[DRE-commits] [SCM] Packaging for ruby-lapack branch, master, updated. upstream/1.2-6-gf131914
Youhei SASAKI
uwabami at gfd-dennou.org
Mon May 2 07:37:29 UTC 2011
The following commit has been merged in the master branch:
commit dc928c4e351ca4963966976d37012108d89c7a7b
Author: Youhei SASAKI <uwabami at gfd-dennou.org>
Date: Mon May 2 15:34:59 2011 +0900
Imported Upstream version 1.5
diff --git a/README b/README
deleted file mode 100644
index 4a23e67..0000000
--- a/README
+++ /dev/null
@@ -1,52 +0,0 @@
-* What's Ruby-LAPACK
-Ruby-LAPACK is a Ruby wrapper of LAPACK.
-Requires
-
- * LAPACK (http://www.netlib.org/lapack/)
- * NArray (http://narray.rubyforge.org/index.html.en)
-
-
-* Usage
-returns = NumRu::Lapack.method_name(args)
-
- * Arguments
- * The arguments of each method are the arguments of the corresponding subroutine/function without arguments for output and dimension size of array. Returns
- The methods return the arguments for output of the correspoing subroutine/function.
-
-In the arguments and returns, array (Matrix) is NArray object. The order of Matrix dimensions is the same as the notation of mathematics: x_ij => x[i-1,j-1].
-If you call methods with no arguments, help message will be printed.
-
-
-* Documents
-Documents for individual methods are "doc" directory in the source
-
-
-* Example
-DSYEVR: Compultes selected eigenvalues, and optinally, eigenvectors of a real symmetric matrix.
-The following script calculats the leading eigenvalue and corresponding eigenvector of the matrix (x_11 = 1, x_12 = x_21 = 2, x_22 = 3).
-Ruby method is NumRu::Lapack.dsyevr.
-
-jobz = "V"
-range = "I"
-uplo = "U"
-a = NArray[[1,0],[2,3]]
-vl = vu = 0 # not be used in this example
-il = 1
-iu = 2
-abstol = 0.0
-lwork = 66
-liwork = 26
-
-m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr(jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, liwork)
-
-The corresponding FORTRAN subroutine is DSYEVR.
-
-SUBROUTINE DSYEVR(JOBZ, RANGE, UPLO, N, A, LDA, VL, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO)
-# JOBZ(input), RANGE(input), UPLO(input)
-# N(input), A(input/output), LDA(input)
-# VL(input), IL(input), IU(input), ABSTOL(input)
-# M(output), W(output), Z(output), LDZ(input), ISUPPZ(output)
-# WORK(workspace/output), IWORK(input), LWORK(workspace/output), LIWORK(input)
-# INFO(output)
-
-N is the order of the matrix A, LDA is the leading dimension of array A, and LDZ is the leading dimension of array Z.
diff --git a/README.rdoc b/README.rdoc
new file mode 100644
index 0000000..f9984dd
--- /dev/null
+++ b/README.rdoc
@@ -0,0 +1,73 @@
+= What's Ruby-LAPACK
+
+Ruby-LAPACK is a Ruby wrapper of LAPACK.
+
+= Requires
+
+ * Ruby (http://www.ruby-lang.org/)
+ * LAPACK (http://www.netlib.org/lapack/)
+ * NArray (http://narray.rubyforge.org/index.html.en)
+
+
+= Install
+
+== with gem
+ # gem install ruby-lapack
+
+== build from source
+ % rake
+ % rake tests
+ % sudo rake install
+
+
+= Usage
+
+You need require numru/lapack to use Ruby-lapack
+ require 'numru/lapack'
+
+Each subroutine/function is defined as module function of NumRu::Lapack.
+ returns = NumRu::Lapack.method_name(args)
+
+ * Arguments
+ * The arguments of each method are the arguments of the corresponding subroutine/function without arguments for output, workspace and dimension size of array. Returns
+ The methods return the arguments for output of the correspoing subroutine/function.
+
+In the arguments and returns, array (Matrix) is NArray object. The order of Matrix dimensions is the same as the notation of mathematics: x_ij => x[i-1,j-1].
+If you call methods with the argument of :help=>true, or :usage=>true, help or usage message will be printed, respectively.
+ NumRu::Lapack.method_name(:help => true)
+ NumRu::Lapack.method_name(:usage => true)
+
+
+= Documents
+
+Documents for individual methods are "doc" directory in the source
+
+
+= Example
+
+DSYEVR: Compultes selected eigenvalues, and optinally, eigenvectors of a real symmetric matrix.
+The following script calculats the leading eigenvalue and corresponding eigenvector of the matrix (x_11 = 1, x_12 = x_21 = 2, x_22 = 3).
+Ruby method is NumRu::Lapack.dsyevr.
+
+jobz = "V"
+range = "I"
+uplo = "U"
+a = NArray[[1,2],[2,3]]
+vl = vu = 0 # not be used in this example
+il = 1
+iu = 2
+abstol = 0.0
+
+m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr(jobz, range, uplo, a, vl, vu, il, iu, abstol)
+
+The corresponding FORTRAN subroutine is DSYEVR.
+
+SUBROUTINE DSYEVR(JOBZ, RANGE, UPLO, N, A, LDA, VL, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO)
+# JOBZ(input), RANGE(input), UPLO(input)
+# N(input), A(input/output), LDA(input)
+# VL(input), IL(input), IU(input), ABSTOL(input)
+# M(output), W(output), Z(output), LDZ(input), ISUPPZ(output)
+# WORK(workspace/output), LWORK(input), IWORK(workspace/output), LIWORK(input)
+# INFO(output)
+
+N is order of the matrix A, LDA is size of the leading dimension of the array A, and LDZ is size of the leading dimension of the array Z, LWORK is size of the array WORK, and LIWORK is size of the array IWORK.
diff --git a/Rakefile b/Rakefile
new file mode 100644
index 0000000..9bfc3c5
--- /dev/null
+++ b/Rakefile
@@ -0,0 +1,121 @@
+require "rubygems"
+require "rake/clean"
+require "rake/gempackagetask"
+require "rake/testtask"
+
+version = 1.5
+target_prefix = "numru"
+
+# get options
+destdir = ENV["DESTDIR"]
+libdir = ENV["SITELIBDIR"] || Config::CONFIG["sitelibdir"]
+archdir = ENV["SITEARCHDIR"] || Config::CONFIG["sitearchdir"]
+config_opts = ENV["CONFIG_OPTIONS"]
+
+NAME = "lapack"
+LIBS = FileList["lib/#{target_prefix}/*rb"]
+DLLIB = "ext/#{NAME}.so"
+so_file = File.join("lib", target_prefix, "#{NAME}.so")
+
+
+task :default => so_file
+
+desc "Building extensions"
+file so_file => DLLIB do
+ mkdir_p File.dirname(so_file)
+ rm_f so_file
+ cp DLLIB, so_file
+end
+file DLLIB => "ext/Makefile" do
+ system("cd ext; make")
+end
+file "ext/Makefile" => "ext/rb_lapack.h" do
+ unless system("cd ext; ruby extconf.rb #{config_opts}")
+ warn <<-EOL
+
+To give options to extconf.rb, set the options to CONFIG_OPTIONS
+e.g.
+% rake CONFIG_OPTIONS="--with-lapack=/opt/lapack"
+ EOL
+ end
+end
+file "ext/rb_lapack.h" => "dev/make_csrc.rb" do
+ system("ruby dev/make_csrc.rb")
+end
+
+desc "Install files to system"
+task :install => [:install_so, :install_rb]
+
+task :install_so => DLLIB do
+ dst = File.join(destdir, archdir, target_prefix)
+ mkdir_p dst
+ install DLLIB, dst, :mode => 0755
+end
+
+task :install_rb => LIBS do
+ dst = File.join(destdir, libdir, target_prefix)
+ mkdir_p dst
+ LIBS.each do |lib|
+ install lib, dst, :mode => 644
+ end
+end
+
+CLEAN.include("ext/*.o")
+CLOBBER.include(DLLIB, so_file)
+CLOBBER.include("ext/Makefile")
+
+
+PKG_FILES = FileList["lib/#{target_prefix}/*rb"]
+PKG_FILES.include("ext/rb_lapack.h")
+PKG_FILES.include("ext/f2c_minimal.h")
+PKG_FILES.include("ext/*.c")
+PKG_FILES.include("Rakefile")
+PKG_FILES.include("COPYING", "GPL", "README.rdoc")
+PKG_FILES.include("doc/*.html", "samples/**/*rb")
+PKG_FILES.include("dev/*.rb", "dev/defs/*")
+TEST_FILES = FileList["tests/**/*.rb"]
+
+Rake::TestTask.new do |t|
+ t.libs << "lib"
+ t.libs << "tests"
+ t.test_files = TEST_FILES
+end
+
+spec = Gem::Specification.new do |s|
+ s.name = "ruby-lapack"
+ s.version = version
+ s.summary = "A Ruby wrapper of Lapack"
+ s.description = <<EOL
+Ruby-LAPACK is a Ruby wrapper of Lapack, which is a linear algebra package (http://www.netlib.org/lapack/).
+EOL
+ s.author = "Seiya Nishizawa"
+ s.email = "seiya at gfd-dennou.org"
+ s.homepage = "http://ruby.gfd-dennou.org/products/ruby-lapack/"
+ s.has_rdoc = false
+ s.files = PKG_FILES
+ s.test_files = TEST_FILES
+ s.add_dependency('narray')
+ s.extensions = %w(ext/extconf.rb)
+end
+
+
+Rake::GemPackageTask.new(spec) do |pkg|
+ pkg.need_tar_gz = true
+ pkg.need_tar_bz2 = true
+end
+
+
+
+binary_pkg = "pkg/#{spec.name}-#{spec.version}-#{Config::CONFIG["arch"]}.gem"
+desc "Build binary package"
+task :binary_package => binary_pkg
+
+file binary_pkg => so_file do
+ files = PKG_FILES.dup
+ files.include so_file
+ spec.platform = Gem::Platform::CURRENT
+ spec.files = files
+ spec.extensions = []
+ Gem::Builder.new(spec).build
+ mv File.basename(binary_pkg), binary_pkg
+end
diff --git a/cbbcsd.c b/cbbcsd.c
deleted file mode 100644
index e500952..0000000
--- a/cbbcsd.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cbbcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, integer *m, integer *p, integer *q, real *theta, real *phi, complex *u1, integer *ldu1, complex *u2, integer *ldu2, complex *v1t, integer *ldv1t, complex *v2t, integer *ldv2t, real *b11d, real *b11e, real *b12d, real *b12e, real *b21d, real *b21e, real *b22d, real *b22e, real *rwork, integer *lrwork, integer *info);
-
-static VALUE
-rb_cbbcsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_theta;
- real *theta;
- VALUE rb_phi;
- real *phi;
- VALUE rb_u1;
- complex *u1;
- VALUE rb_u2;
- complex *u2;
- VALUE rb_v1t;
- complex *v1t;
- VALUE rb_v2t;
- complex *v2t;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_b11d;
- real *b11d;
- VALUE rb_b11e;
- real *b11e;
- VALUE rb_b12d;
- real *b12d;
- VALUE rb_b12e;
- real *b12e;
- VALUE rb_b21d;
- real *b21d;
- VALUE rb_b21e;
- real *b21e;
- VALUE rb_b22d;
- real *b22d;
- VALUE rb_b22e;
- real *b22e;
- VALUE rb_info;
- integer info;
- VALUE rb_theta_out__;
- real *theta_out__;
- VALUE rb_u1_out__;
- complex *u1_out__;
- VALUE rb_u2_out__;
- complex *u2_out__;
- VALUE rb_v1t_out__;
- complex *v1t_out__;
- VALUE rb_v2t_out__;
- complex *v2t_out__;
- real *rwork;
-
- integer q;
- integer ldu1;
- integer p;
- integer ldu2;
- integer ldv1t;
- integer ldv2t;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, lrwork)\n or\n NumRu::Lapack.cbbcsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n* Purpose\n* =======\n*\n* CBBCSD computes the CS decomposition of a unitary matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See CUNCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The unitary matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the unitary matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) REAL array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) REAL array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) COMPLEX array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) COMPLEX array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) COMPLEX array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the conjugate transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) COMPLEX array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the conjugate transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) REAL array, dimension (Q)\n* When CBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If CBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) REAL array, dimension (Q-1)\n* When CBBCSD converges, B11E contains zeros. If CBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) REAL array, dimension (Q)\n* When CBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If CBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) REAL array, dimension (Q-1)\n* When CBBCSD converges, B12E contains zeros. If CBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the RWORK array,\n* returns this value as the first entry of the work array, and\n* no error message related to LRWORK 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* > 0: if CBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_m = argv[5];
- rb_theta = argv[6];
- rb_phi = argv[7];
- rb_u1 = argv[8];
- rb_u2 = argv[9];
- rb_v1t = argv[10];
- rb_v2t = argv[11];
- rb_lrwork = argv[12];
-
- if (!NA_IsNArray(rb_theta))
- rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
- if (NA_RANK(rb_theta) != 1)
- rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
- q = NA_SHAPE0(rb_theta);
- if (NA_TYPE(rb_theta) != NA_SFLOAT)
- rb_theta = na_change_type(rb_theta, NA_SFLOAT);
- theta = NA_PTR_TYPE(rb_theta, real*);
- jobu1 = StringValueCStr(rb_jobu1)[0];
- trans = StringValueCStr(rb_trans)[0];
- m = NUM2INT(rb_m);
- jobu2 = StringValueCStr(rb_jobu2)[0];
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- if (!NA_IsNArray(rb_u1))
- rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
- if (NA_RANK(rb_u1) != 2)
- rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
- p = NA_SHAPE1(rb_u1);
- ldu1 = NA_SHAPE0(rb_u1);
- if (NA_TYPE(rb_u1) != NA_SCOMPLEX)
- rb_u1 = na_change_type(rb_u1, NA_SCOMPLEX);
- u1 = NA_PTR_TYPE(rb_u1, complex*);
- if (!NA_IsNArray(rb_v1t))
- rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
- if (NA_RANK(rb_v1t) != 2)
- rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v1t) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
- ldv1t = NA_SHAPE0(rb_v1t);
- if (NA_TYPE(rb_v1t) != NA_SCOMPLEX)
- rb_v1t = na_change_type(rb_v1t, NA_SCOMPLEX);
- v1t = NA_PTR_TYPE(rb_v1t, complex*);
- if (!NA_IsNArray(rb_u2))
- rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
- if (NA_RANK(rb_u2) != 2)
- rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u2) != (m-p))
- rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
- ldu2 = NA_SHAPE0(rb_u2);
- if (NA_TYPE(rb_u2) != NA_SCOMPLEX)
- rb_u2 = na_change_type(rb_u2, NA_SCOMPLEX);
- u2 = NA_PTR_TYPE(rb_u2, complex*);
- if (!NA_IsNArray(rb_phi))
- rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
- if (NA_RANK(rb_phi) != 1)
- rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_phi) != (q-1))
- rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
- if (NA_TYPE(rb_phi) != NA_SFLOAT)
- rb_phi = na_change_type(rb_phi, NA_SFLOAT);
- phi = NA_PTR_TYPE(rb_phi, real*);
- lrwork = MAX(1,8*q);
- if (!NA_IsNArray(rb_v2t))
- rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
- if (NA_RANK(rb_v2t) != 2)
- rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v2t) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
- ldv2t = NA_SHAPE0(rb_v2t);
- if (NA_TYPE(rb_v2t) != NA_SCOMPLEX)
- rb_v2t = na_change_type(rb_v2t, NA_SCOMPLEX);
- v2t = NA_PTR_TYPE(rb_v2t, complex*);
- {
- int shape[1];
- shape[0] = q;
- rb_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b11d = NA_PTR_TYPE(rb_b11d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b11e = NA_PTR_TYPE(rb_b11e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b12d = NA_PTR_TYPE(rb_b12d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b12e = NA_PTR_TYPE(rb_b12e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b21d = NA_PTR_TYPE(rb_b21d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b21e = NA_PTR_TYPE(rb_b21e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b22d = NA_PTR_TYPE(rb_b22d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b22e = NA_PTR_TYPE(rb_b22e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_theta_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- theta_out__ = NA_PTR_TYPE(rb_theta_out__, real*);
- MEMCPY(theta_out__, theta, real, NA_TOTAL(rb_theta));
- rb_theta = rb_theta_out__;
- theta = theta_out__;
- {
- int shape[2];
- shape[0] = ldu1;
- shape[1] = p;
- rb_u1_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u1_out__ = NA_PTR_TYPE(rb_u1_out__, complex*);
- MEMCPY(u1_out__, u1, complex, NA_TOTAL(rb_u1));
- rb_u1 = rb_u1_out__;
- u1 = u1_out__;
- {
- int shape[2];
- shape[0] = ldu2;
- shape[1] = m-p;
- rb_u2_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u2_out__ = NA_PTR_TYPE(rb_u2_out__, complex*);
- MEMCPY(u2_out__, u2, complex, NA_TOTAL(rb_u2));
- rb_u2 = rb_u2_out__;
- u2 = u2_out__;
- {
- int shape[2];
- shape[0] = ldv1t;
- shape[1] = q;
- rb_v1t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v1t_out__ = NA_PTR_TYPE(rb_v1t_out__, complex*);
- MEMCPY(v1t_out__, v1t, complex, NA_TOTAL(rb_v1t));
- rb_v1t = rb_v1t_out__;
- v1t = v1t_out__;
- {
- int shape[2];
- shape[0] = ldv2t;
- shape[1] = m-q;
- rb_v2t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v2t_out__ = NA_PTR_TYPE(rb_v2t_out__, complex*);
- MEMCPY(v2t_out__, v2t, complex, NA_TOTAL(rb_v2t));
- rb_v2t = rb_v2t_out__;
- v2t = v2t_out__;
- rwork = ALLOC_N(real, (MAX(1,lrwork)));
-
- cbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, &lrwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(14, rb_b11d, rb_b11e, rb_b12d, rb_b12e, rb_b21d, rb_b21e, rb_b22d, rb_b22e, rb_info, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t);
-}
-
-void
-init_lapack_cbbcsd(VALUE mLapack){
- rb_define_module_function(mLapack, "cbbcsd", rb_cbbcsd, -1);
-}
diff --git a/cbdsqr.c b/cbdsqr.c
deleted file mode 100644
index 7c93a2a..0000000
--- a/cbdsqr.c
+++ /dev/null
@@ -1,163 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cbdsqr_(char *uplo, integer *n, integer *ncvt, integer *nru, integer *ncc, real *d, real *e, complex *vt, integer *ldvt, complex *u, integer *ldu, complex *c, integer *ldc, real *rwork, integer *info);
-
-static VALUE
-rb_cbdsqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nru;
- integer nru;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vt;
- complex *vt;
- VALUE rb_u;
- complex *u;
- VALUE rb_c;
- complex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_vt_out__;
- complex *vt_out__;
- VALUE rb_u_out__;
- complex *u_out__;
- VALUE rb_c_out__;
- complex *c_out__;
- real *rwork;
-
- integer n;
- integer ldvt;
- integer ncvt;
- integer ldu;
- integer ldc;
- integer ncc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.cbdsqr( uplo, nru, d, e, vt, u, c)\n or\n NumRu::Lapack.cbdsqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**H\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**H*VT instead of\n* P**H, for given complex input matrices U and VT. When U and VT are\n* the unitary matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by CGEBRD, then\n* \n* A = (U*Q) * S * (P**H*VT)\n* \n* is the SVD of A. Optionally, the subroutine may also compute Q**H*C\n* for a given complex input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B.\n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) COMPLEX array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**H * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) COMPLEX array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) COMPLEX array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**H * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* RWORK (workspace) REAL array, dimension (2*N) \n* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_nru = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vt = argv[4];
- rb_u = argv[5];
- rb_c = argv[6];
-
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (6th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_SCOMPLEX)
- rb_u = na_change_type(rb_u, NA_SCOMPLEX);
- u = NA_PTR_TYPE(rb_u, complex*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
- ncvt = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_SCOMPLEX)
- rb_vt = na_change_type(rb_vt, NA_SCOMPLEX);
- vt = NA_PTR_TYPE(rb_vt, complex*);
- nru = NUM2INT(rb_nru);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = ncvt;
- rb_vt_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, complex*);
- MEMCPY(vt_out__, vt, complex, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, complex*);
- MEMCPY(u_out__, u, complex, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- rwork = ALLOC_N(real, ((ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)));
-
- cbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_info, rb_d, rb_e, rb_vt, rb_u, rb_c);
-}
-
-void
-init_lapack_cbdsqr(VALUE mLapack){
- rb_define_module_function(mLapack, "cbdsqr", rb_cbdsqr, -1);
-}
diff --git a/cgbbrd.c b/cgbbrd.c
deleted file mode 100644
index acb12b5..0000000
--- a/cgbbrd.c
+++ /dev/null
@@ -1,138 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbbrd_(char *vect, integer *m, integer *n, integer *ncc, integer *kl, integer *ku, complex *ab, integer *ldab, real *d, real *e, complex *q, integer *ldq, complex *pt, integer *ldpt, complex *c, integer *ldc, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgbbrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_c;
- complex *c;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_q;
- complex *q;
- VALUE rb_pt;
- complex *pt;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldc;
- integer ncc;
- integer ldq;
- integer m;
- integer ldpt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.cgbbrd( vect, kl, ku, ab, c)\n or\n NumRu::Lapack.cgbbrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBBRD reduces a complex general m-by-n band matrix A to real upper\n* bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) COMPLEX array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) COMPLEX array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) COMPLEX array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) COMPLEX array, dimension (max(M,N))\n*\n* RWORK (workspace) REAL array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- vect = StringValueCStr(rb_vect)[0];
- ku = NUM2INT(rb_ku);
- m = ldab;
- ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
- ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = m;
- rb_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, complex*);
- {
- int shape[2];
- shape[0] = ldpt;
- shape[1] = n;
- rb_pt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- pt = NA_PTR_TYPE(rb_pt, complex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (MAX(m,n)));
- rwork = ALLOC_N(real, (MAX(m,n)));
-
- cgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_q, rb_pt, rb_info, rb_ab, rb_c);
-}
-
-void
-init_lapack_cgbbrd(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbbrd", rb_cgbbrd, -1);
-}
diff --git a/cgbcon.c b/cgbcon.c
deleted file mode 100644
index deee169..0000000
--- a/cgbcon.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbcon_(char *norm, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cgbcon( norm, kl, ku, ab, ipiv, anorm)\n or\n NumRu::Lapack.cgbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBCON estimates the reciprocal of the condition number of a complex\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by CGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\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/(norm(A) * norm(inv(A))).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_anorm = argv[5];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cgbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbcon", rb_cgbcon, -1);
-}
diff --git a/cgbequ.c b/cgbequ.c
deleted file mode 100644
index 347df59..0000000
--- a/cgbequ.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbequ_(integer *m, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_cgbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequ( m, kl, ku, ab)\n or\n NumRu::Lapack.cgbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MAX(1,m);
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- cgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_cgbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbequ", rb_cgbequ, -1);
-}
diff --git a/cgbequb.c b/cgbequb.c
deleted file mode 100644
index afc200d..0000000
--- a/cgbequb.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbequb_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_cgbequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequb( kl, ku, ab)\n or\n NumRu::Lapack.cgbequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from CGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", m);
- m = ldab;
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- ku = NUM2INT(rb_ku);
- ldab = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- cgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_cgbequb(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbequb", rb_cgbequb, -1);
-}
diff --git a/cgbrfs.c b/cgbrfs.c
deleted file mode 100644
index 11f803c..0000000
--- a/cgbrfs.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbrfs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)\n or\n NumRu::Lapack.cgbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGBTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cgbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbrfs", rb_cgbrfs, -1);
-}
diff --git a/cgbrfsx.c b/cgbrfsx.c
deleted file mode 100644
index c9a0261..0000000
--- a/cgbrfsx.c
+++ /dev/null
@@ -1,230 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbrfsx_(char *trans, char *equed, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgbrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.cgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.cgbrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_r = argv[7];
- rb_c = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
- rb_params = argv[11];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (8th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- ku = NUM2INT(rb_ku);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_r, rb_c, rb_x, rb_params);
-}
-
-void
-init_lapack_cgbrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbrfsx", rb_cgbrfsx, -1);
-}
diff --git a/cgbsv.c b/cgbsv.c
deleted file mode 100644
index 566e151..0000000
--- a/cgbsv.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbsv_(integer *n, integer *kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cgbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_b;
- complex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.cgbsv( kl, ku, ab, b)\n or\n NumRu::Lapack.cgbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGBSV computes the solution to a complex system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL CGBTRF, CGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_cgbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbsv", rb_cgbsv, -1);
-}
diff --git a/cgbsvx.c b/cgbsvx.c
deleted file mode 100644
index 1cd1d8f..0000000
--- a/cgbsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbsvx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *ipiv, char *equed, real *r, real *c, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_afb_out__;
- complex *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.cgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.cgbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) COMPLEX array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace/output) REAL array, dimension (N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n* Moved setting of INFO = N+1 so INFO does not subsequently get\n* overwritten. Sven, 17 Mar 05. \n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- equed = StringValueCStr(rb_equed)[0];
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, complex*);
- MEMCPY(afb_out__, afb, complex, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (2*n));
-
- cgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_rwork, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_cgbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbsvx", rb_cgbsvx, -1);
-}
diff --git a/cgbsvxx.c b/cgbsvxx.c
deleted file mode 100644
index 8d6dfc9..0000000
--- a/cgbsvxx.c
+++ /dev/null
@@ -1,270 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbsvxx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, char *equed, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgbsvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_afb_out__;
- real *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.cgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.cgbsvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBSVXX uses the LU factorization to compute the solution to a\n* complex system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In SGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
- rb_params = argv[11];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- fact = StringValueCStr(rb_fact)[0];
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, real*);
- MEMCPY(afb_out__, afb, real, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_cgbsvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbsvxx", rb_cgbsvxx, -1);
-}
diff --git a/cgbtf2.c b/cgbtf2.c
deleted file mode 100644
index 93da3a7..0000000
--- a/cgbtf2.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbtf2_(integer *m, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_cgbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.cgbtf2( m, kl, ku, ab)\n or\n NumRu::Lapack.cgbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGBTF2 computes an LU factorization of a complex m-by-n band matrix\n* A using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- cgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_cgbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbtf2", rb_cgbtf2, -1);
-}
diff --git a/cgbtrf.c b/cgbtrf.c
deleted file mode 100644
index ffd802c..0000000
--- a/cgbtrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbtrf_(integer *m, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_cgbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.cgbtrf( m, kl, ku, ab)\n or\n NumRu::Lapack.cgbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGBTRF computes an LU factorization of a complex m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- cgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_cgbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbtrf", rb_cgbtrf, -1);
-}
diff --git a/cgbtrs.c b/cgbtrs.c
deleted file mode 100644
index 896b430..0000000
--- a/cgbtrs.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgbtrs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cgbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cgbtrs( trans, kl, ku, ab, ipiv, b)\n or\n NumRu::Lapack.cgbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGBTRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general band matrix A using the LU factorization computed\n* by CGBTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cgbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cgbtrs", rb_cgbtrs, -1);
-}
diff --git a/cgebak.c b/cgebak.c
deleted file mode 100644
index 2fa3b31..0000000
--- a/cgebak.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, real *scale, integer *m, complex *v, integer *ldv, integer *info);
-
-static VALUE
-rb_cgebak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- real *scale;
- VALUE rb_v;
- complex *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- complex *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.cgebak( job, side, ilo, ihi, scale, v)\n or\n NumRu::Lapack.cgebak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* CGEBAK forms the right or left eigenvectors of a complex general\n* matrix by backward transformation on the computed eigenvectors of the\n* balanced matrix output by CGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to CGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by CGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) REAL array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by CGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by CHSEIN or CTREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_scale = argv[4];
- rb_v = argv[5];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- if (!NA_IsNArray(rb_scale))
- rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
- if (NA_RANK(rb_scale) != 1)
- rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_scale);
- if (NA_TYPE(rb_scale) != NA_SFLOAT)
- rb_scale = na_change_type(rb_scale, NA_SFLOAT);
- scale = NA_PTR_TYPE(rb_scale, real*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- job = StringValueCStr(rb_job)[0];
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, complex*);
- MEMCPY(v_out__, v, complex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- cgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_cgebak(VALUE mLapack){
- rb_define_module_function(mLapack, "cgebak", rb_cgebak, -1);
-}
diff --git a/cgebal.c b/cgebal.c
deleted file mode 100644
index 25f1daa..0000000
--- a/cgebal.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgebal_(char *job, integer *n, complex *a, integer *lda, integer *ilo, integer *ihi, real *scale, integer *info);
-
-static VALUE
-rb_cgebal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- complex *a;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- real *scale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.cgebal( job, a)\n or\n NumRu::Lapack.cgebal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* CGEBAL balances a general complex matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine CBAL.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
-
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ilo, rb_ihi, rb_scale, rb_info, rb_a);
-}
-
-void
-init_lapack_cgebal(VALUE mLapack){
- rb_define_module_function(mLapack, "cgebal", rb_cgebal, -1);
-}
diff --git a/cgebd2.c b/cgebd2.c
deleted file mode 100644
index 6c9a6ae..0000000
--- a/cgebd2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgebd2_(integer *m, integer *n, complex *a, integer *lda, real *d, real *e, complex *tauq, complex *taup, complex *work, integer *info);
-
-static VALUE
-rb_cgebd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tauq;
- complex *tauq;
- VALUE rb_taup;
- complex *taup;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.cgebd2( m, a)\n or\n NumRu::Lapack.cgebd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEBD2 reduces a complex general m by n matrix A to upper or lower\n* real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace) COMPLEX array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit \n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, v and u are complex vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, complex*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (MAX(m,n)));
-
- cgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tauq, rb_taup, rb_info, rb_a);
-}
-
-void
-init_lapack_cgebd2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgebd2", rb_cgebd2, -1);
-}
diff --git a/cgebrd.c b/cgebrd.c
deleted file mode 100644
index 9640d58..0000000
--- a/cgebrd.c
+++ /dev/null
@@ -1,102 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgebrd_(integer *m, integer *n, complex *a, integer *lda, real *d, real *e, complex *tauq, complex *taup, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgebrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tauq;
- complex *tauq;
- VALUE rb_taup;
- complex *taup;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.cgebrd( m, a, lwork)\n or\n NumRu::Lapack.cgebrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEBRD reduces a general complex M-by-N matrix A to upper or lower\n* bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, complex*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgebrd(VALUE mLapack){
- rb_define_module_function(mLapack, "cgebrd", rb_cgebrd, -1);
-}
diff --git a/cgecon.c b/cgecon.c
deleted file mode 100644
index 6c8ac0e..0000000
--- a/cgecon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgecon_(char *norm, integer *n, complex *a, integer *lda, real *anorm, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgecon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- complex *a;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cgecon( norm, a, anorm)\n or\n NumRu::Lapack.cgecon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGECON estimates the reciprocal of the condition number of a general\n* complex matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by CGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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/(norm(A) * norm(inv(A))).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- norm = StringValueCStr(rb_norm)[0];
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cgecon(VALUE mLapack){
- rb_define_module_function(mLapack, "cgecon", rb_cgecon, -1);
-}
diff --git a/cgeequ.c b/cgeequ.c
deleted file mode 100644
index 3c3e9b0..0000000
--- a/cgeequ.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeequ_(integer *m, integer *n, complex *a, integer *lda, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_cgeequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequ( a)\n or\n NumRu::Lapack.cgeequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- cgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_cgeequ(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeequ", rb_cgeequ, -1);
-}
diff --git a/cgeequb.c b/cgeequb.c
deleted file mode 100644
index 7782273..0000000
--- a/cgeequb.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeequb_(integer *m, integer *n, complex *a, integer *lda, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_cgeequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequb( a)\n or\n NumRu::Lapack.cgeequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from CGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lda = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- cgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_cgeequb(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeequb", rb_cgeequb, -1);
-}
diff --git a/cgees.c b/cgees.c
deleted file mode 100644
index b4528f1..0000000
--- a/cgees.c
+++ /dev/null
@@ -1,117 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(complex *arg0){
- VALUE rb_arg0;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
-
- rb_ret = rb_yield_values(1, rb_arg0);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID cgees_(char *jobvs, char *sort, L_fp *select, integer *n, complex *a, integer *lda, integer *sdim, complex *w, complex *vs, integer *ldvs, complex *work, integer *lwork, real *rwork, logical *bwork, integer *info);
-
-static VALUE
-rb_cgees(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_w;
- complex *w;
- VALUE rb_vs;
- complex *vs;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, w, vs, work, info, a = NumRu::Lapack.cgees( jobvs, sort, a, lwork){|a| ... }\n or\n NumRu::Lapack.cgees # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEES computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered:\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* IF SORT = 'N', SELECT is not referenced.\n* The eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues, in the same order that\n* they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged;\n* if JOBVS = 'V', VS contains the matrix which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because\n* some eigenvalues were too close to separate (the\n* problem is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Schur form no longer satisfy\n* SELECT = .TRUE.. This could also be caused by\n* underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- lwork = NUM2INT(rb_lwork);
- sort = StringValueCStr(rb_sort)[0];
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- cgees_(&jobvs, &sort, rb_select, &n, a, &lda, &sdim, w, vs, &ldvs, work, &lwork, rwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_sdim, rb_w, rb_vs, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgees(VALUE mLapack){
- rb_define_module_function(mLapack, "cgees", rb_cgees, -1);
-}
diff --git a/cgeesx.c b/cgeesx.c
deleted file mode 100644
index 6df0181..0000000
--- a/cgeesx.c
+++ /dev/null
@@ -1,127 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(complex *arg0){
- VALUE rb_arg0;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
-
- rb_ret = rb_yield_values(1, rb_arg0);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID cgeesx_(char *jobvs, char *sort, L_fp *select, char *sense, integer *n, complex *a, integer *lda, integer *sdim, complex *w, complex *vs, integer *ldvs, real *rconde, real *rcondv, complex *work, integer *lwork, real *rwork, logical *bwork, integer *info);
-
-static VALUE
-rb_cgeesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_w;
- complex *w;
- VALUE rb_vs;
- complex *vs;
- VALUE rb_rconde;
- real rconde;
- VALUE rb_rcondv;
- real rcondv;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.cgeesx( jobvs, sort, sense, a, lwork){|a| ... }\n or\n NumRu::Lapack.cgeesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the N-by-N matrix A.\n* On exit, A is overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues, in the same order\n* that they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) REAL\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n* where SDIM is the number of selected eigenvalues computed by\n* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n* that an error is only returned if LWORK < max(1,2*N), but if\n* SENSE = 'E' or 'V' or 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bound on the optimal size of the\n* array WORK, returns this value as the first entry of the WORK\n* array, and no error message related to LWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) REAL array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_sense = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- cgeesx_(&jobvs, &sort, rb_select, &sense, &n, a, &lda, &sdim, w, vs, &ldvs, &rconde, &rcondv, work, &lwork, rwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_rconde = rb_float_new((double)rconde);
- rb_rcondv = rb_float_new((double)rcondv);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_sdim, rb_w, rb_vs, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeesx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeesx", rb_cgeesx, -1);
-}
diff --git a/cgeev.c b/cgeev.c
deleted file mode 100644
index 277cf81..0000000
--- a/cgeev.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeev_(char *jobvl, char *jobvr, integer *n, complex *a, integer *lda, complex *w, complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgeev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- complex *w;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, vl, vr, work, info, a = NumRu::Lapack.cgeev( jobvl, jobvr, a, lwork)\n or\n NumRu::Lapack.cgeev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements and i+1:N of W contain eigenvalues which have\n* converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, complex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (2*n));
-
- cgeev_(&jobvl, &jobvr, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_vl, rb_vr, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeev(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeev", rb_cgeev, -1);
-}
diff --git a/cgeevx.c b/cgeevx.c
deleted file mode 100644
index 2cf6fbf..0000000
--- a/cgeevx.c
+++ /dev/null
@@ -1,148 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, complex *a, integer *lda, complex *w, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi, real *scale, real *abnrm, real *rconde, real *rcondv, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgeevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- complex *w;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- real *scale;
- VALUE rb_abnrm;
- real abnrm;
- VALUE rb_rconde;
- real *rconde;
- VALUE rb_rcondv;
- real *rcondv;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.cgeevx( balanc, jobvl, jobvr, sense, a, lwork)\n or\n NumRu::Lapack.cgeevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, ie. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the Schur form of the balanced \n* version of the matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and\n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) REAL array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) REAL array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\n*\n* WORK (workspace/output) COMPLEX 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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n* LWORK >= N*N+2*N.\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of W\n* contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- sense = StringValueCStr(rb_sense)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, complex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (2*n));
-
- cgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_w, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_scale, rb_abnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeevx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeevx", rb_cgeevx, -1);
-}
diff --git a/cgegs.c b/cgegs.c
deleted file mode 100644
index 4f78fa0..0000000
--- a/cgegs.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgegs_(char *jobvsl, char *jobvsr, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgegs(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_vsl;
- complex *vsl;
- VALUE rb_vsr;
- complex *vsr;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgegs( jobvsl, jobvsr, a, b, lwork)\n or\n NumRu::Lapack.cgegs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGGES.\n*\n* CGEGS computes the eigenvalues, Schur form, and, optionally, the\n* left and or/right Schur vectors of a complex matrix pair (A,B).\n* Given two square matrices A and B, the generalized Schur\n* factorization has the form\n* \n* A = Q*S*Z**H, B = Q*T*Z**H\n* \n* where Q and Z are unitary matrices and S and T are upper triangular.\n* The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n* \n* If only the eigenvalues of (A,B) are needed, the driver routine\n* CGEGV should be used instead. See CGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper triangular matrix S from the generalized\n* Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur\n* form of A.\n*\n* BETA (output) COMPLEX array, dimension (N)\n* The non-negative real scalars beta that define the\n* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element\n* of the triangular factor T.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* VSL (output) COMPLEX array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n* the optimal LWORK is N*(NB+1).\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* RWORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from CGGBAL\n* =N+2: error return from CGEQRF\n* =N+3: error return from CUNMQR\n* =N+4: error return from CUNGQR\n* =N+5: error return from CGGHRD\n* =N+6: error return from CHGEQZ (other than failed\n* iteration)\n* =N+7: error return from CGGBAK (computing VSL)\n* =N+8: error return from CGGBAK (computing VSR)\n* =N+9: error return from CLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, complex*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (3*n));
-
- cgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_alpha, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cgegs(VALUE mLapack){
- rb_define_module_function(mLapack, "cgegs", rb_cgegs, -1);
-}
diff --git a/cgegv.c b/cgegv.c
deleted file mode 100644
index 118546c..0000000
--- a/cgegv.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgegv_(char *jobvl, char *jobvr, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgegv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cgegv( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.cgegv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGGEV.\n*\n* CGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a complex matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n* \n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing. If no\n* eigenvectors were computed, then only the diagonal elements\n* of the Schur form will be correct. See CGGHRD and CHGEQZ\n* for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* elements of B will be correct. See CGGHRD and CHGEQZ for\n* details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP.\n*\n* BETA (output) COMPLEX array, dimension (N)\n* The complex scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n* The optimal LWORK is MAX( 2*N, N*(NB+1) ).\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* RWORK (workspace/output) REAL array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from CGGBAL\n* =N+2: error return from CGEQRF\n* =N+3: error return from CUNMQR\n* =N+4: error return from CUNGQR\n* =N+5: error return from CGGHRD\n* =N+6: error return from CHGEQZ (other than failed\n* iteration)\n* =N+7: error return from CTGEVC\n* =N+8: error return from CGGBAK (computing VL)\n* =N+9: error return from CGGBAK (computing VR)\n* =N+10: error return from CLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls CGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, CGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the complex Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] In other words, upper triangular form.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, complex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = 8*n;
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_vl, rb_vr, rb_work, rb_rwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cgegv(VALUE mLapack){
- rb_define_module_function(mLapack, "cgegv", rb_cgegv, -1);
-}
diff --git a/cgehd2.c b/cgehd2.c
deleted file mode 100644
index f3b0372..0000000
--- a/cgehd2.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgehd2_(integer *n, integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cgehd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgehd2( ilo, ihi, a)\n or\n NumRu::Lapack.cgehd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n* by a unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to CGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n));
-
- cgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_cgehd2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgehd2", rb_cgehd2, -1);
-}
diff --git a/cgehrd.c b/cgehrd.c
deleted file mode 100644
index 81d09b9..0000000
--- a/cgehrd.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgehrd_(integer *n, integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgehrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgehrd( ilo, ihi, a, lwork)\n or\n NumRu::Lapack.cgehrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n* an unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to CGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) COMPLEX array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ilo = NUM2INT(rb_ilo);
- lwork = NUM2INT(rb_lwork);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgehrd(VALUE mLapack){
- rb_define_module_function(mLapack, "cgehrd", rb_cgehrd, -1);
-}
diff --git a/cgelq2.c b/cgelq2.c
deleted file mode 100644
index 572ac70..0000000
--- a/cgelq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgelq2_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cgelq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgelq2( a)\n or\n NumRu::Lapack.cgelq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELQ2 computes an LQ factorization of a complex m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (m));
-
- cgelq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_cgelq2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgelq2", rb_cgelq2, -1);
-}
diff --git a/cgelqf.c b/cgelqf.c
deleted file mode 100644
index 50ad345..0000000
--- a/cgelqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgelqf_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgelqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgelqf( m, a, lwork)\n or\n NumRu::Lapack.cgelqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELQF computes an LQ factorization of a complex M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGELQ2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgelqf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgelqf", rb_cgelqf, -1);
-}
diff --git a/cgels.c b/cgels.c
deleted file mode 100644
index 4df5bd3..0000000
--- a/cgels.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgels_(char *trans, integer *m, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgels(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.cgels( trans, m, a, b, lwork)\n or\n NumRu::Lapack.cgels # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELS solves overdetermined or underdetermined complex linear systems\n* involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n* or LQ factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided:\n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of\n* an undetermined system A**H * X = B.\n*\n* 4. If TRANS = 'C' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**H * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'C': the linear system involves A**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by CGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by CGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'C'.\n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of the\n* modulus of elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of the modulus of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cgels(VALUE mLapack){
- rb_define_module_function(mLapack, "cgels", rb_cgels, -1);
-}
diff --git a/cgelsd.c b/cgelsd.c
deleted file mode 100644
index bbb9162..0000000
--- a/cgelsd.c
+++ /dev/null
@@ -1,129 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgelsd_(integer *m, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, real *s, real *rcond, integer *rank, complex *work, integer *lwork, real *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_cgelsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer c__9;
- integer c__0;
- integer lrwork;
- integer liwork;
- integer smlsiz;
- integer nlvl;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.cgelsd( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.cgelsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder tranformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX 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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 2 * N + N * NRHS\n* if M is greater than or equal to N or\n* 2 * M + M * NRHS\n* if M is less than N, the code will execute correctly.\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the array WORK and the\n* minimum sizes of the arrays RWORK and IWORK, and returns\n* these values as the first entries of the WORK, RWORK and\n* IWORK arrays, and no error message related to LWORK is issued\n* by XERBLA.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n* LRWORK >=\n* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is greater than or equal to N or\n* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- c__9 = 9;
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- c__0 = 0;
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- smlsiz = ilaenv_(&c__9,"CGELSD"," ",&c__0,&c__0,&c__0,&c__0);
- nlvl = MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)));
- liwork = MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)));
- lrwork = m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (MAX(1,lrwork)));
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
-
- cgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, iwork, &info);
-
- free(rwork);
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_rank, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cgelsd(VALUE mLapack){
- rb_define_module_function(mLapack, "cgelsd", rb_cgelsd, -1);
-}
diff --git a/cgelss.c b/cgelss.c
deleted file mode 100644
index 66d61db..0000000
--- a/cgelss.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgelss_(integer *m, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, real *s, real *rcond, integer *rank, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgelss(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.cgelss( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.cgelss # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELSS computes the minimum norm solution to a complex linear\n* least squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX 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, and also:\n* LWORK >= 2*min(M,N) + max(M,N,NRHS)\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) REAL array, dimension (5*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (5*MIN(m,n)));
-
- cgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_rank, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cgelss(VALUE mLapack){
- rb_define_module_function(mLapack, "cgelss", rb_cgelss, -1);
-}
diff --git a/cgelsx.c b/cgelsx.c
deleted file mode 100644
index 06709e8..0000000
--- a/cgelsx.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgelsx_(integer *m, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond, integer *rank, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgelsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, a, b, jpvt = NumRu::Lapack.cgelsx( m, a, b, jpvt, rcond)\n or\n NumRu::Lapack.cgelsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGELSY.\n*\n* CGELSX computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) COMPLEX array, dimension\n* (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n*\n* RWORK (workspace) REAL array, dimension (2*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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(complex, (MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)));
- rwork = ALLOC_N(real, (2*n));
-
- cgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_cgelsx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgelsx", rb_cgelsx, -1);
-}
diff --git a/cgelsy.c b/cgelsy.c
deleted file mode 100644
index c30141d..0000000
--- a/cgelsy.c
+++ /dev/null
@@ -1,129 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgelsy_(integer *m, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond, integer *rank, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgelsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.cgelsy( m, a, b, jpvt, rcond, lwork)\n or\n NumRu::Lapack.cgelsy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELSY computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace/output) COMPLEX 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.\n* The unblocked strategy requires that:\n* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n* where MN = min(M,N).\n* The block algorithm requires that:\n* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR,\n* and CUNMRZ.\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* RWORK (workspace) REAL array, dimension (2*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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
- rb_lwork = argv[5];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- rwork = ALLOC_N(real, (2*n));
-
- cgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_rank, rb_work, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_cgelsy(VALUE mLapack){
- rb_define_module_function(mLapack, "cgelsy", rb_cgelsy, -1);
-}
diff --git a/cgeql2.c b/cgeql2.c
deleted file mode 100644
index 6a0a68d..0000000
--- a/cgeql2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeql2_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cgeql2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgeql2( m, a)\n or\n NumRu::Lapack.cgeql2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQL2 computes a QL factorization of a complex m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n));
-
- cgeql2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeql2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeql2", rb_cgeql2, -1);
-}
diff --git a/cgeqlf.c b/cgeqlf.c
deleted file mode 100644
index 378581f..0000000
--- a/cgeqlf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeqlf_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgeqlf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgeqlf( m, a, lwork)\n or\n NumRu::Lapack.cgeqlf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQLF computes a QL factorization of a complex M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQL2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeqlf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeqlf", rb_cgeqlf, -1);
-}
diff --git a/cgeqp3.c b/cgeqp3.c
deleted file mode 100644
index 926e0e1..0000000
--- a/cgeqp3.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeqp3_(integer *m, integer *n, complex *a, integer *lda, integer *jpvt, complex *tau, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgeqp3(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- real *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.cgeqp3( m, a, jpvt, lwork)\n or\n NumRu::Lapack.cgeqp3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* unitary matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX 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 >= N+1.\n* For optimal performance LWORK >= ( N+1 )*NB, where NB\n* is the optimal blocksize.\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* RWORK (workspace) REAL array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- rwork = ALLOC_N(real, (2*n));
-
- cgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_tau, rb_work, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_cgeqp3(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeqp3", rb_cgeqp3, -1);
-}
diff --git a/cgeqpf.c b/cgeqpf.c
deleted file mode 100644
index 3d7d9fb..0000000
--- a/cgeqpf.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeqpf_(integer *m, integer *n, complex *a, integer *lda, integer *jpvt, complex *tau, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgeqpf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.cgeqpf( m, a, jpvt)\n or\n NumRu::Lapack.cgeqpf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGEQP3.\n*\n* CGEQPF computes a QR factorization with column pivoting of a\n* complex M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the unitary matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (2*n));
-
- cgeqpf_(&m, &n, a, &lda, jpvt, tau, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_cgeqpf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeqpf", rb_cgeqpf, -1);
-}
diff --git a/cgeqr2.c b/cgeqr2.c
deleted file mode 100644
index a2c4aeb..0000000
--- a/cgeqr2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeqr2_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cgeqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgeqr2( m, a)\n or\n NumRu::Lapack.cgeqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQR2 computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n));
-
- cgeqr2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeqr2", rb_cgeqr2, -1);
-}
diff --git a/cgeqr2p.c b/cgeqr2p.c
deleted file mode 100644
index 744e387..0000000
--- a/cgeqr2p.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeqr2p_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cgeqr2p(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgeqr2p( m, a)\n or\n NumRu::Lapack.cgeqr2p # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQR2P computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n));
-
- cgeqr2p_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeqr2p(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeqr2p", rb_cgeqr2p, -1);
-}
diff --git a/cgeqrf.c b/cgeqrf.c
deleted file mode 100644
index 3900f98..0000000
--- a/cgeqrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeqrf_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgeqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgeqrf( m, a, lwork)\n or\n NumRu::Lapack.cgeqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQRF computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQR2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeqrf", rb_cgeqrf, -1);
-}
diff --git a/cgeqrfp.c b/cgeqrfp.c
deleted file mode 100644
index f7e198e..0000000
--- a/cgeqrfp.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgeqrfp_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgeqrfp(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgeqrfp( m, a, lwork)\n or\n NumRu::Lapack.cgeqrfp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQR2P, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgeqrfp(VALUE mLapack){
- rb_define_module_function(mLapack, "cgeqrfp", rb_cgeqrfp, -1);
-}
diff --git a/cgerfs.c b/cgerfs.c
deleted file mode 100644
index d07ed8b..0000000
--- a/cgerfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgerfs_(char *trans, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgerfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cgerfs( trans, a, af, ipiv, b, x)\n or\n NumRu::Lapack.cgerfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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)\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* A (input) COMPLEX array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGETRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cgerfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cgerfs", rb_cgerfs, -1);
-}
diff --git a/cgerfsx.c b/cgerfsx.c
deleted file mode 100644
index db15aff..0000000
--- a/cgerfsx.c
+++ /dev/null
@@ -1,200 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgerfsx_(char *trans, char *equed, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, real *r, real *c, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgerfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.cgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.cgerfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. \n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_r = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_x = argv[8];
- rb_params = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (9th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (6th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_x, rb_params);
-}
-
-void
-init_lapack_cgerfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgerfsx", rb_cgerfsx, -1);
-}
diff --git a/cgerq2.c b/cgerq2.c
deleted file mode 100644
index 67f2ece..0000000
--- a/cgerq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgerq2_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cgerq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgerq2( a)\n or\n NumRu::Lapack.cgerq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERQ2 computes an RQ factorization of a complex m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the unitary matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (m));
-
- cgerq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_cgerq2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgerq2", rb_cgerq2, -1);
-}
diff --git a/cgerqf.c b/cgerqf.c
deleted file mode 100644
index 37321fc..0000000
--- a/cgerqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgerqf_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgerqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgerqf( m, a, lwork)\n or\n NumRu::Lapack.cgerqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERQF computes an RQ factorization of a complex M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGERQ2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgerqf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgerqf", rb_cgerqf, -1);
-}
diff --git a/cgesc2.c b/cgesc2.c
deleted file mode 100644
index 1faedc5..0000000
--- a/cgesc2.c
+++ /dev/null
@@ -1,89 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgesc2_(integer *n, complex *a, integer *lda, complex *rhs, integer *ipiv, integer *jpiv, real *scale);
-
-static VALUE
-rb_cgesc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_rhs;
- complex *rhs;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_scale;
- real scale;
- VALUE rb_rhs_out__;
- complex *rhs_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.cgesc2( a, rhs, ipiv, jpiv)\n or\n NumRu::Lapack.cgesc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* CGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by CGETC2.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX array, dimension (LDA, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by CGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) COMPLEX array, dimension N.\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) REAL\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_rhs = argv[1];
- rb_ipiv = argv[2];
- rb_jpiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_SCOMPLEX)
- rb_rhs = na_change_type(rb_rhs, NA_SCOMPLEX);
- rhs = NA_PTR_TYPE(rb_rhs, complex*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, complex*);
- MEMCPY(rhs_out__, rhs, complex, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- cgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
-
- rb_scale = rb_float_new((double)scale);
- return rb_ary_new3(2, rb_scale, rb_rhs);
-}
-
-void
-init_lapack_cgesc2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgesc2", rb_cgesc2, -1);
-}
diff --git a/cgesdd.c b/cgesdd.c
deleted file mode 100644
index f7c0a2c..0000000
--- a/cgesdd.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgesdd_(char *jobz, integer *m, integer *n, complex *a, integer *lda, real *s, complex *u, integer *ldu, complex *vt, integer *ldvt, complex *work, integer *lwork, real *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_cgesdd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_u;
- complex *u;
- VALUE rb_vt;
- complex *vt;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldu;
- integer ucol;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.cgesdd( jobz, m, a, lwork)\n or\n NumRu::Lapack.cgesdd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESDD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors, by using divide-and-conquer method. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**H, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**H are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**H are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* in the array A and all rows of V**H are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**H are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**H are computed.\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 >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**H (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* unitary matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) COMPLEX array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N unitary matrix V**H;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX 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 JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n* if JOBZ = 'O',\n* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* if JOBZ = 'S' or 'A',\n* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, a workspace query is assumed. The optimal\n* size for the WORK array is calculated and stored in WORK(1),\n* and no other work except argument checking is performed.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n* If JOBZ = 'N', LRWORK >= 5*min(M,N).\n* Otherwise, \n* LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The updating process of SBDSDC did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- jobz = StringValueCStr(rb_jobz)[0];
- ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
- ldu = ((lsame_(&jobz,"S")) || ((('a') || (((lsame_(&jobz,"O")) && (m < n)))))) ? m : 1;
- ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m == n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = ucol;
- rb_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, complex*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (MAX(1, lsame_(&jobz,"N") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1))));
- iwork = ALLOC_N(integer, (8*MIN(m,n)));
-
- cgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info);
-
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgesdd(VALUE mLapack){
- rb_define_module_function(mLapack, "cgesdd", rb_cgesdd, -1);
-}
diff --git a/cgesv.c b/cgesv.c
deleted file mode 100644
index f333518..0000000
--- a/cgesv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgesv_(integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cgesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.cgesv( a, b)\n or\n NumRu::Lapack.cgesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL CGETRF, CGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cgesv(VALUE mLapack){
- rb_define_module_function(mLapack, "cgesv", rb_cgesv, -1);
-}
diff --git a/cgesvd.c b/cgesvd.c
deleted file mode 100644
index bc2a8c1..0000000
--- a/cgesvd.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgesvd_(char *jobu, char *jobvt, integer *m, integer *n, complex *a, integer *lda, real *s, complex *u, integer *ldu, complex *vt, integer *ldvt, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cgesvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobvt;
- char jobvt;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_u;
- complex *u;
- VALUE rb_vt;
- complex *vt;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldu;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.cgesvd( jobu, jobvt, m, a, lwork)\n or\n NumRu::Lapack.cgesvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESVD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**H, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**H:\n* = 'A': all N rows of V**H are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**H (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**H (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**H (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**H (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M unitary matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) COMPLEX array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N unitary matrix\n* V**H;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) REAL array, dimension (5*min(M,N))\n* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n* unconverged superdiagonal elements of an upper bidiagonal\n* matrix B whose diagonal is in S (not necessarily sorted).\n* B satisfies A = U * B * VT, so it has the same singular\n* values as A, and singular vectors related by U and VT.\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 CBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of RWORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobvt = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- jobvt = StringValueCStr(rb_jobvt)[0];
- lwork = NUM2INT(rb_lwork);
- jobu = StringValueCStr(rb_jobu)[0];
- ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
- ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
- rb_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, complex*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (5*MIN(m,n)));
-
- cgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgesvd(VALUE mLapack){
- rb_define_module_function(mLapack, "cgesvd", rb_cgesvd, -1);
-}
diff --git a/cgesvx.c b/cgesvx.c
deleted file mode 100644
index fdc1b2f..0000000
--- a/cgesvx.c
+++ /dev/null
@@ -1,229 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgesvx_(char *fact, char *trans, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, char *equed, real *r, real *c, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgesvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.cgesvx( fact, trans, a, af, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.cgesvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESVX uses the LU factorization to compute the solution to a complex\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace/output) REAL array, dimension (2*N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = 2*n;
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (2*n));
-
- cgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_rwork, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_cgesvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgesvx", rb_cgesvx, -1);
-}
diff --git a/cgesvxx.c b/cgesvxx.c
deleted file mode 100644
index 2800d94..0000000
--- a/cgesvxx.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgesvxx_(char *fact, char *trans, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, char *equed, real *r, real *c, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgesvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.cgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.cgesvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESVXX uses the LU factorization to compute the solution to a\n* complex system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In CGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
- rb_params = argv[9];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- ldx = n;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_cgesvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgesvxx", rb_cgesvxx, -1);
-}
diff --git a/cgetc2.c b/cgetc2.c
deleted file mode 100644
index b62567a..0000000
--- a/cgetc2.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgetc2_(integer *n, complex *a, integer *lda, integer *ipiv, integer *jpiv, integer *info);
-
-static VALUE
-rb_cgetc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.cgetc2( a)\n or\n NumRu::Lapack.cgetc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGETC2 computes an LU factorization, using complete pivoting, of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is a level 1 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the n-by-n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* IPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce overflow if\n* one tries to solve for x in Ax = b. So U is perturbed\n* to avoid the overflow.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgetc2_(&n, a, &lda, ipiv, jpiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_jpiv, rb_info, rb_a);
-}
-
-void
-init_lapack_cgetc2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgetc2", rb_cgetc2, -1);
-}
diff --git a/cgetf2.c b/cgetf2.c
deleted file mode 100644
index f62b73d..0000000
--- a/cgetf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgetf2_(integer *m, integer *n, complex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_cgetf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.cgetf2( m, a)\n or\n NumRu::Lapack.cgetf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgetf2_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_cgetf2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgetf2", rb_cgetf2, -1);
-}
diff --git a/cgetrf.c b/cgetrf.c
deleted file mode 100644
index aee49fc..0000000
--- a/cgetrf.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgetrf_(integer *m, integer *n, complex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_cgetrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.cgetrf( m, a)\n or\n NumRu::Lapack.cgetrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgetrf_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_cgetrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgetrf", rb_cgetrf, -1);
-}
diff --git a/cgetri.c b/cgetri.c
deleted file mode 100644
index 9777e84..0000000
--- a/cgetri.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgetri_(integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgetri(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cgetri( a, ipiv, lwork)\n or\n NumRu::Lapack.cgetri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGETRI computes the inverse of a matrix using the LU factorization\n* computed by CGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_ipiv = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cgetri(VALUE mLapack){
- rb_define_module_function(mLapack, "cgetri", rb_cgetri, -1);
-}
diff --git a/cgetrs.c b/cgetrs.c
deleted file mode 100644
index 3a28ec5..0000000
--- a/cgetrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgetrs_(char *trans, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cgetrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cgetrs( trans, a, ipiv, b)\n or\n NumRu::Lapack.cgetrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGETRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by CGETRF.\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)\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* A (input) COMPLEX array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cgetrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cgetrs", rb_cgetrs, -1);
-}
diff --git a/cggbak.c b/cggbak.c
deleted file mode 100644
index 3892862..0000000
--- a/cggbak.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggbak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, real *lscale, real *rscale, integer *m, complex *v, integer *ldv, integer *info);
-
-static VALUE
-rb_cggbak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- real *lscale;
- VALUE rb_rscale;
- real *rscale;
- VALUE rb_v;
- complex *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- complex *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.cggbak( job, side, ilo, ihi, lscale, rscale, v)\n or\n NumRu::Lapack.cggbak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* CGGBAK forms the right or left eigenvectors of a complex generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* CGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to CGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by CGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by CGGBAL.\n*\n* RSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by CGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by CTGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSSCAL, CSWAP, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_lscale = argv[4];
- rb_rscale = argv[5];
- rb_v = argv[6];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_rscale))
- rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
- if (NA_RANK(rb_rscale) != 1)
- rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_rscale);
- if (NA_TYPE(rb_rscale) != NA_SFLOAT)
- rb_rscale = na_change_type(rb_rscale, NA_SFLOAT);
- rscale = NA_PTR_TYPE(rb_rscale, real*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_lscale))
- rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
- if (NA_RANK(rb_lscale) != 1)
- rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lscale) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of lscale must be the same as shape 0 of rscale");
- if (NA_TYPE(rb_lscale) != NA_SFLOAT)
- rb_lscale = na_change_type(rb_lscale, NA_SFLOAT);
- lscale = NA_PTR_TYPE(rb_lscale, real*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, complex*);
- MEMCPY(v_out__, v, complex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- cggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_cggbak(VALUE mLapack){
- rb_define_module_function(mLapack, "cggbak", rb_cggbak, -1);
-}
diff --git a/cggbal.c b/cggbal.c
deleted file mode 100644
index ae623dd..0000000
--- a/cggbal.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggbal_(char *job, integer *n, complex *a, integer *lda, complex *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, real *rscale, real *work, integer *info);
-
-static VALUE
-rb_cggbal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- real *lscale;
- VALUE rb_rscale;
- real *rscale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.cggbal( job, a, b)\n or\n NumRu::Lapack.cggbal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGBAL balances a pair of general complex matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i=1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j) is the scaling factor\n* applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) REAL array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
-
- cggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
-
- free(work);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggbal(VALUE mLapack){
- rb_define_module_function(mLapack, "cggbal", rb_cggbal, -1);
-}
diff --git a/cgges.c b/cgges.c
deleted file mode 100644
index 3db34d0..0000000
--- a/cgges.c
+++ /dev/null
@@ -1,167 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(complex *arg0, complex *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
- rb_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID cgges_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, integer *n, complex *a, integer *lda, complex *b, integer *ldb, integer *sdim, complex *alpha, complex *beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr, complex *work, integer *lwork, real *rwork, logical *bwork, integer *info);
-
-static VALUE
-rb_cgges(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_vsl;
- complex *vsl;
- VALUE rb_vsr;
- complex *vsr;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b| ... }\n or\n NumRu::Lapack.cgges # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGES computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the generalized complex Schur\n* form (S, T), and optionally left and/or right Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T. The leading\n* columns of VSL and VSR then form an unitary basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* CGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0, and even for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if S\n* and T are upper triangular and, in addition, the diagonal elements\n* of T are non-negative real numbers.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue ALPHA(j)/BETA(j) is selected if\n* SELCTG(ALPHA(j),BETA(j)) is true.\n*\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+2 (See INFO below).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),\n* j=1,...,N are the diagonals of the complex Schur form (A,B)\n* output by CGGES. The BETA(j) will be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (8*N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in CHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering falied in CTGSEN.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, complex*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (8*n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- cgges_(&jobvsl, &jobvsr, &sort, rb_selctg, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_sdim, rb_alpha, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cgges(VALUE mLapack){
- rb_define_module_function(mLapack, "cgges", rb_cgges, -1);
-}
diff --git a/cggesx.c b/cggesx.c
deleted file mode 100644
index d1d7a85..0000000
--- a/cggesx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(complex *arg0, complex *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
- rb_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID cggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, char *sense, integer *n, complex *a, integer *lda, complex *b, integer *ldb, integer *sdim, complex *alpha, complex *beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr, real *rconde, real *rcondv, complex *work, integer *lwork, real *rwork, integer *iwork, integer *liwork, logical *bwork, integer *info);
-
-static VALUE
-rb_cggesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_vsl;
- complex *vsl;
- VALUE rb_vsr;
- complex *vsr;
- VALUE rb_rconde;
- real *rconde;
- VALUE rb_rcondv;
- real *rcondv;
- VALUE rb_work;
- complex *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.cggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b| ... }\n or\n NumRu::Lapack.cggesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n* and, optionally, the left and/or right matrices of Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if T is\n* upper triangular with non-negative diagonal and S is upper\n* triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3 see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are\n* the diagonals of the complex Schur form (S,T). BETA(j) will\n* be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) REAL array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition number for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX 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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n* not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) REAL array, dimension ( 8*N )\n* Real workspace.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array WORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+2.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in CHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in CTGSEN.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
- rb_liwork = argv[7];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- liwork = NUM2INT(rb_liwork);
- sense = StringValueCStr(rb_sense)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, complex*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, complex*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (8*n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- cggesx_(&jobvsl, &jobvsr, &sort, rb_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, rwork, iwork, &liwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_sdim, rb_alpha, rb_beta, rb_vsl, rb_vsr, rb_rconde, rb_rcondv, rb_work, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggesx(VALUE mLapack){
- rb_define_module_function(mLapack, "cggesx", rb_cggesx, -1);
-}
diff --git a/cggev.c b/cggev.c
deleted file mode 100644
index 188cbe8..0000000
--- a/cggev.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggev_(char *jobvl, char *jobvr, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *vr, integer *ldvr, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cggev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cggev( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.cggev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right generalized eigenvector v(j) corresponding to the\n* generalized eigenvalue lambda(j) of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left generalized eigenvector u(j) corresponding to the\n* generalized eigenvalues lambda(j) of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace/output) REAL array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: =N+1: other then QZ iteration failed in SHGEQZ,\n* =N+2: error return from STGEVC.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, complex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = 8*n;
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_vl, rb_vr, rb_work, rb_rwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggev(VALUE mLapack){
- rb_define_module_function(mLapack, "cggev", rb_cggev, -1);
-}
diff --git a/cggevx.c b/cggevx.c
deleted file mode 100644
index 424c051..0000000
--- a/cggevx.c
+++ /dev/null
@@ -1,201 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, complex *work, integer *lwork, real *rwork, integer *iwork, logical *bwork, integer *info);
-
-static VALUE
-rb_cggevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- real *lscale;
- VALUE rb_rscale;
- real *rscale;
- VALUE rb_abnrm;
- real abnrm;
- VALUE rb_bbnrm;
- real bbnrm;
- VALUE rb_rconde;
- real *rconde;
- VALUE rb_rcondv;
- real *rcondv;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
- integer *iwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
- integer lrwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.cggevx( balanc, jobvl, jobvr, sense, a, b, lwork)\n or\n NumRu::Lapack.cggevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B) the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* Optionally, it also computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* A * v(j) = lambda(j) * B * v(j) .\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed:\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the complex Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the complex\n* Schur form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n* eigenvalues.\n*\n* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio ALPHA/BETA.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) REAL\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) REAL array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) REAL array, dimension (N)\n* If SENSE = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. If the eigenvalues cannot be reordered to\n* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n* when the true value would be very small anyway. \n* If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* If SENSE = 'E', LWORK >= max(1,4*N).\n* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*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* RWORK (workspace) REAL array, dimension (lrwork)\n* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n* and at least max(1,2*N) otherwise.\n* Real workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be correct\n* for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in CHGEQZ.\n* =N+2: error return from CTGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- lrwork = ((lsame_(&balanc,"S")) || (lsame_(&balanc,"B"))) ? MAX(1,6*n) : MAX(1,2*n);
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, complex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (lrwork));
- iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+2));
- bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
-
- cggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, rwork, iwork, bwork, &info);
-
- free(rwork);
- free(iwork);
- free(bwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_bbnrm = rb_float_new((double)bbnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(16, rb_alpha, rb_beta, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_abnrm, rb_bbnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggevx(VALUE mLapack){
- rb_define_module_function(mLapack, "cggevx", rb_cggevx, -1);
-}
diff --git a/cggglm.c b/cggglm.c
deleted file mode 100644
index 9b4d19c..0000000
--- a/cggglm.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggglm_(integer *n, integer *m, integer *p, complex *a, integer *lda, complex *b, integer *ldb, complex *d, complex *x, complex *y, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cggglm(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_d;
- complex *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- complex *x;
- VALUE rb_y;
- complex *y;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_d_out__;
- complex *d_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.cggglm( a, b, d, lwork)\n or\n NumRu::Lapack.cggglm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) COMPLEX array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) COMPLEX array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX array, dimension (M)\n* Y (output) COMPLEX array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_d = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = m;
- rb_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = p;
- rb_y = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, complex*);
- MEMCPY(d_out__, d, complex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- cggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_y, rb_work, rb_info, rb_a, rb_b, rb_d);
-}
-
-void
-init_lapack_cggglm(VALUE mLapack){
- rb_define_module_function(mLapack, "cggglm", rb_cggglm, -1);
-}
diff --git a/cgghrd.c b/cgghrd.c
deleted file mode 100644
index 1099f5c..0000000
--- a/cgghrd.c
+++ /dev/null
@@ -1,148 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgghrd_(char *compq, char *compz, integer *n, integer *ilo, integer *ihi, complex *a, integer *lda, complex *b, integer *ldb, complex *q, integer *ldq, complex *z, integer *ldz, integer *info);
-
-static VALUE
-rb_cgghrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_q;
- complex *q;
- VALUE rb_z;
- complex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.cgghrd( compq, compz, ilo, ihi, a, b, q, z)\n or\n NumRu::Lapack.cgghrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* CGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n* Hessenberg form using unitary transformations, where A is a\n* general matrix and B is upper triangular. The form of the generalized\n* eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the unitary matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**H*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**H*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**H*x.\n*\n* The unitary matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n* If Q1 is the unitary matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then CGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to CGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**H B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n* from the QR factorization of B.\n* On exit, if COMPQ='I', the unitary matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1.\n* On exit, if COMPZ='I', the unitary matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and van Loan (Johns Hopkins Press).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_compq = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ilo = NUM2INT(rb_ilo);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- compq = StringValueCStr(rb_compq)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- cgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_cgghrd(VALUE mLapack){
- rb_define_module_function(mLapack, "cgghrd", rb_cgghrd, -1);
-}
diff --git a/cgglse.c b/cgglse.c
deleted file mode 100644
index 444b15d..0000000
--- a/cgglse.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgglse_(integer *m, integer *n, integer *p, complex *a, integer *lda, complex *b, integer *ldb, complex *c, complex *d, complex *x, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cgglse(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_c;
- complex *c;
- VALUE rb_d;
- complex *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- complex *x;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_c_out__;
- complex *c_out__;
- VALUE rb_d_out__;
- complex *d_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer m;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.cgglse( a, b, c, d, lwork)\n or\n NumRu::Lapack.cgglse # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( (A) ) = N.\n* ( (B) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) COMPLEX array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) COMPLEX array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX array, dimension (N)\n* On exit, X is the solution of the LSE problem.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- p = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = n;
- rb_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[1];
- shape[0] = p;
- rb_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, complex*);
- MEMCPY(d_out__, d, complex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- cgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_work, rb_info, rb_a, rb_b, rb_c, rb_d);
-}
-
-void
-init_lapack_cgglse(VALUE mLapack){
- rb_define_module_function(mLapack, "cgglse", rb_cgglse, -1);
-}
diff --git a/cggqrf.c b/cggqrf.c
deleted file mode 100644
index efb9678..0000000
--- a/cggqrf.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggqrf_(integer *n, integer *m, integer *p, complex *a, integer *lda, complex *taua, complex *b, integer *ldb, complex *taub, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cggqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- complex *taua;
- VALUE rb_taub;
- complex *taub;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.cggqrf( n, a, b, lwork)\n or\n NumRu::Lapack.cggqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n* and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the unitary matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) COMPLEX array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the unitary\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) COMPLEX array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of CUNMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine CUNGQR.\n* To use Q to update another matrix, use LAPACK subroutine CUNMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine CUNGRQ.\n* To use Z to update another matrix, use LAPACK subroutine CUNMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQRF, CGERQF, CUNMQR, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- n = NUM2INT(rb_n);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(n,m);
- rb_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, complex*);
- {
- int shape[1];
- shape[0] = MIN(n,p);
- rb_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cggqrf", rb_cggqrf, -1);
-}
diff --git a/cggrqf.c b/cggrqf.c
deleted file mode 100644
index 07e0231..0000000
--- a/cggrqf.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggrqf_(integer *m, integer *p, integer *n, complex *a, integer *lda, complex *taua, complex *b, integer *ldb, complex *taub, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cggrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_p;
- integer p;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- complex *taua;
- VALUE rb_taub;
- complex *taub;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.cggrqf( m, p, a, b, lwork)\n or\n NumRu::Lapack.cggrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the unitary\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the unitary matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) COMPLEX array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of CUNMRQ.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine CUNGRQ.\n* To use Q to update another matrix, use LAPACK subroutine CUNMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine CUNGQR.\n* To use Z to update another matrix, use LAPACK subroutine CUNMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQRF, CGERQF, CUNMRQ, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_p = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- p = NUM2INT(rb_p);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, complex*);
- {
- int shape[1];
- shape[0] = MIN(p,n);
- rb_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "cggrqf", rb_cggrqf, -1);
-}
diff --git a/cggsvd.c b/cggsvd.c
deleted file mode 100644
index 89e5a38..0000000
--- a/cggsvd.c
+++ /dev/null
@@ -1,171 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, complex *a, integer *lda, complex *b, integer *ldb, real *alpha, real *beta, complex *u, integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, complex *work, real *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_cggsvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_alpha;
- real *alpha;
- VALUE rb_beta;
- real *beta;
- VALUE rb_u;
- complex *u;
- VALUE rb_v;
- complex *v;
- VALUE rb_q;
- complex *q;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.cggsvd( jobu, jobv, jobq, a, b)\n or\n NumRu::Lapack.cggsvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N complex matrix A and P-by-N complex matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are unitary matrices, and Z' means the conjugate\n* transpose of Z. Let K+L = the effective numerical rank of the\n* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n* matrices and of the following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the unitary\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n* equal to the CS decomposition of A and B. Furthermore, the GSVD can\n* be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) )\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains part of the triangular matrix R if\n* M-K-L < 0. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) COMPLEX array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P)+N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine CTGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA REAL\n* TOLB REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n REAL CLANGE, SLAMCH\n EXTERNAL LSAME, CLANGE, SLAMCH\n* ..\n* .. External Subroutines ..\n EXTERNAL CGGSVP, CTGSJA, SCOPY, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- lda = m;
- ldb = p;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, complex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, complex*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (MAX(3*n,m)*(p)+n));
- rwork = ALLOC_N(real, (2*n));
-
- cggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, rwork, iwork, &info);
-
- free(work);
- free(rwork);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_k, rb_l, rb_alpha, rb_beta, rb_u, rb_v, rb_q, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggsvd(VALUE mLapack){
- rb_define_module_function(mLapack, "cggsvd", rb_cggsvd, -1);
-}
diff --git a/cggsvp.c b/cggsvp.c
deleted file mode 100644
index 1c10997..0000000
--- a/cggsvp.c
+++ /dev/null
@@ -1,161 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, complex *a, integer *lda, complex *b, integer *ldb, real *tola, real *tolb, integer *k, integer *l, complex *u, integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, integer *iwork, real *rwork, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cggsvp(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_tola;
- real tola;
- VALUE rb_tolb;
- real tolb;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_u;
- complex *u;
- VALUE rb_v;
- complex *v;
- VALUE rb_q;
- complex *q;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- integer *iwork;
- real *rwork;
- complex *tau;
- complex *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.cggsvp( jobu, jobv, jobq, a, b, tola, tolb)\n or\n NumRu::Lapack.cggsvp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGSVP computes unitary matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* conjugate transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* CGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) COMPLEX array, dimension (LDU,M)\n* If JOBU = 'U', U contains the unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX array, dimension (LDV,P)\n* If JOBV = 'V', V contains the unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* TAU (workspace) COMPLEX array, dimension (N)\n*\n* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine CGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_tola = argv[5];
- rb_tolb = argv[6];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- tolb = (real)NUM2DBL(rb_tolb);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- tola = (real)NUM2DBL(rb_tola);
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- lda = m;
- ldb = p;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, complex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, complex*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
- rwork = ALLOC_N(real, (2*n));
- tau = ALLOC_N(complex, (n));
- work = ALLOC_N(complex, (MAX(3*n,m)*(p)));
-
- cggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, rwork, tau, work, &info);
-
- free(iwork);
- free(rwork);
- free(tau);
- free(work);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_k, rb_l, rb_u, rb_v, rb_q, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cggsvp(VALUE mLapack){
- rb_define_module_function(mLapack, "cggsvp", rb_cggsvp, -1);
-}
diff --git a/cgtcon.c b/cgtcon.c
deleted file mode 100644
index 64c7e18..0000000
--- a/cgtcon.c
+++ /dev/null
@@ -1,102 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgtcon_(char *norm, integer *n, complex *dl, complex *d, complex *du, complex *du2, integer *ipiv, real *anorm, real *rcond, complex *work, integer *info);
-
-static VALUE
-rb_cgtcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_du2;
- complex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cgtcon( norm, dl, d, du, du2, ipiv, anorm)\n or\n NumRu::Lapack.cgtcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGTCON estimates the reciprocal of the condition number of a complex\n* tridiagonal matrix A using the LU factorization as computed by\n* CGTTRF.\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) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by CGTTRF.\n*\n* D (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX 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) COMPLEX array, dimension (2*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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_anorm = argv[6];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_SCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- work = ALLOC_N(complex, (2*n));
-
- cgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cgtcon(VALUE mLapack){
- rb_define_module_function(mLapack, "cgtcon", rb_cgtcon, -1);
-}
diff --git a/cgtrfs.c b/cgtrfs.c
deleted file mode 100644
index 7f4c3c6..0000000
--- a/cgtrfs.c
+++ /dev/null
@@ -1,190 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgtrfs_(char *trans, integer *n, integer *nrhs, complex *dl, complex *d, complex *du, complex *dlf, complex *df, complex *duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgtrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_dlf;
- complex *dlf;
- VALUE rb_df;
- complex *df;
- VALUE rb_duf;
- complex *duf;
- VALUE rb_du2;
- complex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)\n or\n NumRu::Lapack.cgtrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGTRFS 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)\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) COMPLEX array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by CGTTRF.\n*\n* DF (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGTTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_dlf = argv[4];
- rb_df = argv[5];
- rb_duf = argv[6];
- rb_du2 = argv[7];
- rb_ipiv = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (6th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_SCOMPLEX)
- rb_df = na_change_type(rb_df, NA_SCOMPLEX);
- df = NA_PTR_TYPE(rb_df, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_SCOMPLEX)
- rb_dlf = na_change_type(rb_dlf, NA_SCOMPLEX);
- dlf = NA_PTR_TYPE(rb_dlf, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_SCOMPLEX)
- rb_duf = na_change_type(rb_duf, NA_SCOMPLEX);
- duf = NA_PTR_TYPE(rb_duf, complex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_SCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cgtrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cgtrfs", rb_cgtrfs, -1);
-}
diff --git a/cgtsv.c b/cgtsv.c
deleted file mode 100644
index 25a3cda..0000000
--- a/cgtsv.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgtsv_(integer *n, integer *nrhs, complex *dl, complex *d, complex *du, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cgtsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- complex *dl_out__;
- VALUE rb_d_out__;
- complex *d_out__;
- VALUE rb_du_out__;
- complex *du_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.cgtsv( dl, d, du, b)\n or\n NumRu::Lapack.cgtsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) COMPLEX array, dimension (N-1)\n* On entry, DL must contain the (n-1) subdiagonal elements of\n* A.\n* On exit, DL is overwritten by the (n-2) elements of the\n* second superdiagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) COMPLEX array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) COMPLEX array, dimension (N-1)\n* On entry, DU must contain the (n-1) superdiagonal elements\n* of A.\n* On exit, DU is overwritten by the (n-1) elements of the first\n* superdiagonal of U.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, complex*);
- MEMCPY(dl_out__, dl, complex, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, complex*);
- MEMCPY(d_out__, d, complex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, complex*);
- MEMCPY(du_out__, du, complex, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_dl, rb_d, rb_du, rb_b);
-}
-
-void
-init_lapack_cgtsv(VALUE mLapack){
- rb_define_module_function(mLapack, "cgtsv", rb_cgtsv, -1);
-}
diff --git a/cgtsvx.c b/cgtsvx.c
deleted file mode 100644
index ce2552e..0000000
--- a/cgtsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgtsvx_(char *fact, char *trans, integer *n, integer *nrhs, complex *dl, complex *d, complex *du, complex *dlf, complex *df, complex *duf, complex *du2, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cgtsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_dlf;
- complex *dlf;
- VALUE rb_df;
- complex *df;
- VALUE rb_duf;
- complex *duf;
- VALUE rb_du2;
- complex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_dlf_out__;
- complex *dlf_out__;
- VALUE rb_df_out__;
- complex *df_out__;
- VALUE rb_duf_out__;
- complex *duf_out__;
- VALUE rb_du2_out__;
- complex *du2_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.cgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)\n or\n NumRu::Lapack.cgtsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGTSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form\n* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n* be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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)\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) COMPLEX array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX array, dimension (N)\n* The n diagonal elements of A.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input or output) COMPLEX array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by CGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) COMPLEX array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) COMPLEX array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) COMPLEX array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by CGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_dlf = argv[5];
- rb_df = argv[6];
- rb_duf = argv[7];
- rb_du2 = argv[8];
- rb_ipiv = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (7th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_SCOMPLEX)
- rb_df = na_change_type(rb_df, NA_SCOMPLEX);
- df = NA_PTR_TYPE(rb_df, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_SCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_SCOMPLEX)
- rb_dlf = na_change_type(rb_dlf, NA_SCOMPLEX);
- dlf = NA_PTR_TYPE(rb_dlf, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_SCOMPLEX)
- rb_duf = na_change_type(rb_duf, NA_SCOMPLEX);
- duf = NA_PTR_TYPE(rb_duf, complex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dlf_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- dlf_out__ = NA_PTR_TYPE(rb_dlf_out__, complex*);
- MEMCPY(dlf_out__, dlf, complex, NA_TOTAL(rb_dlf));
- rb_dlf = rb_dlf_out__;
- dlf = dlf_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, complex*);
- MEMCPY(df_out__, df, complex, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_duf_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- duf_out__ = NA_PTR_TYPE(rb_duf_out__, complex*);
- MEMCPY(duf_out__, duf, complex, NA_TOTAL(rb_duf));
- rb_duf = rb_duf_out__;
- duf = duf_out__;
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- du2_out__ = NA_PTR_TYPE(rb_du2_out__, complex*);
- MEMCPY(du2_out__, du2, complex, NA_TOTAL(rb_du2));
- rb_du2 = rb_du2_out__;
- du2 = du2_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_dlf, rb_df, rb_duf, rb_du2, rb_ipiv);
-}
-
-void
-init_lapack_cgtsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cgtsvx", rb_cgtsvx, -1);
-}
diff --git a/cgttrf.c b/cgttrf.c
deleted file mode 100644
index e94d84e..0000000
--- a/cgttrf.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgttrf_(integer *n, complex *dl, complex *d, complex *du, complex *du2, integer *ipiv, integer *info);
-
-static VALUE
-rb_cgttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_du2;
- complex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- complex *dl_out__;
- VALUE rb_d_out__;
- complex *d_out__;
- VALUE rb_du_out__;
- complex *du_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.cgttrf( dl, d, du)\n or\n NumRu::Lapack.cgttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGTTRF computes an LU factorization of a complex tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) COMPLEX array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) COMPLEX array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) COMPLEX array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) COMPLEX array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- du2 = NA_PTR_TYPE(rb_du2, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, complex*);
- MEMCPY(dl_out__, dl, complex, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, complex*);
- MEMCPY(d_out__, d, complex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, complex*);
- MEMCPY(du_out__, du, complex, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
-
- cgttrf_(&n, dl, d, du, du2, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_du2, rb_ipiv, rb_info, rb_dl, rb_d, rb_du);
-}
-
-void
-init_lapack_cgttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cgttrf", rb_cgttrf, -1);
-}
diff --git a/cgttrs.c b/cgttrs.c
deleted file mode 100644
index 2d71b4b..0000000
--- a/cgttrs.c
+++ /dev/null
@@ -1,118 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgttrs_(char *trans, integer *n, integer *nrhs, complex *dl, complex *d, complex *du, complex *du2, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cgttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_du2;
- complex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cgttrs( trans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.cgttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGTTRS solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by CGTTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CGTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_SCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cgttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cgttrs", rb_cgttrs, -1);
-}
diff --git a/cgtts2.c b/cgtts2.c
deleted file mode 100644
index 0fb328d..0000000
--- a/cgtts2.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cgtts2_(integer *itrans, integer *n, integer *nrhs, complex *dl, complex *d, complex *du, complex *du2, integer *ipiv, complex *b, integer *ldb);
-
-static VALUE
-rb_cgtts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itrans;
- integer itrans;
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_du2;
- complex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.cgtts2( itrans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.cgtts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* CGTTS2 solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by CGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A**T * X = B (Transpose)\n* = 2: A**H * X = B (Conjugate transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n COMPLEX TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itrans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- itrans = NUM2INT(rb_itrans);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_SCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_cgtts2(VALUE mLapack){
- rb_define_module_function(mLapack, "cgtts2", rb_cgtts2, -1);
-}
diff --git a/chbev.c b/chbev.c
deleted file mode 100644
index 3f432d2..0000000
--- a/chbev.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbev_(char *jobz, char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chbev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.chbev( jobz, uplo, kd, ab)\n or\n NumRu::Lapack.chbev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (MAX(1,3*n-2)));
-
- chbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ab);
-}
-
-void
-init_lapack_chbev(VALUE mLapack){
- rb_define_module_function(mLapack, "chbev", rb_chbev, -1);
-}
diff --git a/chbevd.c b/chbevd.c
deleted file mode 100644
index cbc9c21..0000000
--- a/chbevd.c
+++ /dev/null
@@ -1,121 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbevd_(char *jobz, char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *w, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_chbevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab = NumRu::Lapack.chbevd( jobz, uplo, kd, ab, lwork, lrwork, liwork)\n or\n NumRu::Lapack.chbevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_lwork = argv[4];
- rb_lrwork = argv[5];
- rb_liwork = argv[6];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- jobz = StringValueCStr(rb_jobz)[0];
- lwork = NUM2INT(rb_lwork);
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- chbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_rwork, rb_iwork, rb_info, rb_ab);
-}
-
-void
-init_lapack_chbevd(VALUE mLapack){
- rb_define_module_function(mLapack, "chbevd", rb_chbevd, -1);
-}
diff --git a/chbevx.c b/chbevx.c
deleted file mode 100644
index c685b01..0000000
--- a/chbevx.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbevx_(char *jobz, char *range, char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, complex *q, integer *ldq, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_chbevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_q;
- complex *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- complex *work;
- real *rwork;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.chbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.chbevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) COMPLEX array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N unitary matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_vl = argv[5];
- rb_vu = argv[6];
- rb_il = argv[7];
- rb_iu = argv[8];
- rb_abstol = argv[9];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- chbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_q, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ab);
-}
-
-void
-init_lapack_chbevx(VALUE mLapack){
- rb_define_module_function(mLapack, "chbevx", rb_chbevx, -1);
-}
diff --git a/chbgst.c b/chbgst.c
deleted file mode 100644
index c780a12..0000000
--- a/chbgst.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbgst_(char *vect, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, complex *x, integer *ldx, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chbgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_bb;
- complex *bb;
- VALUE rb_x;
- complex *x;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, info, ab = NumRu::Lapack.chbgst( vect, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.chbgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBGST reduces a complex Hermitian-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**H*S by CPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**H*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) COMPLEX array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by CPBSTF, stored in the first kb+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) COMPLEX array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_SCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, complex*);
- ka = NUM2INT(rb_ka);
- vect = StringValueCStr(rb_vect)[0];
- kb = NUM2INT(rb_kb);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (n));
-
- chbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_x, rb_info, rb_ab);
-}
-
-void
-init_lapack_chbgst(VALUE mLapack){
- rb_define_module_function(mLapack, "chbgst", rb_chbgst, -1);
-}
diff --git a/chbgv.c b/chbgv.c
deleted file mode 100644
index 1ebf82c..0000000
--- a/chbgv.c
+++ /dev/null
@@ -1,121 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbgv_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chbgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_bb;
- complex *bb;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_bb_out__;
- complex *bb_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.chbgv( jobz, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.chbgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by CPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHBGST, CHBTRD, CPBSTF, CSTEQR, SSTERF, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_SCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, complex*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- kb = NUM2INT(rb_kb);
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, complex*);
- MEMCPY(bb_out__, bb, complex, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (3*n));
-
- chbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_chbgv(VALUE mLapack){
- rb_define_module_function(mLapack, "chbgv", rb_chbgv, -1);
-}
diff --git a/chbgvd.c b/chbgvd.c
deleted file mode 100644
index 318be7a..0000000
--- a/chbgvd.c
+++ /dev/null
@@ -1,151 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbgvd_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, real *w, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_chbgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_bb;
- complex *bb;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_bb_out__;
- complex *bb_out__;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.chbgvd( jobz, uplo, ka, kb, ab, bb, lwork, lrwork, liwork)\n or\n NumRu::Lapack.chbgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by CPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
- rb_lwork = argv[6];
- rb_lrwork = argv[7];
- rb_liwork = argv[8];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_SCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, complex*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kb = NUM2INT(rb_kb);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- liwork = NUM2INT(rb_liwork);
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, complex*);
- MEMCPY(bb_out__, bb, complex, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
-
- chbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_w, rb_z, rb_work, rb_rwork, rb_iwork, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_chbgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "chbgvd", rb_chbgvd, -1);
-}
diff --git a/chbgvx.c b/chbgvx.c
deleted file mode 100644
index 803764b..0000000
--- a/chbgvx.c
+++ /dev/null
@@ -1,170 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbgvx_(char *jobz, char *range, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, complex *q, integer *ldq, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_chbgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_bb;
- complex *bb;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_q;
- complex *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_bb_out__;
- complex *bb_out__;
- complex *work;
- real *rwork;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.chbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.chbgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by CPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) COMPLEX array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n* <= N: then i eigenvectors failed to converge. Their\n* indices are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ka = argv[3];
- rb_kb = argv[4];
- rb_ab = argv[5];
- rb_bb = argv[6];
- rb_vl = argv[7];
- rb_vu = argv[8];
- rb_il = argv[9];
- rb_iu = argv[10];
- rb_abstol = argv[11];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_SCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, complex*);
- ka = NUM2INT(rb_ka);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kb = NUM2INT(rb_kb);
- vu = (real)NUM2DBL(rb_vu);
- jobz = StringValueCStr(rb_jobz)[0];
- il = NUM2INT(rb_il);
- range = StringValueCStr(rb_range)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- ldq = 1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0;
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, complex*);
- MEMCPY(bb_out__, bb, complex, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- chbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_q, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_chbgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "chbgvx", rb_chbgvx, -1);
-}
diff --git a/chbtrd.c b/chbtrd.c
deleted file mode 100644
index 4a282e1..0000000
--- a/chbtrd.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chbtrd_(char *vect, char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *d, real *e, complex *q, integer *ldq, complex *work, integer *info);
-
-static VALUE
-rb_chbtrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_q;
- complex *q;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- complex *work;
-
- integer ldab;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.chbtrd( vect, uplo, kd, ab, q)\n or\n NumRu::Lapack.chbtrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBTRD reduces a complex Hermitian band matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_q = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- vect = StringValueCStr(rb_vect)[0];
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of ab");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(complex, (n));
-
- chbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_info, rb_ab, rb_q);
-}
-
-void
-init_lapack_chbtrd(VALUE mLapack){
- rb_define_module_function(mLapack, "chbtrd", rb_chbtrd, -1);
-}
diff --git a/checon.c b/checon.c
deleted file mode 100644
index 80add25..0000000
--- a/checon.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID checon_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, real *anorm, real *rcond, complex *work, integer *info);
-
-static VALUE
-rb_checon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.checon( uplo, a, ipiv, anorm)\n or\n NumRu::Lapack.checon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHECON estimates the reciprocal of the condition number of a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHETRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(complex, (2*n));
-
- checon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_checon(VALUE mLapack){
- rb_define_module_function(mLapack, "checon", rb_checon, -1);
-}
diff --git a/cheequb.c b/cheequb.c
deleted file mode 100644
index 29465ff..0000000
--- a/cheequb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cheequb_(char *uplo, integer *n, complex *a, integer *lda, real *s, real *scond, real *amax, complex *work, integer *info);
-
-static VALUE
-rb_cheequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cheequb( uplo, a)\n or\n NumRu::Lapack.cheequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- work = ALLOC_N(complex, (3*n));
-
- cheequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
-
- free(work);
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_cheequb(VALUE mLapack){
- rb_define_module_function(mLapack, "cheequb", rb_cheequb, -1);
-}
diff --git a/cheev.c b/cheev.c
deleted file mode 100644
index e25231e..0000000
--- a/cheev.c
+++ /dev/null
@@ -1,85 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cheev_(char *jobz, char *uplo, integer *n, complex *a, integer *lda, real *w, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_cheev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.cheev( jobz, uplo, a, lwork)\n or\n NumRu::Lapack.cheev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEEV computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for CHETRD returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
-
- cheev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cheev(VALUE mLapack){
- rb_define_module_function(mLapack, "cheev", rb_cheev, -1);
-}
diff --git a/cheevd.c b/cheevd.c
deleted file mode 100644
index a66e1dd..0000000
--- a/cheevd.c
+++ /dev/null
@@ -1,106 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cheevd_(char *jobz, char *uplo, integer *n, complex *a, integer *lda, real *w, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_cheevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a = NumRu::Lapack.cheevd( jobz, uplo, a, lwork, lrwork, liwork)\n or\n NumRu::Lapack.cheevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
- rb_lrwork = argv[4];
- rb_liwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cheevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_work, rb_rwork, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_cheevd(VALUE mLapack){
- rb_define_module_function(mLapack, "cheevd", rb_cheevd, -1);
-}
diff --git a/cheevr.c b/cheevr.c
deleted file mode 100644
index 82c4f10..0000000
--- a/cheevr.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cheevr_(char *jobz, char *range, char *uplo, integer *n, complex *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, integer *isuppz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_cheevr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.cheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, lrwork, liwork)\n or\n NumRu::Lapack.cheevr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* CHEEVR first reduces the matrix A to tridiagonal form T with a call\n* to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute\n* the eigenspectrum using Relatively Robust Representations. CSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see DSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of CSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** CSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* furutre releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for CHETRD and for\n* CUNMTR as returned by ILAENV.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal\n* (and minimal) LRWORK.\n*\n* LRWORK (input) INTEGER\n* The length of the array RWORK. LRWORK >= max(1,24*N).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal\n* (and minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_lrwork = argv[10];
- rb_liwork = argv[11];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- vu = (real)NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- lrwork = NUM2INT(rb_lrwork);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cheevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_rwork, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_cheevr(VALUE mLapack){
- rb_define_module_function(mLapack, "cheevr", rb_cheevr, -1);
-}
diff --git a/cheevx.c b/cheevx.c
deleted file mode 100644
index b7d355e..0000000
--- a/cheevx.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cheevx_(char *jobz, char *range, char *uplo, integer *n, complex *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_cheevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_work;
- complex *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.cheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)\n or\n NumRu::Lapack.cheevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHEEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 2*N.\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for CHETRD and for\n* CUNMTR as returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(real, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- cheevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
-
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a);
-}
-
-void
-init_lapack_cheevx(VALUE mLapack){
- rb_define_module_function(mLapack, "cheevx", rb_cheevx, -1);
-}
diff --git a/chegs2.c b/chegs2.c
deleted file mode 100644
index 79e0517..0000000
--- a/chegs2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chegs2_(integer *itype, char *uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_chegs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.chegs2( itype, uplo, a, b)\n or\n NumRu::Lapack.chegs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHEGS2 reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by CPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- chegs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_chegs2(VALUE mLapack){
- rb_define_module_function(mLapack, "chegs2", rb_chegs2, -1);
-}
diff --git a/chegst.c b/chegst.c
deleted file mode 100644
index 689b278..0000000
--- a/chegst.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chegst_(integer *itype, char *uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_chegst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.chegst( itype, uplo, a, b)\n or\n NumRu::Lapack.chegst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHEGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by CPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- chegst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_chegst(VALUE mLapack){
- rb_define_module_function(mLapack, "chegst", rb_chegst, -1);
-}
diff --git a/chegv.c b/chegv.c
deleted file mode 100644
index 1292259..0000000
--- a/chegv.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chegv_(integer *itype, char *jobz, char *uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb, real *w, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_chegv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.chegv( itype, jobz, uplo, a, b, lwork)\n or\n NumRu::Lapack.chegv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the Hermitian positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for CHETRD returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPOTRF or CHEEV returned an error code:\n* <= N: if INFO = i, CHEEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
-
- chegv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_chegv(VALUE mLapack){
- rb_define_module_function(mLapack, "chegv", rb_chegv, -1);
-}
diff --git a/chegvd.c b/chegvd.c
deleted file mode 100644
index b922d60..0000000
--- a/chegvd.c
+++ /dev/null
@@ -1,136 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chegvd_(integer *itype, char *jobz, char *uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb, real *w, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_chegvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a, b = NumRu::Lapack.chegvd( itype, jobz, uplo, a, b, lwork, lrwork, liwork)\n or\n NumRu::Lapack.chegvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N + 1.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: CPOTRF or CHEEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if CHEEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
- rb_lrwork = argv[6];
- rb_liwork = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- chegvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_work, rb_rwork, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_chegvd(VALUE mLapack){
- rb_define_module_function(mLapack, "chegvd", rb_chegvd, -1);
-}
diff --git a/chegvx.c b/chegvx.c
deleted file mode 100644
index 96c2cb1..0000000
--- a/chegvx.c
+++ /dev/null
@@ -1,167 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chegvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, complex *a, integer *lda, complex *b, integer *ldb, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_chegvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_work;
- complex *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.chegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, ldz, lwork)\n or\n NumRu::Lapack.chegvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHEGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n**\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for CHETRD returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPOTRF or CHEEVX returned an error code:\n* <= N: if INFO = i, CHEEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_vl = argv[6];
- rb_vu = argv[7];
- rb_il = argv[8];
- rb_iu = argv[9];
- rb_abstol = argv[10];
- rb_ldz = argv[11];
- rb_lwork = argv[12];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- vu = (real)NUM2DBL(rb_vu);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- chegvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
-
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_chegvx(VALUE mLapack){
- rb_define_module_function(mLapack, "chegvx", rb_chegvx, -1);
-}
diff --git a/cherfs.c b/cherfs.c
deleted file mode 100644
index 2daca9d..0000000
--- a/cherfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cherfs_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cherfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cherfs( uplo, a, af, ipiv, b, x)\n or\n NumRu::Lapack.cherfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHERFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CHETRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cherfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cherfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cherfs", rb_cherfs, -1);
-}
diff --git a/cherfsx.c b/cherfsx.c
deleted file mode 100644
index 7439ee7..0000000
--- a/cherfsx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cherfsx_(char *uplo, char *equed, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cherfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cherfsx( uplo, equed, a, af, ipiv, s, b, x, params)\n or\n NumRu::Lapack.cherfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHERFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
- rb_params = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cherfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_cherfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "cherfsx", rb_cherfsx, -1);
-}
diff --git a/chesv.c b/chesv.c
deleted file mode 100644
index 05271d5..0000000
--- a/chesv.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chesv_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_chesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.chesv( uplo, a, b, lwork)\n or\n NumRu::Lapack.chesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**H or A = L*D*L**H as computed by\n* CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CHETRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* CHETRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHETRF, CHETRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- chesv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_chesv(VALUE mLapack){
- rb_define_module_function(mLapack, "chesv", rb_chesv, -1);
-}
diff --git a/chesvx.c b/chesvx.c
deleted file mode 100644
index 07a5052..0000000
--- a/chesvx.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chesvx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_chesvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.chesvx( fact, uplo, a, af, ipiv, b, lwork)\n or\n NumRu::Lapack.chesvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHESVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHETRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CHETRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CHETRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for CHETRF.\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* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- lwork = NUM2INT(rb_lwork);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- rwork = ALLOC_N(real, (n));
-
- chesvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_af, rb_ipiv);
-}
-
-void
-init_lapack_chesvx(VALUE mLapack){
- rb_define_module_function(mLapack, "chesvx", rb_chesvx, -1);
-}
diff --git a/chesvxx.c b/chesvxx.c
deleted file mode 100644
index ecde0db..0000000
--- a/chesvxx.c
+++ /dev/null
@@ -1,239 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chesvxx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chesvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.chesvxx( fact, uplo, a, af, ipiv, equed, s, b, params)\n or\n NumRu::Lapack.chesvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHESVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CHESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CHESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CHESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CHESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by CHETRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by CHETRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
- rb_params = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- chesvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(14, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_chesvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "chesvxx", rb_chesvxx, -1);
-}
diff --git a/chetd2.c b/chetd2.c
deleted file mode 100644
index 1dcdfcf..0000000
--- a/chetd2.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chetd2_(char *uplo, integer *n, complex *a, integer *lda, real *d, real *e, complex *tau, integer *info);
-
-static VALUE
-rb_chetd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.chetd2( uplo, a)\n or\n NumRu::Lapack.chetd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* CHETD2 reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q' * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- chetd2_(&uplo, &n, a, &lda, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_chetd2(VALUE mLapack){
- rb_define_module_function(mLapack, "chetd2", rb_chetd2, -1);
-}
diff --git a/chetf2.c b/chetf2.c
deleted file mode 100644
index f50e3a2..0000000
--- a/chetf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chetf2_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_chetf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.chetf2( uplo, a)\n or\n NumRu::Lapack.chetf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CHETF2 computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the conjugate transpose of U, and D is\n* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.210 and l.392\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- chetf2_(&uplo, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_chetf2(VALUE mLapack){
- rb_define_module_function(mLapack, "chetf2", rb_chetf2, -1);
-}
diff --git a/chetrd.c b/chetrd.c
deleted file mode 100644
index 9e00dc4..0000000
--- a/chetrd.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chetrd_(char *uplo, integer *n, complex *a, integer *lda, real *d, real *e, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_chetrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.chetrd( uplo, a, lwork)\n or\n NumRu::Lapack.chetrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRD reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- chetrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_chetrd(VALUE mLapack){
- rb_define_module_function(mLapack, "chetrd", rb_chetrd, -1);
-}
diff --git a/chetrf.c b/chetrf.c
deleted file mode 100644
index f9182c5..0000000
--- a/chetrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chetrf_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_chetrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.chetrf( uplo, a, lwork)\n or\n NumRu::Lapack.chetrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRF computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CHETF2, CLAHEF, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- chetrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_chetrf(VALUE mLapack){
- rb_define_module_function(mLapack, "chetrf", rb_chetrf, -1);
-}
diff --git a/chetri.c b/chetri.c
deleted file mode 100644
index f482ec8..0000000
--- a/chetri.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chetri_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *info);
-
-static VALUE
-rb_chetri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.chetri( uplo, a, ipiv)\n or\n NumRu::Lapack.chetri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRI computes the inverse of a complex Hermitian indefinite matrix\n* A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n* CHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CHETRF.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* WORK (workspace) COMPLEX 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n));
-
- chetri_(&uplo, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_chetri(VALUE mLapack){
- rb_define_module_function(mLapack, "chetri", rb_chetri, -1);
-}
diff --git a/chetrs.c b/chetrs.c
deleted file mode 100644
index febcece..0000000
--- a/chetrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chetrs_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_chetrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.chetrs( uplo, a, ipiv, b)\n or\n NumRu::Lapack.chetrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHETRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- chetrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_chetrs(VALUE mLapack){
- rb_define_module_function(mLapack, "chetrs", rb_chetrs, -1);
-}
diff --git a/chetrs2.c b/chetrs2.c
deleted file mode 100644
index 51c1e34..0000000
--- a/chetrs2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chetrs2_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work, integer *info);
-
-static VALUE
-rb_chetrs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.chetrs2( uplo, a, ipiv, b)\n or\n NumRu::Lapack.chetrs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRS2 solves a system of linear equations A*X = B with a COMPLEX\n* Hermitian matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) COMPLEX 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (n));
-
- chetrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_chetrs2(VALUE mLapack){
- rb_define_module_function(mLapack, "chetrs2", rb_chetrs2, -1);
-}
diff --git a/chfrk.c b/chfrk.c
deleted file mode 100644
index f4bb3d0..0000000
--- a/chfrk.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chfrk_(char *transr, char *uplo, char *trans, integer *n, integer *k, real *alpha, complex *a, integer *lda, real *beta, complex *c);
-
-static VALUE
-rb_chfrk(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- complex *a;
- VALUE rb_beta;
- real beta;
- VALUE rb_c;
- complex *c;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.chfrk( transr, uplo, trans, n, k, alpha, a, beta, c)\n or\n NumRu::Lapack.chfrk # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* CHFRK performs one of the Hermitian rank--k operations\n*\n* C := alpha*A*conjg( A' ) + beta*C,\n*\n* or\n*\n* C := alpha*conjg( A' )*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n Hermitian\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.\n*\n* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with\n* TRANS = 'C' or 'c', K specifies the number of rows of the\n* matrix A. K must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n* C (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the matrix A in RFP Format. RFP Format is\n* described by TRANSR, UPLO and N. Note that the imaginary\n* parts of the diagonal elements need not be set, they are\n* assumed to be zero, and on exit they are set to zero.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_n = argv[3];
- rb_k = argv[4];
- rb_alpha = argv[5];
- rb_a = argv[6];
- rb_beta = argv[7];
- rb_c = argv[8];
-
- k = NUM2INT(rb_k);
- uplo = StringValueCStr(rb_uplo)[0];
- trans = StringValueCStr(rb_trans)[0];
- n = NUM2INT(rb_n);
- beta = (real)NUM2DBL(rb_beta);
- alpha = (real)NUM2DBL(rb_alpha);
- transr = StringValueCStr(rb_transr)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (lsame_(&trans,"N") ? k : n))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
- lda = NA_SHAPE0(rb_a);
- if (lda != (lsame_(&trans,"N") ? MAX(1,n) : MAX(1,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", lsame_(&trans,"N") ? MAX(1,n) : MAX(1,k));
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lda = lsame_(&trans,"N") ? MAX(1,n) : MAX(1,k);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- chfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
-
- return rb_c;
-}
-
-void
-init_lapack_chfrk(VALUE mLapack){
- rb_define_module_function(mLapack, "chfrk", rb_chfrk, -1);
-}
diff --git a/chgeqz.c b/chgeqz.c
deleted file mode 100644
index c95da6e..0000000
--- a/chgeqz.c
+++ /dev/null
@@ -1,183 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chgeqz_(char *job, char *compq, char *compz, integer *n, integer *ilo, integer *ihi, complex *h, integer *ldh, complex *t, integer *ldt, complex *alpha, complex *beta, complex *q, integer *ldq, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_chgeqz(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- complex *h;
- VALUE rb_t;
- complex *t;
- VALUE rb_q;
- complex *q;
- VALUE rb_z;
- complex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_t_out__;
- complex *t_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- VALUE rb_z_out__;
- complex *z_out__;
- real *rwork;
-
- integer ldh;
- integer n;
- integer ldt;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, work, info, h, t, q, z = NumRu::Lapack.chgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)\n or\n NumRu::Lapack.chgeqz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the single-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a complex matrix pair (A,B):\n* \n* A = Q1*H*Z1**H, B = Q1*T*Z1**H,\n* \n* as computed by CGGHRD.\n* \n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**H, T = Q*P*Z**H,\n* \n* where Q and Z are unitary matrices and S and P are upper triangular.\n* \n* Optionally, the unitary matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* unitary matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced\n* the matrix pair (A,B) to generalized Hessenberg form, then the output\n* matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n* Schur factorization of (A,B):\n* \n* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T)\n* (equivalently, of (A,B)) are computed as a pair of complex values\n* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an\n* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* The values of alpha and beta for the i-th eigenvalue can be read\n* directly from the generalized Schur form: alpha = S(i,i),\n* beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Computer eigenvalues and the Schur form.\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain a unitary matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) COMPLEX array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper triangular\n* matrix S from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of H matches that of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) COMPLEX array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of T matches that of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(i) = S(i,i) in the generalized Schur\n* factorization.\n*\n* BETA (output) COMPLEX array, dimension (N)\n* The real non-negative scalars beta that define the\n* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized\n* Schur factorization.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of right Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,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* RWORK (workspace) REAL 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* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* We assume that complex ABS works as long as its value is less than\n* overflow.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_compz = argv[2];
- rb_ilo = argv[3];
- rb_ihi = argv[4];
- rb_h = argv[5];
- rb_t = argv[6];
- rb_q = argv[7];
- rb_z = argv[8];
- rb_lwork = argv[9];
-
- ilo = NUM2INT(rb_ilo);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (8th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of z");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of z");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SCOMPLEX)
- rb_t = na_change_type(rb_t, NA_SCOMPLEX);
- t = NA_PTR_TYPE(rb_t, complex*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, complex*);
- MEMCPY(t_out__, t, complex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- rwork = ALLOC_N(real, (n));
-
- chgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alpha, beta, q, &ldq, z, &ldz, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_alpha, rb_beta, rb_work, rb_info, rb_h, rb_t, rb_q, rb_z);
-}
-
-void
-init_lapack_chgeqz(VALUE mLapack){
- rb_define_module_function(mLapack, "chgeqz", rb_chgeqz, -1);
-}
diff --git a/chla_transtype.c b/chla_transtype.c
deleted file mode 100644
index aa2af05..0000000
--- a/chla_transtype.c
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chla_transtype_(char *__out__, integer *trans);
-
-static VALUE
-rb_chla_transtype(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb___out__;
- char __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.chla_transtype( trans)\n or\n NumRu::Lapack.chla_transtype # print help\n\n\nFORTRAN MANUAL\n CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS )\n\n* Purpose\n* =======\n*\n* This subroutine translates from a BLAST-specified integer constant to\n* the character string specifying a transposition operation.\n*\n* CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE is 'X',\n* then input is not an integer indicating a transposition operator.\n* Otherwise CHLA_TRANSTYPE returns the constant value corresponding to\n* TRANS.\n*\n\n* Arguments\n* =========\n* TRANS (input) INTEGER\n* Specifies the form of the system of equations:\n* = BLAS_NO_TRANS = 111 : No Transpose\n* = BLAS_TRANS = 112 : Transpose\n* = BLAS_CONJ_TRANS = 113 : Conjugate Transpose\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_trans = argv[0];
-
- trans = NUM2INT(rb_trans);
-
- chla_transtype_(&__out__, &trans);
-
- rb___out__ = rb_str_new(&__out__,1);
- return rb___out__;
-}
-
-void
-init_lapack_chla_transtype(VALUE mLapack){
- rb_define_module_function(mLapack, "chla_transtype", rb_chla_transtype, -1);
-}
diff --git a/chpcon.c b/chpcon.c
deleted file mode 100644
index 919414a..0000000
--- a/chpcon.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpcon_(char *uplo, integer *n, complex *ap, integer *ipiv, real *anorm, real *rcond, complex *work, integer *info);
-
-static VALUE
-rb_chpcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.chpcon( uplo, ap, ipiv, anorm)\n or\n NumRu::Lapack.chpcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPCON estimates the reciprocal of the condition number of a complex\n* Hermitian packed matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- work = ALLOC_N(complex, (2*n));
-
- chpcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_chpcon(VALUE mLapack){
- rb_define_module_function(mLapack, "chpcon", rb_chpcon, -1);
-}
diff --git a/chpev.c b/chpev.c
deleted file mode 100644
index 8d113f1..0000000
--- a/chpev.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpev_(char *jobz, char *uplo, integer *n, complex *ap, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chpev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- complex *work;
- real *rwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.chpev( jobz, uplo, ap)\n or\n NumRu::Lapack.chpev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(complex, (MAX(1, 2*n-1)));
- rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
-
- chpev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ap);
-}
-
-void
-init_lapack_chpev(VALUE mLapack){
- rb_define_module_function(mLapack, "chpev", rb_chpev, -1);
-}
diff --git a/chpevd.c b/chpevd.c
deleted file mode 100644
index 8f64030..0000000
--- a/chpevd.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpevd_(char *jobz, char *uplo, integer *n, complex *ap, real *w, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_chpevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ap = NumRu::Lapack.chpevd( jobz, uplo, ap, lwork, lrwork, liwork)\n or\n NumRu::Lapack.chpevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_lwork = argv[3];
- rb_lrwork = argv[4];
- rb_liwork = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- chpevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_rwork, rb_iwork, rb_info, rb_ap);
-}
-
-void
-init_lapack_chpevd(VALUE mLapack){
- rb_define_module_function(mLapack, "chpevd", rb_chpevd, -1);
-}
diff --git a/chpevx.c b/chpevx.c
deleted file mode 100644
index a335d3e..0000000
--- a/chpevx.c
+++ /dev/null
@@ -1,125 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpevx_(char *jobz, char *range, char *uplo, integer *n, complex *ap, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_chpevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- complex *work;
- real *rwork;
- integer *iwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.chpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.chpevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A in packed storage.\n* Eigenvalues/vectors can be selected by specifying either a range of\n* values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and\n* the index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- il = NUM2INT(rb_il);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- chpevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap);
-}
-
-void
-init_lapack_chpevx(VALUE mLapack){
- rb_define_module_function(mLapack, "chpevx", rb_chpevx, -1);
-}
diff --git a/chpgst.c b/chpgst.c
deleted file mode 100644
index 94e0b02..0000000
--- a/chpgst.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpgst_(integer *itype, char *uplo, integer *n, complex *ap, complex *bp, integer *info);
-
-static VALUE
-rb_chpgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_bp;
- complex *bp;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.chpgst( itype, uplo, n, ap, bp)\n or\n NumRu::Lapack.chpgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* CHPGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by CPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by CPPTRF.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- itype = NUM2INT(rb_itype);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_SCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- chpgst_(&itype, &uplo, &n, ap, bp, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_chpgst(VALUE mLapack){
- rb_define_module_function(mLapack, "chpgst", rb_chpgst, -1);
-}
diff --git a/chpgv.c b/chpgv.c
deleted file mode 100644
index f2b6639..0000000
--- a/chpgv.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpgv_(integer *itype, char *jobz, char *uplo, integer *n, complex *ap, complex *bp, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chpgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_bp;
- complex *bp;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- VALUE rb_bp_out__;
- complex *bp_out__;
- complex *work;
- real *rwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.chpgv( itype, jobz, uplo, ap, bp)\n or\n NumRu::Lapack.chpgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPPTRF or CHPEV returned an error code:\n* <= N: if INFO = i, CHPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPEV, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_SCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, complex*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, complex*);
- MEMCPY(bp_out__, bp, complex, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(complex, (MAX(1, 2*n-1)));
- rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
-
- chpgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_chpgv(VALUE mLapack){
- rb_define_module_function(mLapack, "chpgv", rb_chpgv, -1);
-}
diff --git a/chpgvd.c b/chpgvd.c
deleted file mode 100644
index 4d41ab5..0000000
--- a/chpgvd.c
+++ /dev/null
@@ -1,133 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpgvd_(integer *itype, char *jobz, char *uplo, integer *n, complex *ap, complex *bp, real *w, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_chpgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_bp;
- complex *bp;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- VALUE rb_bp_out__;
- complex *bp_out__;
- complex *work;
- real *rwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, iwork, info, ap, bp = NumRu::Lapack.chpgvd( itype, jobz, uplo, ap, bp, lwork, lrwork, liwork)\n or\n NumRu::Lapack.chpgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: CPPTRF or CHPEVD returned an error code:\n* <= N: if INFO = i, CHPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPEVD, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, REAL\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
- rb_lwork = argv[5];
- rb_lrwork = argv[6];
- rb_liwork = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_SCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, complex*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, complex*);
- MEMCPY(bp_out__, bp, complex, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(complex, (MAX(1,lwork)));
- rwork = ALLOC_N(real, (MAX(1,lrwork)));
-
- chpgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_z, rb_iwork, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_chpgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "chpgvd", rb_chpgvd, -1);
-}
diff --git a/chpgvx.c b/chpgvx.c
deleted file mode 100644
index 057b049..0000000
--- a/chpgvx.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpgvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, complex *ap, complex *bp, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, complex *work, real *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_chpgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_bp;
- complex *bp;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- VALUE rb_bp_out__;
- complex *bp_out__;
- complex *work;
- real *rwork;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.chpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)\n or\n NumRu::Lapack.chpgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHPGVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite. Eigenvalues and eigenvectors can be selected by\n* specifying either a range of values or a range of indices for the\n* desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPPTRF or CHPEVX returned an error code:\n* <= N: if INFO = i, CHPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPEVX, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_ap = argv[4];
- rb_bp = argv[5];
- rb_vl = argv[6];
- rb_vu = argv[7];
- rb_il = argv[8];
- rb_iu = argv[9];
- rb_abstol = argv[10];
- rb_ldz = argv[11];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- range = StringValueCStr(rb_range)[0];
- itype = NUM2INT(rb_itype);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_SCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : n;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, complex*);
- MEMCPY(bp_out__, bp, complex, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- chpgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_chpgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "chpgvx", rb_chpgvx, -1);
-}
diff --git a/chprfs.c b/chprfs.c
deleted file mode 100644
index bf4b7b2..0000000
--- a/chprfs.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chprfs_(char *uplo, integer *n, integer *nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_afp;
- complex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.chprfs( uplo, ap, afp, ipiv, b, x)\n or\n NumRu::Lapack.chprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by CHPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CHPTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_SCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- chprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_chprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "chprfs", rb_chprfs, -1);
-}
diff --git a/chpsv.c b/chpsv.c
deleted file mode 100644
index 8158652..0000000
--- a/chpsv.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpsv_(char *uplo, integer *n, integer *nrhs, complex *ap, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_chpsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_b;
- complex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldb;
- integer nrhs;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.chpsv( uplo, ap, b)\n or\n NumRu::Lapack.chpsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is Hermitian and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CHPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPTRF, CHPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- chpsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_chpsv(VALUE mLapack){
- rb_define_module_function(mLapack, "chpsv", rb_chpsv, -1);
-}
diff --git a/chpsvx.c b/chpsvx.c
deleted file mode 100644
index 511b52b..0000000
--- a/chpsvx.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chpsvx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_chpsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_afp;
- complex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_afp_out__;
- complex *afp_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.chpsvx( fact, uplo, ap, afp, ipiv, b)\n or\n NumRu::Lapack.chpsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n* A = L*D*L**H to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N Hermitian matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CHPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CHPTRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_SCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, complex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, complex*);
- MEMCPY(afp_out__, afp, complex, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- chpsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_afp, rb_ipiv);
-}
-
-void
-init_lapack_chpsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "chpsvx", rb_chpsvx, -1);
-}
diff --git a/chptrd.c b/chptrd.c
deleted file mode 100644
index 55b6f11..0000000
--- a/chptrd.c
+++ /dev/null
@@ -1,81 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chptrd_(char *uplo, integer *n, complex *ap, real *d, real *e, complex *tau, integer *info);
-
-static VALUE
-rb_chptrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.chptrd( uplo, ap)\n or\n NumRu::Lapack.chptrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRD reduces a complex Hermitian matrix A stored in packed form to\n* real symmetric tridiagonal form T by a unitary similarity\n* transformation: Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- chptrd_(&uplo, &n, ap, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_ap);
-}
-
-void
-init_lapack_chptrd(VALUE mLapack){
- rb_define_module_function(mLapack, "chptrd", rb_chptrd, -1);
-}
diff --git a/chptrf.c b/chptrf.c
deleted file mode 100644
index ac02dec..0000000
--- a/chptrf.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chptrf_(char *uplo, integer *n, complex *ap, integer *ipiv, integer *info);
-
-static VALUE
-rb_chptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.chptrf( uplo, ap)\n or\n NumRu::Lapack.chptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRF computes the factorization of a complex Hermitian packed\n* matrix A using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- chptrf_(&uplo, &n, ap, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ap);
-}
-
-void
-init_lapack_chptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "chptrf", rb_chptrf, -1);
-}
diff --git a/chptri.c b/chptri.c
deleted file mode 100644
index cd4bcc5..0000000
--- a/chptri.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chptri_(char *uplo, integer *n, complex *ap, integer *ipiv, complex *work, integer *info);
-
-static VALUE
-rb_chptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- complex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.chptri( uplo, ap, ipiv)\n or\n NumRu::Lapack.chptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRI computes the inverse of a complex Hermitian indefinite matrix\n* A in packed storage using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CHPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* WORK (workspace) COMPLEX 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(complex, (n));
-
- chptri_(&uplo, &n, ap, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_chptri(VALUE mLapack){
- rb_define_module_function(mLapack, "chptri", rb_chptri, -1);
-}
diff --git a/chptrs.c b/chptrs.c
deleted file mode 100644
index 9ea0754..0000000
--- a/chptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chptrs_(char *uplo, integer *n, integer *nrhs, complex *ap, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_chptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.chptrs( uplo, ap, ipiv, b)\n or\n NumRu::Lapack.chptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A stored in packed format using the factorization\n* A = U*D*U**H or A = L*D*L**H computed by CHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- chptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_chptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "chptrs", rb_chptrs, -1);
-}
diff --git a/chsein.c b/chsein.c
deleted file mode 100644
index a3107ed..0000000
--- a/chsein.c
+++ /dev/null
@@ -1,166 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chsein_(char *side, char *eigsrc, char *initv, logical *select, integer *n, complex *h, integer *ldh, complex *w, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, real *rwork, integer *ifaill, integer *ifailr, integer *info);
-
-static VALUE
-rb_chsein(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_eigsrc;
- char eigsrc;
- VALUE rb_initv;
- char initv;
- VALUE rb_select;
- logical *select;
- VALUE rb_h;
- complex *h;
- VALUE rb_w;
- complex *w;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_ifaill;
- integer *ifaill;
- VALUE rb_ifailr;
- integer *ifailr;
- VALUE rb_info;
- integer info;
- VALUE rb_w_out__;
- complex *w_out__;
- VALUE rb_vl_out__;
- complex *vl_out__;
- VALUE rb_vr_out__;
- complex *vr_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldh;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.chsein( side, eigsrc, initv, select, h, w, vl, vr)\n or\n NumRu::Lapack.chsein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* CHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a complex upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in W:\n* = 'Q': the eigenvalues were found using CHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows CHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, CHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* eigenvector corresponding to the eigenvalue W(j),\n* SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input/output) COMPLEX array, dimension (N)\n* On entry, the eigenvalues of H.\n* On exit, the real parts of W may have been altered since\n* close eigenvalues are perturbed slightly in searching for\n* independent eigenvectors.\n*\n* VL (input/output) COMPLEX array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) COMPLEX array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors (= the number of .TRUE. elements in\n* SELECT).\n*\n* WORK (workspace) COMPLEX array, dimension (N*N)\n*\n* RWORK (workspace) REAL array, dimension (N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_eigsrc = argv[1];
- rb_initv = argv[2];
- rb_select = argv[3];
- rb_h = argv[4];
- rb_w = argv[5];
- rb_vl = argv[6];
- rb_vr = argv[7];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_SCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, complex*);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (6th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SCOMPLEX)
- rb_w = na_change_type(rb_w, NA_SCOMPLEX);
- w = NA_PTR_TYPE(rb_w, complex*);
- side = StringValueCStr(rb_side)[0];
- eigsrc = StringValueCStr(rb_eigsrc)[0];
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (8th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_SCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, complex*);
- initv = StringValueCStr(rb_initv)[0];
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of w");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 0 of w");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifaill = NA_PTR_TYPE(rb_ifaill, integer*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifailr = NA_PTR_TYPE(rb_ifailr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, complex*);
- MEMCPY(w_out__, w, complex, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, complex*);
- MEMCPY(vl_out__, vl, complex, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, complex*);
- MEMCPY(vr_out__, vr, complex, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(complex, (n*n));
- rwork = ALLOC_N(real, (n));
-
- chsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, w, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, ifaill, ifailr, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_ifaill, rb_ifailr, rb_info, rb_w, rb_vl, rb_vr);
-}
-
-void
-init_lapack_chsein(VALUE mLapack){
- rb_define_module_function(mLapack, "chsein", rb_chsein, -1);
-}
diff --git a/chseqr.c b/chseqr.c
deleted file mode 100644
index 41aa777..0000000
--- a/chseqr.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID chseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, complex *h, integer *ldh, complex *w, complex *z, integer *ldz, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_chseqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- complex *h;
- VALUE rb_z;
- complex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- complex *w;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.chseqr( job, compz, ilo, ihi, h, z, ldz, lwork)\n or\n NumRu::Lapack.chseqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an unitary matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to CGEBAL, and then passed to CGEHRD\n* when the matrix output by CGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', H contains the upper\n* triangular matrix T from the Schur decomposition (the\n* Schur form). If INFO = 0 and JOB = 'E', the contents of\n* H are unspecified on exit. (The output value of H when\n* INFO.GT.0 is given under the description of INFO below.)\n*\n* Unlike earlier versions of CHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues. If JOB = 'S', the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the unitary matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the unitary matrix generated by CUNGHR\n* after the call to CGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then CHSEQR does a workspace query.\n* In this case, CHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, CHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The CLAHQR vs CLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* CLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_z = argv[5];
- rb_ldz = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- ldz = NUM2INT(rb_ldz);
- compz = StringValueCStr(rb_compz)[0];
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (lsame_(&compz,"N") ? 0 : n))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
- if (NA_SHAPE0(rb_z) != (lsame_(&compz,"N") ? 0 : ldz))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = lsame_(&compz,"N") ? 0 : ldz;
- shape[1] = lsame_(&compz,"N") ? 0 : n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- chseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, w, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_chseqr(VALUE mLapack){
- rb_define_module_function(mLapack, "chseqr", rb_chseqr, -1);
-}
diff --git a/cla_gbamv.c b/cla_gbamv.c
deleted file mode 100644
index 358111c..0000000
--- a/cla_gbamv.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_gbamv_(integer *trans, integer *m, integer *n, integer *kl, integer *ku, real *alpha, real *ab, integer *ldab, real *x, integer *incx, real *beta, real *y, integer *incy);
-
-static VALUE
-rb_cla_gbamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_ab;
- real *ab;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- real beta;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy)\n or\n NumRu::Lapack.cla_gbamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) REAL array, dimension (LDA,n)\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension at least\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension at least\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_alpha = argv[4];
- rb_ab = argv[5];
- rb_x = argv[6];
- rb_incx = argv[7];
- rb_beta = argv[8];
- rb_y = argv[9];
- rb_incy = argv[10];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (MAX(1,m)))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", MAX(1,m));
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- trans = NUM2INT(rb_trans);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- beta = (real)NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- alpha = (real)NUM2DBL(rb_alpha);
- incx = NUM2INT(rb_incx);
- ldab = MAX(1,m);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (10th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- cla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_cla_gbamv(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gbamv", rb_cla_gbamv, -1);
-}
diff --git a/cla_gbrcond_c.c b/cla_gbrcond_c.c
deleted file mode 100644
index 3a94c13..0000000
--- a/cla_gbrcond_c.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_gbrcond_c_(char *trans, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *ipiv, real *c, logical *capply, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_gbrcond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- real *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.cla_gbrcond_c # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_GBRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_c = argv[6];
- rb_capply = argv[7];
- rb_work = argv[8];
- rb_rwork = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (10th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- trans = StringValueCStr(rb_trans)[0];
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (9th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_gbrcond_c_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_gbrcond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gbrcond_c", rb_cla_gbrcond_c, -1);
-}
diff --git a/cla_gbrcond_x.c b/cla_gbrcond_x.c
deleted file mode 100644
index 8f0df5a..0000000
--- a/cla_gbrcond_x.c
+++ /dev/null
@@ -1,119 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_gbrcond_x_(char *trans, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *ipiv, complex *x, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_gbrcond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- complex *x;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork)\n or\n NumRu::Lapack.cla_gbrcond_x # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_GBRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_x = argv[6];
- rb_work = argv[7];
- rb_rwork = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (9th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (8th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_gbrcond_x_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_gbrcond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gbrcond_x", rb_cla_gbrcond_x, -1);
-}
diff --git a/cla_gbrfsx_extended.c b/cla_gbrfsx_extended.c
deleted file mode 100644
index bf3558e..0000000
--- a/cla_gbrfsx_extended.c
+++ /dev/null
@@ -1,280 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_gbrfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *kl, integer *ku, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, integer *ipiv, logical *colequ, real *c, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, complex *res, real *ayb, complex *dy, complex *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_cla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_ldab;
- integer ldab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb_ldafb;
- integer ldafb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_y;
- complex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- complex *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- complex *dy;
- VALUE rb_y_tail;
- complex *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- complex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, ldab, afb, ldafb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.cla_gbrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GBRFSX_EXTENDED ( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* AB (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AFB (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGBTRF.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 25)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 25)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_ldab = argv[5];
- rb_afb = argv[6];
- rb_ldafb = argv[7];
- rb_ipiv = argv[8];
- rb_colequ = argv[9];
- rb_c = argv[10];
- rb_b = argv[11];
- rb_y = argv[12];
- rb_n_norms = argv[13];
- rb_err_bnds_norm = argv[14];
- rb_err_bnds_comp = argv[15];
- rb_res = argv[16];
- rb_ayb = argv[17];
- rb_dy = argv[18];
- rb_y_tail = argv[19];
- rb_rcond = argv[20];
- rb_ithresh = argv[21];
- rb_rthresh = argv[22];
- rb_dz_ub = argv[23];
- rb_ignore_cwise = argv[24];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (17th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (17th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SCOMPLEX)
- rb_res = na_change_type(rb_res, NA_SCOMPLEX);
- res = NA_PTR_TYPE(rb_res, complex*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (12th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (12th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (13th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (13th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (11th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (20th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (20th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_SCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, complex*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (15th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (15th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_norm);
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (16th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (16th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_comp) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (7th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- n_norms = NUM2INT(rb_n_norms);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (19th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (19th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_SCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, complex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (18th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- prec_type = NUM2INT(rb_prec_type);
- ldab = lda = MAX(1,n);
- ldafb = ldaf = MAX(1,n);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- cla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_cla_gbrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gbrfsx_extended", rb_cla_gbrfsx_extended, -1);
-}
diff --git a/cla_gbrpvgrw.c b/cla_gbrpvgrw.c
deleted file mode 100644
index 6a98327..0000000
--- a/cla_gbrpvgrw.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_gbrpvgrw_(integer *n, integer *kl, integer *ku, integer *ncols, complex *ab, integer *ldab, complex *afb, integer *ldafb);
-
-static VALUE
-rb_cla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb___out__;
- real __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_gbrpvgrw( kl, ku, ncols, ab, afb)\n or\n NumRu::Lapack.cla_gbrpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* CLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n REAL AMAX, UMAX, RPVGRW\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ncols = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- ku = NUM2INT(rb_ku);
-
- __out__ = cla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_cla_gbrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gbrpvgrw", rb_cla_gbrpvgrw, -1);
-}
diff --git a/cla_geamv.c b/cla_geamv.c
deleted file mode 100644
index 9c89456..0000000
--- a/cla_geamv.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_geamv_(integer *trans, integer *m, integer *n, real *alpha, complex *a, integer *lda, complex *x, integer *incx, real *beta, real *y, integer *incy);
-
-static VALUE
-rb_cla_geamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- complex *a;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- real beta;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_geamv( trans, m, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.cla_geamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension (LDA,n)\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_a = argv[3];
- rb_x = argv[4];
- rb_incx = argv[5];
- rb_beta = argv[6];
- rb_y = argv[7];
- rb_incy = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- trans = NUM2INT(rb_trans);
- m = NUM2INT(rb_m);
- alpha = (real)NUM2DBL(rb_alpha);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- beta = (real)NUM2DBL(rb_beta);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- cla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_cla_geamv(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_geamv", rb_cla_geamv, -1);
-}
diff --git a/cla_gercond_c.c b/cla_gercond_c.c
deleted file mode 100644
index 8b44572..0000000
--- a/cla_gercond_c.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_gercond_c_(char *trans, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, real *c, logical *capply, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_gercond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- real *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.cla_gercond_c # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n* \n* CLA_GERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_c = argv[4];
- rb_capply = argv[5];
- rb_work = argv[6];
- rb_rwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_gercond_c_(&trans, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_gercond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gercond_c", rb_cla_gercond_c, -1);
-}
diff --git a/cla_gercond_x.c b/cla_gercond_x.c
deleted file mode 100644
index e2aba9a..0000000
--- a/cla_gercond_x.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_gercond_x_(char *trans, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_gercond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- complex *x;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gercond_x( trans, a, af, ipiv, x, work, rwork)\n or\n NumRu::Lapack.cla_gercond_x # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n* \n* CLA_GERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_x = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_gercond_x_(&trans, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_gercond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gercond_x", rb_cla_gercond_x, -1);
-}
diff --git a/cla_gerfsx_extended.c b/cla_gerfsx_extended.c
deleted file mode 100644
index 85f4482..0000000
--- a/cla_gerfsx_extended.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_gerfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out, integer *n_norms, real *errs_n, real *errs_c, complex *res, real *ayb, complex *dy, complex *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_cla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_y;
- complex *y;
- VALUE rb_errs_n;
- real *errs_n;
- VALUE rb_errs_c;
- real *errs_c;
- VALUE rb_res;
- complex *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- complex *dy;
- VALUE rb_y_tail;
- complex *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- complex *y_out__;
- VALUE rb_errs_n_out__;
- real *errs_n_out__;
- VALUE rb_errs_c_out__;
- real *errs_c_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_norms;
- integer n_norsm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, errs_n, errs_c = NumRu::Lapack.cla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.cla_gerfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* CLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 20)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_errs_n = argv[9];
- rb_errs_c = argv[10];
- rb_res = argv[11];
- rb_ayb = argv[12];
- rb_dy = argv[13];
- rb_y_tail = argv[14];
- rb_rcond = argv[15];
- rb_ithresh = argv[16];
- rb_rthresh = argv[17];
- rb_dz_ub = argv[18];
- rb_ignore_cwise = argv[19];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (12th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SCOMPLEX)
- rb_res = na_change_type(rb_res, NA_SCOMPLEX);
- res = NA_PTR_TYPE(rb_res, complex*);
- if (!NA_IsNArray(rb_errs_c))
- rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
- if (NA_RANK(rb_errs_c) != 2)
- rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
- n_norms = NA_SHAPE1(rb_errs_c);
- nrhs = NA_SHAPE0(rb_errs_c);
- if (NA_TYPE(rb_errs_c) != NA_SFLOAT)
- rb_errs_c = na_change_type(rb_errs_c, NA_SFLOAT);
- errs_c = NA_PTR_TYPE(rb_errs_c, real*);
- if (!NA_IsNArray(rb_errs_n))
- rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
- if (NA_RANK(rb_errs_n) != 2)
- rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_errs_n) != n_norms)
- rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be the same as shape 1 of errs_c");
- if (NA_SHAPE0(rb_errs_n) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 0 of errs_c");
- if (NA_TYPE(rb_errs_n) != NA_SFLOAT)
- rb_errs_n = na_change_type(rb_errs_n, NA_SFLOAT);
- errs_n = NA_PTR_TYPE(rb_errs_n, real*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of errs_c");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 0 of errs_c");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_SCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- n_norsm = 3;
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_SCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, complex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_errs_n_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- errs_n_out__ = NA_PTR_TYPE(rb_errs_n_out__, real*);
- MEMCPY(errs_n_out__, errs_n, real, NA_TOTAL(rb_errs_n));
- rb_errs_n = rb_errs_n_out__;
- errs_n = errs_n_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_errs_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- errs_c_out__ = NA_PTR_TYPE(rb_errs_c_out__, real*);
- MEMCPY(errs_c_out__, errs_c, real, NA_TOTAL(rb_errs_c));
- rb_errs_c = rb_errs_c_out__;
- errs_c = errs_c_out__;
-
- cla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_errs_n, rb_errs_c);
-}
-
-void
-init_lapack_cla_gerfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_gerfsx_extended", rb_cla_gerfsx_extended, -1);
-}
diff --git a/cla_heamv.c b/cla_heamv.c
deleted file mode 100644
index 7ea572c..0000000
--- a/cla_heamv.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_heamv_(integer *uplo, integer *n, real *alpha, real *a, integer *lda, complex *x, integer *incx, real *beta, real *y, integer *incy);
-
-static VALUE
-rb_cla_heamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- integer uplo;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- real *a;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- real beta;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_heamv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.cla_heamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1,n)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1,n));
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = NUM2INT(rb_uplo);
- alpha = (real)NUM2DBL(rb_alpha);
- beta = (real)NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1,n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- cla_heamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_cla_heamv(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_heamv", rb_cla_heamv, -1);
-}
diff --git a/cla_hercond_c.c b/cla_hercond_c.c
deleted file mode 100644
index 0fa65c8..0000000
--- a/cla_hercond_c.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_hercond_c_(char *uplo, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, real *c, logical *capply, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_hercond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- real *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.cla_hercond_c # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_HERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_c = argv[4];
- rb_capply = argv[5];
- rb_work = argv[6];
- rb_rwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_hercond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_hercond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_hercond_c", rb_cla_hercond_c, -1);
-}
diff --git a/cla_hercond_x.c b/cla_hercond_x.c
deleted file mode 100644
index 6a2cb29..0000000
--- a/cla_hercond_x.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_hercond_x_(char *uplo, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_hercond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- complex *x;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_hercond_x( uplo, a, af, ipiv, x, work, rwork)\n or\n NumRu::Lapack.cla_hercond_x # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_HERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_x = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_hercond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_hercond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_hercond_x", rb_cla_hercond_x, -1);
-}
diff --git a/cla_herfsx_extended.c b/cla_herfsx_extended.c
deleted file mode 100644
index 74dc6e4..0000000
--- a/cla_herfsx_extended.c
+++ /dev/null
@@ -1,264 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_herfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, complex *res, real *ayb, complex *dy, complex *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_cla_herfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_y;
- complex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- complex *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- complex *dy;
- VALUE rb_y_tail;
- complex *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- complex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.cla_herfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_HERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CHERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CHETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CHETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_n_norms = argv[9];
- rb_err_bnds_norm = argv[10];
- rb_err_bnds_comp = argv[11];
- rb_res = argv[12];
- rb_ayb = argv[13];
- rb_dy = argv[14];
- rb_y_tail = argv[15];
- rb_rcond = argv[16];
- rb_ithresh = argv[17];
- rb_rthresh = argv[18];
- rb_dz_ub = argv[19];
- rb_ignore_cwise = argv[20];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (13th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SCOMPLEX)
- rb_res = na_change_type(rb_res, NA_SCOMPLEX);
- res = NA_PTR_TYPE(rb_res, complex*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_SCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_SCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, complex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- cla_herfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_cla_herfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_herfsx_extended", rb_cla_herfsx_extended, -1);
-}
diff --git a/cla_herpvgrw.c b/cla_herpvgrw.c
deleted file mode 100644
index 405ce65..0000000
--- a/cla_herpvgrw.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_herpvgrw_(char *uplo, integer *n, integer *info, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *work);
-
-static VALUE
-rb_cla_herpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_info;
- integer info;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- complex *work;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_herpvgrw( uplo, info, a, af, ipiv, work)\n or\n NumRu::Lapack.cla_herpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* CLA_HERPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from SSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* WORK (input) COMPLEX array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER, LSAME\n COMPLEX ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, CLASET\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX, MIN\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_info = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_work = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- info = NUM2INT(rb_info);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_herpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_cla_herpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_herpvgrw", rb_cla_herpvgrw, -1);
-}
diff --git a/cla_lin_berr.c b/cla_lin_berr.c
deleted file mode 100644
index 6324b43..0000000
--- a/cla_lin_berr.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_lin_berr_(integer *n, integer *nz, integer *nrhs, doublereal *res, doublereal *ayb, complex *berr);
-
-static VALUE
-rb_cla_lin_berr(int argc, VALUE *argv, VALUE self){
- VALUE rb_nz;
- integer nz;
- VALUE rb_res;
- doublereal *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_berr;
- complex *berr;
-
- integer n;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr = NumRu::Lapack.cla_lin_berr( nz, res, ayb)\n or\n NumRu::Lapack.cla_lin_berr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* CLA_LIN_BERR computes componentwise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z.\n*\n\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see cla_gerfsx_extended.f).\n* \n* BERR (output) COMPLEX array, dimension (NRHS)\n* The componentwise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL TMP\n INTEGER I, J\n COMPLEX CDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX\n* ..\n* .. External Functions ..\n EXTERNAL SLAMCH\n REAL SLAMCH\n REAL SAFE1\n* ..\n* .. Statement Functions ..\n COMPLEX CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_nz = argv[0];
- rb_res = argv[1];
- rb_ayb = argv[2];
-
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (2th argument) must be NArray");
- if (NA_RANK(rb_res) != 2)
- rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_res);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DFLOAT)
- rb_res = na_change_type(rb_res, NA_DFLOAT);
- res = NA_PTR_TYPE(rb_res, doublereal*);
- nz = NUM2INT(rb_nz);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 2)
- rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ayb) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of ayb must be the same as shape 1 of res");
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, complex*);
-
- cla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
-
- return rb_berr;
-}
-
-void
-init_lapack_cla_lin_berr(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_lin_berr", rb_cla_lin_berr, -1);
-}
diff --git a/cla_porcond_c.c b/cla_porcond_c.c
deleted file mode 100644
index 3452c91..0000000
--- a/cla_porcond_c.c
+++ /dev/null
@@ -1,103 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_porcond_c_(char *uplo, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, real *c, logical *capply, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_porcond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_c;
- real *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_porcond_c( uplo, a, af, c, capply, work, rwork)\n or\n NumRu::Lapack.cla_porcond_c # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_PORCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_c = argv[3];
- rb_capply = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of a");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_porcond_c_(&uplo, &n, a, &lda, af, &ldaf, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_porcond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_porcond_c", rb_cla_porcond_c, -1);
-}
diff --git a/cla_porcond_x.c b/cla_porcond_x.c
deleted file mode 100644
index 7fdd811..0000000
--- a/cla_porcond_x.c
+++ /dev/null
@@ -1,99 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_porcond_x_(char *uplo, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, complex *x, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_porcond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_x;
- complex *x;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_porcond_x( uplo, a, af, x, work, rwork)\n or\n NumRu::Lapack.cla_porcond_x # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_PORCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_x = argv[3];
- rb_work = argv[4];
- rb_rwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (6th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of a");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (5th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_porcond_x_(&uplo, &n, a, &lda, af, &ldaf, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_porcond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_porcond_x", rb_cla_porcond_x, -1);
-}
diff --git a/cla_porfsx_extended.c b/cla_porfsx_extended.c
deleted file mode 100644
index 0e4e026..0000000
--- a/cla_porfsx_extended.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_porfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, logical *colequ, real *c, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, complex *res, real *ayb, complex *dy, complex *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_cla_porfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_y;
- complex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- complex *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- complex *dy;
- VALUE rb_y_tail;
- complex *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- complex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.cla_porfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 20)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_colequ = argv[4];
- rb_c = argv[5];
- rb_b = argv[6];
- rb_y = argv[7];
- rb_n_norms = argv[8];
- rb_err_bnds_norm = argv[9];
- rb_err_bnds_comp = argv[10];
- rb_res = argv[11];
- rb_ayb = argv[12];
- rb_dy = argv[13];
- rb_y_tail = argv[14];
- rb_rcond = argv[15];
- rb_ithresh = argv[16];
- rb_rthresh = argv[17];
- rb_dz_ub = argv[18];
- rb_ignore_cwise = argv[19];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (12th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SCOMPLEX)
- rb_res = na_change_type(rb_res, NA_SCOMPLEX);
- res = NA_PTR_TYPE(rb_res, complex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_SCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_SCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, complex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- cla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_cla_porfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_porfsx_extended", rb_cla_porfsx_extended, -1);
-}
diff --git a/cla_porpvgrw.c b/cla_porpvgrw.c
deleted file mode 100644
index 63748a7..0000000
--- a/cla_porpvgrw.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_porpvgrw_(char *uplo, integer *ncols, complex *a, integer *lda, complex *af, integer *ldaf, complex *work);
-
-static VALUE
-rb_cla_porpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_work;
- complex *work;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_porpvgrw( uplo, ncols, a, af, work)\n or\n NumRu::Lapack.cla_porpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* CLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) COMPLEX array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n COMPLEX ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, CLASET\n LOGICAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ncols = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_work = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ncols = NUM2INT(rb_ncols);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (5th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_cla_porpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_porpvgrw", rb_cla_porpvgrw, -1);
-}
diff --git a/cla_rpvgrw.c b/cla_rpvgrw.c
deleted file mode 100644
index e3045a3..0000000
--- a/cla_rpvgrw.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_rpvgrw_(integer *n, integer *ncols, complex *a, integer *lda, complex *af, integer *ldaf);
-
-static VALUE
-rb_cla_rpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_rpvgrw( ncols, a, af)\n or\n NumRu::Lapack.cla_rpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n* \n* CLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN, ABS, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ncols = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
-
- __out__ = cla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_cla_rpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_rpvgrw", rb_cla_rpvgrw, -1);
-}
diff --git a/cla_syamv.c b/cla_syamv.c
deleted file mode 100644
index e38cf54..0000000
--- a/cla_syamv.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_syamv_(integer *uplo, integer *n, real *alpha, real *a, integer *lda, complex *x, integer *incx, real *beta, real *y, integer *incy);
-
-static VALUE
-rb_cla_syamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- integer uplo;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- real *a;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- real beta;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_syamv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.cla_syamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1, n)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = NUM2INT(rb_uplo);
- alpha = (real)NUM2DBL(rb_alpha);
- beta = (real)NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1, n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- cla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_cla_syamv(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_syamv", rb_cla_syamv, -1);
-}
diff --git a/cla_syrcond_c.c b/cla_syrcond_c.c
deleted file mode 100644
index f1aa8c5..0000000
--- a/cla_syrcond_c.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_syrcond_c_(char *uplo, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, real *c, logical *capply, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_syrcond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- real *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.cla_syrcond_c # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_SYRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_c = argv[4];
- rb_capply = argv[5];
- rb_work = argv[6];
- rb_rwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_syrcond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_syrcond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_syrcond_c", rb_cla_syrcond_c, -1);
-}
diff --git a/cla_syrcond_x.c b/cla_syrcond_x.c
deleted file mode 100644
index 18be7ad..0000000
--- a/cla_syrcond_x.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_syrcond_x_(char *uplo, integer *n, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *x, integer *info, complex *work, real *rwork);
-
-static VALUE
-rb_cla_syrcond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- complex *x;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_syrcond_x( uplo, a, af, ipiv, x, work, rwork)\n or\n NumRu::Lapack.cla_syrcond_x # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_SYRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_x = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_SFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_SFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_syrcond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_cla_syrcond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_syrcond_x", rb_cla_syrcond_x, -1);
-}
diff --git a/cla_syrfsx_extended.c b/cla_syrfsx_extended.c
deleted file mode 100644
index e63b507..0000000
--- a/cla_syrfsx_extended.c
+++ /dev/null
@@ -1,264 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_syrfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, complex *res, real *ayb, complex *dy, complex *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_cla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- complex *b;
- VALUE rb_y;
- complex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- complex *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- complex *dy;
- VALUE rb_y_tail;
- complex *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- complex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.cla_syrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_n_norms = argv[9];
- rb_err_bnds_norm = argv[10];
- rb_err_bnds_comp = argv[11];
- rb_res = argv[12];
- rb_ayb = argv[13];
- rb_dy = argv[14];
- rb_y_tail = argv[15];
- rb_rcond = argv[16];
- rb_ithresh = argv[17];
- rb_rthresh = argv[18];
- rb_dz_ub = argv[19];
- rb_ignore_cwise = argv[20];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (13th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SCOMPLEX)
- rb_res = na_change_type(rb_res, NA_SCOMPLEX);
- res = NA_PTR_TYPE(rb_res, complex*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_SCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_SCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, complex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- cla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_cla_syrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_syrfsx_extended", rb_cla_syrfsx_extended, -1);
-}
diff --git a/cla_syrpvgrw.c b/cla_syrpvgrw.c
deleted file mode 100644
index ab04246..0000000
--- a/cla_syrpvgrw.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern real cla_syrpvgrw_(char *uplo, integer *n, integer *info, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *work);
-
-static VALUE
-rb_cla_syrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_info;
- integer info;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- complex *work;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_syrpvgrw( uplo, info, a, af, ipiv, work)\n or\n NumRu::Lapack.cla_syrpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* CLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from CSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* WORK (input) COMPLEX array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX, MIN\n* ..\n* .. External Subroutines ..\n EXTERNAL LSAME, CLASET\n LOGICAL LSAME\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_info = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_work = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- info = NUM2INT(rb_info);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SCOMPLEX)
- rb_work = na_change_type(rb_work, NA_SCOMPLEX);
- work = NA_PTR_TYPE(rb_work, complex*);
-
- __out__ = cla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_cla_syrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_syrpvgrw", rb_cla_syrpvgrw, -1);
-}
diff --git a/cla_wwaddw.c b/cla_wwaddw.c
deleted file mode 100644
index 8880557..0000000
--- a/cla_wwaddw.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cla_wwaddw_(integer *n, complex *x, complex *y, complex *w);
-
-static VALUE
-rb_cla_wwaddw(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- complex *x;
- VALUE rb_y;
- complex *y;
- VALUE rb_w;
- complex *w;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_y_out__;
- complex *y_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.cla_wwaddw( x, y, w)\n or\n NumRu::Lapack.cla_wwaddw # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* CLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) COMPLEX array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) COMPLEX array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) COMPLEX array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n COMPLEX S\n INTEGER I\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_w = argv[2];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SCOMPLEX)
- rb_w = na_change_type(rb_w, NA_SCOMPLEX);
- w = NA_PTR_TYPE(rb_w, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (2th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of w");
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- cla_wwaddw_(&n, x, y, w);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_cla_wwaddw(VALUE mLapack){
- rb_define_module_function(mLapack, "cla_wwaddw", rb_cla_wwaddw, -1);
-}
diff --git a/clabrd.c b/clabrd.c
deleted file mode 100644
index 76c7c72..0000000
--- a/clabrd.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clabrd_(integer *m, integer *n, integer *nb, complex *a, integer *lda, real *d, real *e, complex *tauq, complex *taup, complex *x, integer *ldx, complex *y, integer *ldy);
-
-static VALUE
-rb_clabrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- complex *a;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tauq;
- complex *tauq;
- VALUE rb_taup;
- complex *taup;
- VALUE rb_x;
- complex *x;
- VALUE rb_y;
- complex *y;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer ldx;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.clabrd( m, nb, a)\n or\n NumRu::Lapack.clabrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* CLABRD reduces the first NB rows and columns of a complex general\n* m by n matrix A to upper or lower real bidiagonal form by a unitary\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by CGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the unitary matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) COMPLEX array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* X (output) COMPLEX array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,M).\n*\n* Y (output) COMPLEX array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- nb = NUM2INT(rb_nb);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ldy = MAX(1,n);
- ldx = MAX(1,m);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, complex*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = MAX(1,nb);
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
-
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_x, rb_y, rb_a);
-}
-
-void
-init_lapack_clabrd(VALUE mLapack){
- rb_define_module_function(mLapack, "clabrd", rb_clabrd, -1);
-}
diff --git a/clacgv.c b/clacgv.c
deleted file mode 100644
index 584a0a7..0000000
--- a/clacgv.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clacgv_(integer *n, complex *x, integer *incx);
-
-static VALUE
-rb_clacgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_x_out__;
- complex *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.clacgv( n, x, incx)\n or\n NumRu::Lapack.clacgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACGV( N, X, INCX )\n\n* Purpose\n* =======\n*\n* CLACGV conjugates a complex vector of length N.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vector X. N >= 0.\n*\n* X (input/output) COMPLEX array, dimension\n* (1+(N-1)*abs(INCX))\n* On entry, the vector of length N to be conjugated.\n* On exit, X is overwritten with conjg(X).\n*\n* INCX (input) INTEGER\n* The spacing between successive elements of X.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IOFF\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
-
- incx = NUM2INT(rb_incx);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*abs(incx);
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- clacgv_(&n, x, &incx);
-
- return rb_x;
-}
-
-void
-init_lapack_clacgv(VALUE mLapack){
- rb_define_module_function(mLapack, "clacgv", rb_clacgv, -1);
-}
diff --git a/clacn2.c b/clacn2.c
deleted file mode 100644
index 3ec525e..0000000
--- a/clacn2.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clacn2_(integer *n, complex *v, complex *x, real *est, integer *kase, integer *isave);
-
-static VALUE
-rb_clacn2(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- complex *x;
- VALUE rb_est;
- real est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_isave;
- integer *isave;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_isave_out__;
- integer *isave_out__;
- complex *v;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.clacn2( x, est, kase, isave)\n or\n NumRu::Lapack.clacn2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* CLACN2 estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and CLACN2 must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to CLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to CLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from CLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to SLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* This is a thread safe version of CLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* CLACON CLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
- rb_isave = argv[3];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- est = (real)NUM2DBL(rb_est);
- if (!NA_IsNArray(rb_isave))
- rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
- if (NA_RANK(rb_isave) != 1)
- rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isave) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
- if (NA_TYPE(rb_isave) != NA_LINT)
- rb_isave = na_change_type(rb_isave, NA_LINT);
- isave = NA_PTR_TYPE(rb_isave, integer*);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 3;
- rb_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isave_out__ = NA_PTR_TYPE(rb_isave_out__, integer*);
- MEMCPY(isave_out__, isave, integer, NA_TOTAL(rb_isave));
- rb_isave = rb_isave_out__;
- isave = isave_out__;
- v = ALLOC_N(complex, (n));
-
- clacn2_(&n, v, x, &est, &kase, isave);
-
- free(v);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(4, rb_x, rb_est, rb_kase, rb_isave);
-}
-
-void
-init_lapack_clacn2(VALUE mLapack){
- rb_define_module_function(mLapack, "clacn2", rb_clacn2, -1);
-}
diff --git a/clacon.c b/clacon.c
deleted file mode 100644
index 5a42f4b..0000000
--- a/clacon.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clacon_(integer *n, complex *v, complex *x, real *est, integer *kase);
-
-static VALUE
-rb_clacon(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- complex *x;
- VALUE rb_est;
- real est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *v;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.clacon( x, est, kase)\n or\n NumRu::Lapack.clacon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACON( N, V, X, EST, KASE )\n\n* Purpose\n* =======\n*\n* CLACON estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and CLACON must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to CLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to CLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from CLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- est = (real)NUM2DBL(rb_est);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- v = ALLOC_N(complex, (n));
-
- clacon_(&n, v, x, &est, &kase);
-
- free(v);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(3, rb_x, rb_est, rb_kase);
-}
-
-void
-init_lapack_clacon(VALUE mLapack){
- rb_define_module_function(mLapack, "clacon", rb_clacon, -1);
-}
diff --git a/clacp2.c b/clacp2.c
deleted file mode 100644
index 05b3afd..0000000
--- a/clacp2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clacp2_(char *uplo, integer *m, integer *n, real *a, integer *lda, complex *b, integer *ldb);
-
-static VALUE
-rb_clacp2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- complex *b;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.clacp2( uplo, m, a)\n or\n NumRu::Lapack.clacp2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* CLACP2 copies all or part of a real two-dimensional matrix A to a\n* complex matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- ldb = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b = NA_PTR_TYPE(rb_b, complex*);
-
- clacp2_(&uplo, &m, &n, a, &lda, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_clacp2(VALUE mLapack){
- rb_define_module_function(mLapack, "clacp2", rb_clacp2, -1);
-}
diff --git a/clacpy.c b/clacpy.c
deleted file mode 100644
index 55d9b95..0000000
--- a/clacpy.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clacpy_(char *uplo, integer *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb);
-
-static VALUE
-rb_clacpy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.clacpy( uplo, m, a)\n or\n NumRu::Lapack.clacpy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* CLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- ldb = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b = NA_PTR_TYPE(rb_b, complex*);
-
- clacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_clacpy(VALUE mLapack){
- rb_define_module_function(mLapack, "clacpy", rb_clacpy, -1);
-}
diff --git a/clacrm.c b/clacrm.c
deleted file mode 100644
index 5b63fb3..0000000
--- a/clacrm.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clacrm_(integer *m, integer *n, complex *a, integer *lda, real *b, integer *ldb, complex *c, integer *ldc, real *rwork);
-
-static VALUE
-rb_clacrm(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- real *b;
- VALUE rb_c;
- complex *c;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.clacrm( m, a, b)\n or\n NumRu::Lapack.clacrm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n* Purpose\n* =======\n*\n* CLACRM performs a very simple matrix-matrix multiplication:\n* C := A * B,\n* where A is M by N and complex; B is N by N and real;\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) COMPLEX array, dimension (LDA, N)\n* A contains the M by N 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* B contains the N by N matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >=max(1,N).\n*\n* C (input) COMPLEX 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,N).\n*\n* RWORK (workspace) REAL array, dimension (2*M*N)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- ldc = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, complex*);
- rwork = ALLOC_N(real, (2*m*n));
-
- clacrm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
-
- free(rwork);
- return rb_c;
-}
-
-void
-init_lapack_clacrm(VALUE mLapack){
- rb_define_module_function(mLapack, "clacrm", rb_clacrm, -1);
-}
diff --git a/clacrt.c b/clacrt.c
deleted file mode 100644
index c778bcf..0000000
--- a/clacrt.c
+++ /dev/null
@@ -1,89 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clacrt_(integer *n, complex *cx, integer *incx, complex *cy, integer *incy, complex *c, complex *s);
-
-static VALUE
-rb_clacrt(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- complex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_cy;
- complex *cy;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- complex c;
- VALUE rb_s;
- complex s;
- VALUE rb_cx_out__;
- complex *cx_out__;
- VALUE rb_cy_out__;
- complex *cy_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.clacrt( cx, incx, cy, incy, c, s)\n or\n NumRu::Lapack.clacrt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACRT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* CLACRT performs the operation\n*\n* ( c s )( x ) ==> ( x )\n* ( -s c )( y ) ( y )\n*\n* where c and s are complex and the vectors x and y are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX array, dimension (N)\n* On input, the vector x.\n* On output, CX is overwritten with c*x + s*y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CX. INCX <> 0.\n*\n* CY (input/output) COMPLEX array, dimension (N)\n* On input, the vector y.\n* On output, CY is overwritten with -s*x + c*y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCY <> 0.\n*\n* C (input) COMPLEX\n* S (input) COMPLEX\n* C and S define the matrix\n* [ C S ].\n* [ -S C ]\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX CTEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
- rb_cy = argv[2];
- rb_incy = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
-
- if (!NA_IsNArray(rb_cy))
- rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
- if (NA_RANK(rb_cy) != 1)
- rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cy);
- if (NA_TYPE(rb_cy) != NA_SCOMPLEX)
- rb_cy = na_change_type(rb_cy, NA_SCOMPLEX);
- cy = NA_PTR_TYPE(rb_cy, complex*);
- c.r = (real)NUM2DBL(rb_funcall(rb_c, rb_intern("real"), 0));
- c.i = (real)NUM2DBL(rb_funcall(rb_c, rb_intern("imag"), 0));
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- s.r = (real)NUM2DBL(rb_funcall(rb_s, rb_intern("real"), 0));
- s.i = (real)NUM2DBL(rb_funcall(rb_s, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_cx) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of cx must be the same as shape 0 of cy");
- if (NA_TYPE(rb_cx) != NA_SCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_SCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_cx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- cx_out__ = NA_PTR_TYPE(rb_cx_out__, complex*);
- MEMCPY(cx_out__, cx, complex, NA_TOTAL(rb_cx));
- rb_cx = rb_cx_out__;
- cx = cx_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cy_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- cy_out__ = NA_PTR_TYPE(rb_cy_out__, complex*);
- MEMCPY(cy_out__, cy, complex, NA_TOTAL(rb_cy));
- rb_cy = rb_cy_out__;
- cy = cy_out__;
-
- clacrt_(&n, cx, &incx, cy, &incy, &c, &s);
-
- return rb_ary_new3(2, rb_cx, rb_cy);
-}
-
-void
-init_lapack_clacrt(VALUE mLapack){
- rb_define_module_function(mLapack, "clacrt", rb_clacrt, -1);
-}
diff --git a/cladiv.c b/cladiv.c
deleted file mode 100644
index f7d6a1b..0000000
--- a/cladiv.c
+++ /dev/null
@@ -1,38 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cladiv_(complex *__out__, complex *x, complex *y);
-
-static VALUE
-rb_cladiv(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- complex x;
- VALUE rb_y;
- complex y;
- VALUE rb___out__;
- complex __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cladiv( x, y)\n or\n NumRu::Lapack.cladiv # print help\n\n\nFORTRAN MANUAL\n COMPLEX FUNCTION CLADIV( X, Y )\n\n* Purpose\n* =======\n*\n* CLADIV := X / Y, where X and Y are complex. The computation of X / Y\n* will not overflow on an intermediary step unless the results\n* overflows.\n*\n\n* Arguments\n* =========\n*\n* X (input) COMPLEX\n* Y (input) COMPLEX\n* The complex scalars X and Y.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL ZI, ZR\n* ..\n* .. External Subroutines ..\n EXTERNAL SLADIV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC AIMAG, CMPLX, REAL\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
-
- x.r = (real)NUM2DBL(rb_funcall(rb_x, rb_intern("real"), 0));
- x.i = (real)NUM2DBL(rb_funcall(rb_x, rb_intern("imag"), 0));
- y.r = (real)NUM2DBL(rb_funcall(rb_y, rb_intern("real"), 0));
- y.i = (real)NUM2DBL(rb_funcall(rb_y, rb_intern("imag"), 0));
-
- cladiv_(&__out__, &x, &y);
-
- rb___out__ = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(__out__.r)), rb_float_new((double)(__out__.i)));
- return rb___out__;
-}
-
-void
-init_lapack_cladiv(VALUE mLapack){
- rb_define_module_function(mLapack, "cladiv", rb_cladiv, -1);
-}
diff --git a/claed0.c b/claed0.c
deleted file mode 100644
index dd69f96..0000000
--- a/claed0.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claed0_(integer *qsiz, integer *n, real *d, real *e, complex *q, integer *ldq, complex *qstore, integer *ldqs, real *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_claed0(int argc, VALUE *argv, VALUE self){
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_q;
- complex *q;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- complex *qstore;
- real *rwork;
- integer *iwork;
-
- integer n;
- integer ldq;
- integer ldqs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, q = NumRu::Lapack.claed0( qsiz, d, e, q)\n or\n NumRu::Lapack.claed0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using the divide and conquer method, CLAED0 computes all eigenvalues\n* of a symmetric tridiagonal matrix which is one diagonal block of\n* those from reducing a dense or band Hermitian matrix and\n* corresponding eigenvectors of the dense or band matrix.\n*\n\n* Arguments\n* =========\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, Q must contain an QSIZ x N matrix whose columns\n* unitarily orthonormal. It is a part of the unitary matrix\n* that reduces the full dense Hermitian matrix to a\n* (reducible) symmetric tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IWORK (workspace) INTEGER array,\n* the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* RWORK (workspace) REAL array,\n* dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* QSTORE (workspace) COMPLEX array, dimension (LDQS, N)\n* Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE.\n* LDQS >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* =====================================================================\n*\n* Warning: N could be as big as QSIZ!\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_qsiz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_q = argv[3];
-
- qsiz = NUM2INT(rb_qsiz);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (4th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- ldqs = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- qstore = ALLOC_N(complex, (ldqs)*(n));
- rwork = ALLOC_N(real, (1 + 3*n + 2*n*LG(n) + 3*pow(n,2)));
- iwork = ALLOC_N(integer, (6 + 6*n + 5*n*LG(n)));
-
- claed0_(&qsiz, &n, d, e, q, &ldq, qstore, &ldqs, rwork, iwork, &info);
-
- free(qstore);
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_q);
-}
-
-void
-init_lapack_claed0(VALUE mLapack){
- rb_define_module_function(mLapack, "claed0", rb_claed0, -1);
-}
diff --git a/claed7.c b/claed7.c
deleted file mode 100644
index 66ccd68..0000000
--- a/claed7.c
+++ /dev/null
@@ -1,228 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claed7_(integer *n, integer *cutpnt, integer *qsiz, integer *tlvls, integer *curlvl, integer *curpbm, real *d, complex *q, integer *ldq, real *rho, integer *indxq, real *qstore, integer *qptr, integer *prmptr, integer *perm, integer *givptr, integer *givcol, real *givnum, complex *work, real *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_claed7(int argc, VALUE *argv, VALUE self){
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_tlvls;
- integer tlvls;
- VALUE rb_curlvl;
- integer curlvl;
- VALUE rb_curpbm;
- integer curpbm;
- VALUE rb_d;
- real *d;
- VALUE rb_q;
- complex *q;
- VALUE rb_rho;
- real rho;
- VALUE rb_qstore;
- real *qstore;
- VALUE rb_qptr;
- integer *qptr;
- VALUE rb_prmptr;
- integer *prmptr;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- VALUE rb_qstore_out__;
- real *qstore_out__;
- VALUE rb_qptr_out__;
- integer *qptr_out__;
- complex *work;
- real *rwork;
- integer *iwork;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.claed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum)\n or\n NumRu::Lapack.claed7 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense or banded\n* Hermitian matrix that has been reduced to tridiagonal form.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine SLAED4 (as called by SLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) REAL\n* Contains the subdiagonal element used to create the rank-1\n* modification.\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order,\n* ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* RWORK (workspace) REAL array,\n* dimension (3*N+2*QSIZ*N)\n*\n* WORK (workspace) COMPLEX array, dimension (QSIZ*N)\n*\n* QSTORE (input/output) REAL array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) REAL array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, CURR, I, IDLMDA, INDX,\n $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACRM, CLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_cutpnt = argv[0];
- rb_qsiz = argv[1];
- rb_tlvls = argv[2];
- rb_curlvl = argv[3];
- rb_curpbm = argv[4];
- rb_d = argv[5];
- rb_q = argv[6];
- rb_rho = argv[7];
- rb_qstore = argv[8];
- rb_qptr = argv[9];
- rb_prmptr = argv[10];
- rb_perm = argv[11];
- rb_givptr = argv[12];
- rb_givcol = argv[13];
- rb_givnum = argv[14];
-
- qsiz = NUM2INT(rb_qsiz);
- cutpnt = NUM2INT(rb_cutpnt);
- tlvls = NUM2INT(rb_tlvls);
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- curlvl = NUM2INT(rb_curlvl);
- curpbm = NUM2INT(rb_curpbm);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 1);
- if (NA_SHAPE0(rb_perm) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_prmptr))
- rb_raise(rb_eArgError, "prmptr (11th argument) must be NArray");
- if (NA_RANK(rb_prmptr) != 1)
- rb_raise(rb_eArgError, "rank of prmptr (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_prmptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
- if (NA_TYPE(rb_prmptr) != NA_LINT)
- rb_prmptr = na_change_type(rb_prmptr, NA_LINT);
- prmptr = NA_PTR_TYPE(rb_prmptr, integer*);
- if (!NA_IsNArray(rb_qstore))
- rb_raise(rb_eArgError, "qstore (9th argument) must be NArray");
- if (NA_RANK(rb_qstore) != 1)
- rb_raise(rb_eArgError, "rank of qstore (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qstore) != (pow(n,2)+1))
- rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
- if (NA_TYPE(rb_qstore) != NA_SFLOAT)
- rb_qstore = na_change_type(rb_qstore, NA_SFLOAT);
- qstore = NA_PTR_TYPE(rb_qstore, real*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (13th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (14th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (15th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (15th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
- if (NA_TYPE(rb_givnum) != NA_SFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_SFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- if (!NA_IsNArray(rb_qptr))
- rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
- if (NA_RANK(rb_qptr) != 1)
- rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qptr) != (n+2))
- rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
- if (NA_TYPE(rb_qptr) != NA_LINT)
- rb_qptr = na_change_type(rb_qptr, NA_LINT);
- qptr = NA_PTR_TYPE(rb_qptr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = pow(n,2)+1;
- rb_qstore_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- qstore_out__ = NA_PTR_TYPE(rb_qstore_out__, real*);
- MEMCPY(qstore_out__, qstore, real, NA_TOTAL(rb_qstore));
- rb_qstore = rb_qstore_out__;
- qstore = qstore_out__;
- {
- int shape[1];
- shape[0] = n+2;
- rb_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- qptr_out__ = NA_PTR_TYPE(rb_qptr_out__, integer*);
- MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rb_qptr));
- rb_qptr = rb_qptr_out__;
- qptr = qptr_out__;
- work = ALLOC_N(complex, (qsiz*n));
- rwork = ALLOC_N(real, (3*n+2*qsiz*n));
- iwork = ALLOC_N(integer, (4*n));
-
- claed7_(&n, &cutpnt, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, &rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_indxq, rb_info, rb_d, rb_q, rb_qstore, rb_qptr);
-}
-
-void
-init_lapack_claed7(VALUE mLapack){
- rb_define_module_function(mLapack, "claed7", rb_claed7, -1);
-}
diff --git a/claed8.c b/claed8.c
deleted file mode 100644
index 6f0143d..0000000
--- a/claed8.c
+++ /dev/null
@@ -1,179 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claed8_(integer *k, integer *n, integer *qsiz, complex *q, integer *ldq, real *d, real *rho, integer *cutpnt, real *z, real *dlamda, complex *q2, integer *ldq2, real *w, integer *indxp, integer *indx, integer *indxq, integer *perm, integer *givptr, integer *givcol, real *givnum, integer *info);
-
-static VALUE
-rb_claed8(int argc, VALUE *argv, VALUE self){
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_q;
- complex *q;
- VALUE rb_d;
- real *d;
- VALUE rb_rho;
- real rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_z;
- real *z;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_k;
- integer k;
- VALUE rb_dlamda;
- real *dlamda;
- VALUE rb_q2;
- complex *q2;
- VALUE rb_w;
- real *w;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_info;
- integer info;
- VALUE rb_q_out__;
- complex *q_out__;
- VALUE rb_d_out__;
- real *d_out__;
- integer *indxp;
- integer *indx;
-
- integer ldq;
- integer n;
- integer ldq2;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.claed8( qsiz, q, d, rho, cutpnt, z, indxq)\n or\n NumRu::Lapack.claed8 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n* Purpose\n* =======\n*\n* CLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* Contains the number of non-deflated eigenvalues.\n* This is the order of the related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the dense or band matrix to tridiagonal form.\n* QSIZ >= N if ICOMPQ = 1.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined. On exit, D contains the trailing (N-K) updated\n* eigenvalues (those which were deflated) sorted into increasing\n* order.\n*\n* RHO (input/output) REAL\n* Contains the off diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined. RHO is modified during the computation to\n* the value required by SLAED3.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. MIN(1,N) <= CUTPNT <= N.\n*\n* Z (input) REAL array, dimension (N)\n* On input this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix). The contents of Z are\n* destroyed during the updating process.\n*\n* DLAMDA (output) REAL array, dimension (N)\n* Contains a copy of the first K eigenvalues which will be used\n* by SLAED3 to form the secular equation.\n*\n* Q2 (output) COMPLEX array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* Contains a copy of the first K eigenvectors which will be used\n* by SLAED7 in a matrix multiply (SGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max( 1, N ).\n*\n* W (output) REAL array, dimension (N)\n* This will hold the first k values of the final\n* deflation-altered z-vector and will be passed to SLAED3.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output INDXP(1:K)\n* points to the nondeflated D-values and INDXP(K+1:N)\n* points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that elements in\n* the second half of this permutation must first have CUTPNT\n* added to their values in order to be accurate.\n*\n* PERM (output) INTEGER array, dimension (N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* Contains the number of Givens rotations which took place in\n* this subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) REAL array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_qsiz = argv[0];
- rb_q = argv[1];
- rb_d = argv[2];
- rb_rho = argv[3];
- rb_cutpnt = argv[4];
- rb_z = argv[5];
- rb_indxq = argv[6];
-
- qsiz = NUM2INT(rb_qsiz);
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (7th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- cutpnt = NUM2INT(rb_cutpnt);
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (2th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of indxq");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- ldq2 = MAX( 1, n );
- {
- int shape[1];
- shape[0] = n;
- rb_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dlamda = NA_PTR_TYPE(rb_dlamda, real*);
- {
- int shape[2];
- shape[0] = ldq2;
- shape[1] = n;
- rb_q2 = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q2 = NA_PTR_TYPE(rb_q2, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- indxp = ALLOC_N(integer, (n));
- indx = ALLOC_N(integer, (n));
-
- claed8_(&k, &n, &qsiz, q, &ldq, d, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, indxp, indx, indxq, perm, &givptr, givcol, givnum, &info);
-
- free(indxp);
- free(indx);
- rb_k = INT2NUM(k);
- rb_givptr = INT2NUM(givptr);
- rb_info = INT2NUM(info);
- rb_rho = rb_float_new((double)rho);
- return rb_ary_new3(12, rb_k, rb_dlamda, rb_q2, rb_w, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_info, rb_q, rb_d, rb_rho);
-}
-
-void
-init_lapack_claed8(VALUE mLapack){
- rb_define_module_function(mLapack, "claed8", rb_claed8, -1);
-}
diff --git a/claein.c b/claein.c
deleted file mode 100644
index bc89194..0000000
--- a/claein.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claein_(logical *rightv, logical *noinit, integer *n, complex *h, integer *ldh, complex *w, complex *v, complex *b, integer *ldb, real *rwork, real *eps3, real *smlnum, integer *info);
-
-static VALUE
-rb_claein(int argc, VALUE *argv, VALUE self){
- VALUE rb_rightv;
- logical rightv;
- VALUE rb_noinit;
- logical noinit;
- VALUE rb_h;
- complex *h;
- VALUE rb_w;
- complex w;
- VALUE rb_v;
- complex *v;
- VALUE rb_eps3;
- real eps3;
- VALUE rb_smlnum;
- real smlnum;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- complex *v_out__;
- complex *b;
- real *rwork;
-
- integer ldh;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.claein( rightv, noinit, h, w, v, eps3, smlnum)\n or\n NumRu::Lapack.claein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n* Purpose\n* =======\n*\n* CLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue W of a complex upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in V\n* = .FALSE.: initial vector supplied in V.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input) COMPLEX\n* The eigenvalue of H whose corresponding right or left\n* eigenvector is to be computed.\n*\n* V (input/output) COMPLEX array, dimension (N)\n* On entry, if NOINIT = .FALSE., V must contain a starting\n* vector for inverse iteration; otherwise V need not be set.\n* On exit, V contains the computed eigenvector, normalized so\n* that the component of largest magnitude has magnitude 1; here\n* the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n*\n* B (workspace) COMPLEX array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* RWORK (workspace) REAL array, dimension (N)\n*\n* EPS3 (input) REAL\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) REAL\n* A machine-dependent value close to the underflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; V is set to the\n* last iterate.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_rightv = argv[0];
- rb_noinit = argv[1];
- rb_h = argv[2];
- rb_w = argv[3];
- rb_v = argv[4];
- rb_eps3 = argv[5];
- rb_smlnum = argv[6];
-
- smlnum = (real)NUM2DBL(rb_smlnum);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (5th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- w.r = (real)NUM2DBL(rb_funcall(rb_w, rb_intern("real"), 0));
- w.i = (real)NUM2DBL(rb_funcall(rb_w, rb_intern("imag"), 0));
- eps3 = (real)NUM2DBL(rb_eps3);
- noinit = (rb_noinit == Qtrue);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (3th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of v");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- rightv = (rb_rightv == Qtrue);
- ldb = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_v_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, complex*);
- MEMCPY(v_out__, v, complex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- b = ALLOC_N(complex, (ldb)*(n));
- rwork = ALLOC_N(real, (n));
-
- claein_(&rightv, &noinit, &n, h, &ldh, &w, v, b, &ldb, rwork, &eps3, &smlnum, &info);
-
- free(b);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_claein(VALUE mLapack){
- rb_define_module_function(mLapack, "claein", rb_claein, -1);
-}
diff --git a/claesy.c b/claesy.c
deleted file mode 100644
index c59dcfe..0000000
--- a/claesy.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claesy_(complex *a, complex *b, complex *c, complex *rt1, complex *rt2, complex *evscal, complex *cs1, complex *sn1);
-
-static VALUE
-rb_claesy(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex a;
- VALUE rb_b;
- complex b;
- VALUE rb_c;
- complex c;
- VALUE rb_rt1;
- complex rt1;
- VALUE rb_rt2;
- complex rt2;
- VALUE rb_evscal;
- complex evscal;
- VALUE rb_cs1;
- complex cs1;
- VALUE rb_sn1;
- complex sn1;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.claesy( a, b, c)\n or\n NumRu::Lapack.claesy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n* ( ( A, B );( B, C ) )\n* provided the norm of the matrix of eigenvectors is larger than\n* some threshold value.\n*\n* RT1 is the eigenvalue of larger absolute value, and RT2 of\n* smaller absolute value. If the eigenvectors are computed, then\n* on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n*\n* [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]\n* [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX\n* The ( 1, 1 ) element of input matrix.\n*\n* B (input) COMPLEX\n* The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element\n* is also given by B, since the 2-by-2 matrix is symmetric.\n*\n* C (input) COMPLEX\n* The ( 2, 2 ) element of input matrix.\n*\n* RT1 (output) COMPLEX\n* The eigenvalue of larger modulus.\n*\n* RT2 (output) COMPLEX\n* The eigenvalue of smaller modulus.\n*\n* EVSCAL (output) COMPLEX\n* The complex value by which the eigenvector matrix was scaled\n* to make it orthonormal. If EVSCAL is zero, the eigenvectors\n* were not computed. This means one of two things: the 2-by-2\n* matrix could not be diagonalized, or the norm of the matrix\n* of eigenvectors before scaling was larger than the threshold\n* value THRESH (set below).\n*\n* CS1 (output) COMPLEX\n* SN1 (output) COMPLEX\n* If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector\n* for RT1.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a.r = (real)NUM2DBL(rb_funcall(rb_a, rb_intern("real"), 0));
- a.i = (real)NUM2DBL(rb_funcall(rb_a, rb_intern("imag"), 0));
- b.r = (real)NUM2DBL(rb_funcall(rb_b, rb_intern("real"), 0));
- b.i = (real)NUM2DBL(rb_funcall(rb_b, rb_intern("imag"), 0));
- c.r = (real)NUM2DBL(rb_funcall(rb_c, rb_intern("real"), 0));
- c.i = (real)NUM2DBL(rb_funcall(rb_c, rb_intern("imag"), 0));
-
- claesy_(&a, &b, &c, &rt1, &rt2, &evscal, &cs1, &sn1);
-
- rb_rt1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt1.r)), rb_float_new((double)(rt1.i)));
- rb_rt2 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt2.r)), rb_float_new((double)(rt2.i)));
- rb_evscal = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(evscal.r)), rb_float_new((double)(evscal.i)));
- rb_cs1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(cs1.r)), rb_float_new((double)(cs1.i)));
- rb_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
- return rb_ary_new3(5, rb_rt1, rb_rt2, rb_evscal, rb_cs1, rb_sn1);
-}
-
-void
-init_lapack_claesy(VALUE mLapack){
- rb_define_module_function(mLapack, "claesy", rb_claesy, -1);
-}
diff --git a/claev2.c b/claev2.c
deleted file mode 100644
index 5fef072..0000000
--- a/claev2.c
+++ /dev/null
@@ -1,52 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claev2_(complex *a, complex *b, complex *c, real *rt1, real *rt2, real *cs1, complex *sn1);
-
-static VALUE
-rb_claev2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex a;
- VALUE rb_b;
- complex b;
- VALUE rb_c;
- complex c;
- VALUE rb_rt1;
- real rt1;
- VALUE rb_rt2;
- real rt2;
- VALUE rb_cs1;
- real cs1;
- VALUE rb_sn1;
- complex sn1;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.claev2( a, b, c)\n or\n NumRu::Lapack.claev2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n* [ A B ]\n* [ CONJG(B) C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) COMPLEX\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) COMPLEX\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) REAL\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) REAL\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) REAL\n* SN1 (output) COMPLEX\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a.r = (real)NUM2DBL(rb_funcall(rb_a, rb_intern("real"), 0));
- a.i = (real)NUM2DBL(rb_funcall(rb_a, rb_intern("imag"), 0));
- b.r = (real)NUM2DBL(rb_funcall(rb_b, rb_intern("real"), 0));
- b.i = (real)NUM2DBL(rb_funcall(rb_b, rb_intern("imag"), 0));
- c.r = (real)NUM2DBL(rb_funcall(rb_c, rb_intern("real"), 0));
- c.i = (real)NUM2DBL(rb_funcall(rb_c, rb_intern("imag"), 0));
-
- claev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
-
- rb_rt1 = rb_float_new((double)rt1);
- rb_rt2 = rb_float_new((double)rt2);
- rb_cs1 = rb_float_new((double)cs1);
- rb_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
- return rb_ary_new3(4, rb_rt1, rb_rt2, rb_cs1, rb_sn1);
-}
-
-void
-init_lapack_claev2(VALUE mLapack){
- rb_define_module_function(mLapack, "claev2", rb_claev2, -1);
-}
diff --git a/clag2z.c b/clag2z.c
deleted file mode 100644
index 10fcadf..0000000
--- a/clag2z.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clag2z_(integer *m, integer *n, complex *sa, integer *ldsa, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_clag2z(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_sa;
- complex *sa;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
-
- integer ldsa;
- integer n;
- integer lda;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.clag2z( m, sa)\n or\n NumRu::Lapack.clag2z # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A.\n*\n* Note that while it is possible to overflow while converting\n* from double to single, it is not possible to overflow when\n* converting from single to double.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* SA (input) COMPLEX array, dimension (LDSA,N)\n* On entry, the M-by-N coefficient matrix SA.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* A (output) COMPLEX*16 array, dimension (LDA,N)\n* On exit, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_sa = argv[1];
-
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_sa))
- rb_raise(rb_eArgError, "sa (2th argument) must be NArray");
- if (NA_RANK(rb_sa) != 2)
- rb_raise(rb_eArgError, "rank of sa (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_sa);
- ldsa = NA_SHAPE0(rb_sa);
- if (NA_TYPE(rb_sa) != NA_SCOMPLEX)
- rb_sa = na_change_type(rb_sa, NA_SCOMPLEX);
- sa = NA_PTR_TYPE(rb_sa, complex*);
- lda = MAX(1,m);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
-
- clag2z_(&m, &n, sa, &ldsa, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_clag2z(VALUE mLapack){
- rb_define_module_function(mLapack, "clag2z", rb_clag2z, -1);
-}
diff --git a/clags2.c b/clags2.c
deleted file mode 100644
index c47e116..0000000
--- a/clags2.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clags2_(logical *upper, real *a1, complex *a2, real *a3, real *b1, complex *b2, real *b3, real *csu, complex *snu, real *csv, complex *snv, real *csq, complex *snq);
-
-static VALUE
-rb_clags2(int argc, VALUE *argv, VALUE self){
- VALUE rb_upper;
- logical upper;
- VALUE rb_a1;
- real a1;
- VALUE rb_a2;
- complex a2;
- VALUE rb_a3;
- real a3;
- VALUE rb_b1;
- real b1;
- VALUE rb_b2;
- complex b2;
- VALUE rb_b3;
- real b3;
- VALUE rb_csu;
- real csu;
- VALUE rb_snu;
- complex snu;
- VALUE rb_csv;
- real csv;
- VALUE rb_snv;
- complex snv;
- VALUE rb_csq;
- real csq;
- VALUE rb_snq;
- complex snq;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.clags2( upper, a1, a2, a3, b1, b2, b3)\n or\n NumRu::Lapack.clags2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n* where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ),\n* ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV )\n*\n* Q = ( CSQ SNQ )\n* ( -CONJG(SNQ) CSQ )\n*\n* Z' denotes the conjugate transpose of Z.\n*\n* The rows of the transformed A and B are parallel. Moreover, if the\n* input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n* of A is not zero. If the input matrices A and B are both not zero,\n* then the transformed (2,2) element of B is not zero, except when the\n* first rows of input A and B are parallel and the second rows are\n* zero.\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) REAL\n* A2 (input) COMPLEX\n* A3 (input) REAL\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) REAL\n* B2 (input) COMPLEX\n* B3 (input) REAL\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) REAL\n* SNU (output) COMPLEX\n* The desired unitary matrix U.\n*\n* CSV (output) REAL\n* SNV (output) COMPLEX\n* The desired unitary matrix V.\n*\n* CSQ (output) REAL\n* SNQ (output) COMPLEX\n* The desired unitary matrix Q.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_upper = argv[0];
- rb_a1 = argv[1];
- rb_a2 = argv[2];
- rb_a3 = argv[3];
- rb_b1 = argv[4];
- rb_b2 = argv[5];
- rb_b3 = argv[6];
-
- b1 = (real)NUM2DBL(rb_b1);
- upper = (rb_upper == Qtrue);
- b2.r = (real)NUM2DBL(rb_funcall(rb_b2, rb_intern("real"), 0));
- b2.i = (real)NUM2DBL(rb_funcall(rb_b2, rb_intern("imag"), 0));
- a1 = (real)NUM2DBL(rb_a1);
- b3 = (real)NUM2DBL(rb_b3);
- a2.r = (real)NUM2DBL(rb_funcall(rb_a2, rb_intern("real"), 0));
- a2.i = (real)NUM2DBL(rb_funcall(rb_a2, rb_intern("imag"), 0));
- a3 = (real)NUM2DBL(rb_a3);
-
- clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
-
- rb_csu = rb_float_new((double)csu);
- rb_snu = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snu.r)), rb_float_new((double)(snu.i)));
- rb_csv = rb_float_new((double)csv);
- rb_snv = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snv.r)), rb_float_new((double)(snv.i)));
- rb_csq = rb_float_new((double)csq);
- rb_snq = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snq.r)), rb_float_new((double)(snq.i)));
- return rb_ary_new3(6, rb_csu, rb_snu, rb_csv, rb_snv, rb_csq, rb_snq);
-}
-
-void
-init_lapack_clags2(VALUE mLapack){
- rb_define_module_function(mLapack, "clags2", rb_clags2, -1);
-}
diff --git a/clagtm.c b/clagtm.c
deleted file mode 100644
index 88f8a87..0000000
--- a/clagtm.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clagtm_(char *trans, integer *n, integer *nrhs, real *alpha, complex *dl, complex *d, complex *du, complex *x, integer *ldx, real *beta, complex *b, integer *ldb);
-
-static VALUE
-rb_clagtm(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb_x;
- complex *x;
- VALUE rb_beta;
- real beta;
- VALUE rb_b;
- complex *b;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldx;
- integer nrhs;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.clagtm( trans, alpha, dl, d, du, x, beta, b)\n or\n NumRu::Lapack.clagtm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* CLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A**T * X + beta * B\n* = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B\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 X and B.\n*\n* ALPHA (input) REAL\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) COMPLEX array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) COMPLEX array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) COMPLEX array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) REAL\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_alpha = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_x = argv[5];
- rb_beta = argv[6];
- rb_b = argv[7];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- beta = (real)NUM2DBL(rb_beta);
- alpha = (real)NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- clagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_clagtm(VALUE mLapack){
- rb_define_module_function(mLapack, "clagtm", rb_clagtm, -1);
-}
diff --git a/clahef.c b/clahef.c
deleted file mode 100644
index da10f57..0000000
--- a/clahef.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clahef_(char *uplo, integer *n, integer *nb, integer *kb, complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw, integer *info);
-
-static VALUE
-rb_clahef(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- complex *a;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *w;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.clahef( uplo, nb, a)\n or\n NumRu::Lapack.clahef # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* CLAHEF computes a partial factorization of a complex Hermitian\n* matrix A using the Bunch-Kaufman diagonal pivoting method. The\n* partial factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the conjugate transpose of U.\n*\n* CLAHEF is an auxiliary routine called by CHETRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- w = ALLOC_N(complex, (ldw)*(MAX(n,nb)));
-
- clahef_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
-
- free(w);
- rb_kb = INT2NUM(kb);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_kb, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_clahef(VALUE mLapack){
- rb_define_module_function(mLapack, "clahef", rb_clahef, -1);
-}
diff --git a/clahqr.c b/clahqr.c
deleted file mode 100644
index 5817916..0000000
--- a/clahqr.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clahqr_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, complex *h, integer *ldh, complex *w, integer *iloz, integer *ihiz, complex *z, integer *ldz, integer *info);
-
-static VALUE
-rb_clahqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- complex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- complex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_w;
- complex *w;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, info, h, z = NumRu::Lapack.clahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz)\n or\n NumRu::Lapack.clahqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* CLAHQR is an auxiliary routine called by CHSEQR to update the\n* eigenvalues and Schur decomposition already computed by CHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows and\n* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n* CLAHQR works primarily with the Hessenberg submatrix in rows\n* and columns ILO to IHI, but applies transformations to all of\n* H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., then H\n* is upper triangular in rows and columns ILO:IHI. If INFO\n* is zero and if WANTT is .FALSE., then the contents of H\n* are unspecified on exit. The output state of H in case\n* INF is positive is below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues ILO to IHI are stored in the\n* corresponding elements of W. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with W(i) = H(i,i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by CHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, CLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of W contain\n* those eigenvalues which have been successfully\n* computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix\n* rows and columns ILO thorugh INFO of the final,\n* output value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of CLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_iloz = argv[5];
- rb_ihiz = argv[6];
- rb_z = argv[7];
- rb_ldz = argv[8];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- ldz = NUM2INT(rb_ldz);
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? n : 0;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- clahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_clahqr(VALUE mLapack){
- rb_define_module_function(mLapack, "clahqr", rb_clahqr, -1);
-}
diff --git a/clahr2.c b/clahr2.c
deleted file mode 100644
index f14bee1..0000000
--- a/clahr2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clahr2_(integer *n, integer *k, integer *nb, complex *a, integer *lda, complex *tau, complex *t, integer *ldt, complex *y, integer *ldy);
-
-static VALUE
-rb_clahr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_t;
- complex *t;
- VALUE rb_y;
- complex *y;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.clahr2( n, k, nb, a)\n or\n NumRu::Lapack.clahr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by CGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ldt = nb;
- ldy = n;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, complex*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_clahr2(VALUE mLapack){
- rb_define_module_function(mLapack, "clahr2", rb_clahr2, -1);
-}
diff --git a/clahrd.c b/clahrd.c
deleted file mode 100644
index d517125..0000000
--- a/clahrd.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clahrd_(integer *n, integer *k, integer *nb, complex *a, integer *lda, complex *tau, complex *t, integer *ldt, complex *y, integer *ldy);
-
-static VALUE
-rb_clahrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_t;
- complex *t;
- VALUE rb_y;
- complex *y;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.clahrd( n, k, nb, a)\n or\n NumRu::Lapack.clahrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by a unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine CLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ldt = nb;
- ldy = MAX(1,n);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, complex*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_clahrd(VALUE mLapack){
- rb_define_module_function(mLapack, "clahrd", rb_clahrd, -1);
-}
diff --git a/claic1.c b/claic1.c
deleted file mode 100644
index d6a9db7..0000000
--- a/claic1.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claic1_(integer *job, integer *j, complex *x, real *sest, complex *w, complex *gamma, real *sestpr, complex *s, complex *c);
-
-static VALUE
-rb_claic1(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- integer job;
- VALUE rb_x;
- complex *x;
- VALUE rb_sest;
- real sest;
- VALUE rb_w;
- complex *w;
- VALUE rb_gamma;
- complex gamma;
- VALUE rb_sestpr;
- real sestpr;
- VALUE rb_s;
- complex s;
- VALUE rb_c;
- complex c;
-
- integer j;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.claic1( job, x, sest, w, gamma)\n or\n NumRu::Lapack.claic1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* CLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then CLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]\n* [ conjg(gamma) ]\n*\n* where alpha = conjg(x)'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) COMPLEX array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) REAL\n* Estimated singular value of j by j matrix L\n*\n* W (input) COMPLEX array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) COMPLEX\n* The diagonal element gamma.\n*\n* SESTPR (output) REAL\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) COMPLEX\n* Sine needed in forming xhat.\n*\n* C (output) COMPLEX\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_job = argv[0];
- rb_x = argv[1];
- rb_sest = argv[2];
- rb_w = argv[3];
- rb_gamma = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (4th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
- j = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SCOMPLEX)
- rb_w = na_change_type(rb_w, NA_SCOMPLEX);
- w = NA_PTR_TYPE(rb_w, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != j)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- gamma.r = (real)NUM2DBL(rb_funcall(rb_gamma, rb_intern("real"), 0));
- gamma.i = (real)NUM2DBL(rb_funcall(rb_gamma, rb_intern("imag"), 0));
- job = NUM2INT(rb_job);
- sest = (real)NUM2DBL(rb_sest);
-
- claic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
-
- rb_sestpr = rb_float_new((double)sestpr);
- rb_s = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(s.r)), rb_float_new((double)(s.i)));
- rb_c = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(c.r)), rb_float_new((double)(c.i)));
- return rb_ary_new3(3, rb_sestpr, rb_s, rb_c);
-}
-
-void
-init_lapack_claic1(VALUE mLapack){
- rb_define_module_function(mLapack, "claic1", rb_claic1, -1);
-}
diff --git a/clals0.c b/clals0.c
deleted file mode 100644
index c8ab505..0000000
--- a/clals0.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, complex *b, integer *ldb, complex *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *difl, real *difr, real *z, integer *k, real *c, real *s, real *rwork, integer *info);
-
-static VALUE
-rb_clals0(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_b;
- complex *b;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_poles;
- real *poles;
- VALUE rb_difl;
- real *difl;
- VALUE rb_difr;
- real *difr;
- VALUE rb_z;
- real *z;
- VALUE rb_c;
- real c;
- VALUE rb_s;
- real s;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *bx;
- real *rwork;
-
- integer ldb;
- integer nrhs;
- integer n;
- integer ldgcol;
- integer ldgnum;
- integer k;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.clals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s)\n or\n NumRu::Lapack.clals0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) COMPLEX array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) REAL array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) REAL array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) REAL array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) REAL array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* RWORK (workspace) REAL array, dimension\n* ( K*(1+NRHS) + 2*NRHS )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_b = argv[4];
- rb_perm = argv[5];
- rb_givptr = argv[6];
- rb_givcol = argv[7];
- rb_givnum = argv[8];
- rb_poles = argv[9];
- rb_difl = argv[10];
- rb_difr = argv[11];
- rb_z = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
- if (NA_RANK(rb_difl) != 1)
- rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
- k = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_SFLOAT)
- rb_difl = na_change_type(rb_difl, NA_SFLOAT);
- difl = NA_PTR_TYPE(rb_difl, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- c = (real)NUM2DBL(rb_c);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
- ldgcol = NA_SHAPE0(rb_givcol);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (13th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- nr = NUM2INT(rb_nr);
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
- ldgnum = NA_SHAPE0(rb_poles);
- if (NA_TYPE(rb_poles) != NA_SFLOAT)
- rb_poles = na_change_type(rb_poles, NA_SFLOAT);
- poles = NA_PTR_TYPE(rb_poles, real*);
- icompq = NUM2INT(rb_icompq);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
- if (NA_SHAPE0(rb_givnum) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of poles");
- if (NA_TYPE(rb_givnum) != NA_SFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_SFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- s = (real)NUM2DBL(rb_s);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
- if (NA_SHAPE0(rb_difr) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of poles");
- if (NA_TYPE(rb_difr) != NA_SFLOAT)
- rb_difr = na_change_type(rb_difr, NA_SFLOAT);
- difr = NA_PTR_TYPE(rb_difr, real*);
- givptr = NUM2INT(rb_givptr);
- ldbx = n;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- bx = ALLOC_N(complex, (ldbx)*(nrhs));
- rwork = ALLOC_N(real, (k*(1+nrhs) + 2*nrhs));
-
- clals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, rwork, &info);
-
- free(bx);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_clals0(VALUE mLapack){
- rb_define_module_function(mLapack, "clals0", rb_clals0, -1);
-}
diff --git a/clalsa.c b/clalsa.c
deleted file mode 100644
index 521edc8..0000000
--- a/clalsa.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clalsa_(integer *icompq, integer *smlsiz, integer *n, integer *nrhs, complex *b, integer *ldb, complex *bx, integer *ldbx, real *u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real *z, real *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum, real *c, real *s, real *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_clalsa(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_b;
- complex *b;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_k;
- integer *k;
- VALUE rb_difl;
- real *difl;
- VALUE rb_difr;
- real *difr;
- VALUE rb_z;
- real *z;
- VALUE rb_poles;
- real *poles;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- real *s;
- VALUE rb_bx;
- complex *bx;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
- real *rwork;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldu;
- integer smlsiz;
- integer n;
- integer nlvl;
- integer ldgcol;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.clalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s)\n or\n NumRu::Lapack.clalsa # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, CLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, CLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by CLALSA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) COMPLEX array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) REAL array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) REAL array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) REAL array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* RWORK (workspace) REAL array, dimension at least\n* MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_b = argv[1];
- rb_u = argv[2];
- rb_vt = argv[3];
- rb_k = argv[4];
- rb_difl = argv[5];
- rb_difr = argv[6];
- rb_z = argv[7];
- rb_poles = argv[8];
- rb_givptr = argv[9];
- rb_givcol = argv[10];
- rb_perm = argv[11];
- rb_givnum = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (5th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
- if (NA_RANK(rb_difl) != 2)
- rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
- nlvl = NA_SHAPE1(rb_difl);
- if (nlvl != ((int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1))
- rb_raise(rb_eRuntimeError, "shape 1 of difl must be %d", (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
- ldu = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_SFLOAT)
- rb_difl = na_change_type(rb_difl, NA_SFLOAT);
- difl = NA_PTR_TYPE(rb_difl, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (14th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (3th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
- smlsiz = NA_SHAPE1(rb_u);
- if (NA_SHAPE0(rb_u) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of u must be the same as shape 0 of difl");
- if (NA_TYPE(rb_u) != NA_SFLOAT)
- rb_u = na_change_type(rb_u, NA_SFLOAT);
- u = NA_PTR_TYPE(rb_u, real*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of difl");
- if (NA_SHAPE0(rb_z) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (15th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
- if (NA_RANK(rb_perm) != 2)
- rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_perm) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of perm must be the same as shape 1 of difl");
- ldgcol = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- ldbx = n;
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_poles) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of difl");
- if (NA_TYPE(rb_poles) != NA_SFLOAT)
- rb_poles = na_change_type(rb_poles, NA_SFLOAT);
- poles = NA_PTR_TYPE(rb_poles, real*);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_difr) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of difl");
- if (NA_TYPE(rb_difr) != NA_SFLOAT)
- rb_difr = na_change_type(rb_difr, NA_SFLOAT);
- difr = NA_PTR_TYPE(rb_difr, real*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vt) != (smlsiz+1))
- rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
- if (NA_SHAPE0(rb_vt) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of difl");
- if (NA_TYPE(rb_vt) != NA_SFLOAT)
- rb_vt = na_change_type(rb_vt, NA_SFLOAT);
- vt = NA_PTR_TYPE(rb_vt, real*);
- nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givnum) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of difl");
- if (NA_TYPE(rb_givnum) != NA_SFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_SFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givcol) != ldgcol)
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldbx;
- shape[1] = nrhs;
- rb_bx = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- bx = NA_PTR_TYPE(rb_bx, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(real, (MAX(n,(smlsiz+1)*nrhs*3)));
- iwork = ALLOC_N(integer, (3 * n));
-
- clalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, rwork, iwork, &info);
-
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_bx, rb_info, rb_b);
-}
-
-void
-init_lapack_clalsa(VALUE mLapack){
- rb_define_module_function(mLapack, "clalsa", rb_clalsa, -1);
-}
diff --git a/clalsd.c b/clalsd.c
deleted file mode 100644
index aeed667..0000000
--- a/clalsd.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, real *d, real *e, complex *b, integer *ldb, real *rcond, integer *rank, complex *work, real *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_clalsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_b;
- complex *b;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- integer nlvl;
- complex *work;
- real *rwork;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.clalsd( uplo, smlsiz, d, e, b, rcond)\n or\n NumRu::Lapack.clalsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) REAL array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) REAL\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) COMPLEX array, dimension (N * NRHS).\n*\n* RWORK (workspace) REAL array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n* where\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*\n* IWORK (workspace) INTEGER array, dimension (3*N*NLVL + 11*N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_smlsiz = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_b = argv[4];
- rb_rcond = argv[5];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- smlsiz = NUM2INT(rb_smlsiz);
- uplo = StringValueCStr(rb_uplo)[0];
- nlvl = ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1;
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (n * nrhs));
- rwork = ALLOC_N(real, (9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)));
- iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
-
- clalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, rwork, iwork, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_clalsd(VALUE mLapack){
- rb_define_module_function(mLapack, "clalsd", rb_clalsd, -1);
-}
diff --git a/clangb.c b/clangb.c
deleted file mode 100644
index 6bae2e0..0000000
--- a/clangb.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clangb_(char *norm, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, real *work);
-
-static VALUE
-rb_clangb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clangb( norm, kl, ku, ab)\n or\n NumRu::Lapack.clangb # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* CLANGB returns the value\n*\n* CLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- work = ALLOC_N(real, (MAX(1,lsame_(&norm,"I") ? n : 0)));
-
- __out__ = clangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clangb(VALUE mLapack){
- rb_define_module_function(mLapack, "clangb", rb_clangb, -1);
-}
diff --git a/clange.c b/clange.c
deleted file mode 100644
index 5e877ca..0000000
--- a/clange.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clange_(char *norm, integer *m, integer *n, complex *a, integer *lda, real *work);
-
-static VALUE
-rb_clange(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clange( norm, m, a)\n or\n NumRu::Lapack.clange # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex matrix A.\n*\n* Description\n* ===========\n*\n* CLANGE returns the value\n*\n* CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* CLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* CLANGE is set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = clange_(&norm, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clange(VALUE mLapack){
- rb_define_module_function(mLapack, "clange", rb_clange, -1);
-}
diff --git a/clangt.c b/clangt.c
deleted file mode 100644
index 859bc00..0000000
--- a/clangt.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clangt_(char *norm, integer *n, complex *dl, complex *d, complex *du);
-
-static VALUE
-rb_clangt(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- complex *dl;
- VALUE rb_d;
- complex *d;
- VALUE rb_du;
- complex *du;
- VALUE rb___out__;
- real __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clangt( norm, dl, d, du)\n or\n NumRu::Lapack.clangt # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* CLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* CLANGT returns the value\n*\n* CLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANGT is\n* set to zero.\n*\n* DL (input) COMPLEX array, dimension (N-1)\n* The (n-1) sub-diagonal elements of A.\n*\n* D (input) COMPLEX array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SCOMPLEX)
- rb_du = na_change_type(rb_du, NA_SCOMPLEX);
- du = NA_PTR_TYPE(rb_du, complex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_SCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, complex*);
-
- __out__ = clangt_(&norm, &n, dl, d, du);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clangt(VALUE mLapack){
- rb_define_module_function(mLapack, "clangt", rb_clangt, -1);
-}
diff --git a/clanhb.c b/clanhb.c
deleted file mode 100644
index ec39263..0000000
--- a/clanhb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clanhb_(char *norm, char *uplo, integer *n, integer *k, complex *ab, integer *ldab, real *work);
-
-static VALUE
-rb_clanhb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- complex *ab;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhb( norm, uplo, k, ab)\n or\n NumRu::Lapack.clanhb # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANHB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n hermitian band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* CLANHB returns the value\n*\n* CLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the hermitian band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_k = argv[2];
- rb_ab = argv[3];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = clanhb_(&norm, &uplo, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clanhb(VALUE mLapack){
- rb_define_module_function(mLapack, "clanhb", rb_clanhb, -1);
-}
diff --git a/clanhe.c b/clanhe.c
deleted file mode 100644
index 2ad630b..0000000
--- a/clanhe.c
+++ /dev/null
@@ -1,53 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clanhe_(char *norm, char *uplo, integer *n, complex *a, integer *lda, real *work);
-
-static VALUE
-rb_clanhe(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhe( norm, uplo, a)\n or\n NumRu::Lapack.clanhe # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANHE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A.\n*\n* Description\n* ===========\n*\n* CLANHE returns the value\n*\n* CLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHE as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHE is\n* set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The hermitian matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced. Note that the imaginary parts of the diagonal\n* elements need not be set and are assumed to be zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));
-
- __out__ = clanhe_(&norm, &uplo, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clanhe(VALUE mLapack){
- rb_define_module_function(mLapack, "clanhe", rb_clanhe, -1);
-}
diff --git a/clanhf.c b/clanhf.c
deleted file mode 100644
index c93468e..0000000
--- a/clanhf.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clanhf_(char *norm, char *transr, char *uplo, integer *n, doublecomplex *a, real *work);
-
-static VALUE
-rb_clanhf(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhf( norm, transr, uplo, n, a)\n or\n NumRu::Lapack.clanhf # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* CLANHF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* CLANHF returns the value\n*\n* CLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER\n* Specifies the value to be returned in CLANHF as described\n* above.\n*\n* TRANSR (input) CHARACTER\n* Specifies whether the RFP format of A is normal or\n* conjugate-transposed format.\n* = 'N': RFP format is Normal\n* = 'C': RFP format is Conjugate-transposed\n*\n* UPLO (input) CHARACTER\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n*\n* UPLO = 'U' or 'u' RFP A came from an upper triangular\n* matrix\n*\n* UPLO = 'L' or 'l' RFP A came from a lower triangular\n* matrix\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHF is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n* as defined when TRANSR = 'N'. The contents of RFP A are\n* defined by UPLO as follows: If UPLO = 'U' the RFP A\n* contains the ( N*(N+1)/2 ) elements of upper packed A\n* either in normal or conjugate-transpose Format. If\n* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n* of lower packed A either in normal or conjugate-transpose\n* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n* TRANSR is 'N' the LDA is N+1 when N is even and is N when\n* is odd. See the Note below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) REAL array, dimension (LWORK),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_transr = argv[1];
- rb_uplo = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- work = ALLOC_N(real, (lwork));
-
- __out__ = clanhf_(&norm, &transr, &uplo, &n, a, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clanhf(VALUE mLapack){
- rb_define_module_function(mLapack, "clanhf", rb_clanhf, -1);
-}
diff --git a/clanhp.c b/clanhp.c
deleted file mode 100644
index d83d9dd..0000000
--- a/clanhp.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clanhp_(char *norm, char *uplo, integer *n, complex *ap, real *work);
-
-static VALUE
-rb_clanhp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb___out__;
- real __out__;
- real *work;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhp( norm, uplo, n, ap)\n or\n NumRu::Lapack.clanhp # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* CLANHP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* CLANHP returns the value\n*\n* CLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHP is\n* set to zero.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"O")) ? n : 0)));
-
- __out__ = clanhp_(&norm, &uplo, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clanhp(VALUE mLapack){
- rb_define_module_function(mLapack, "clanhp", rb_clanhp, -1);
-}
diff --git a/clanhs.c b/clanhs.c
deleted file mode 100644
index b60361e..0000000
--- a/clanhs.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clanhs_(char *norm, integer *n, complex *a, integer *lda, real *work);
-
-static VALUE
-rb_clanhs(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- complex *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhs( norm, a)\n or\n NumRu::Lapack.clanhs # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* CLANHS returns the value\n*\n* CLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHS is\n* set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = clanhs_(&norm, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clanhs(VALUE mLapack){
- rb_define_module_function(mLapack, "clanhs", rb_clanhs, -1);
-}
diff --git a/clanht.c b/clanht.c
deleted file mode 100644
index 32fd19e..0000000
--- a/clanht.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clanht_(char *norm, integer *n, real *d, complex *e);
-
-static VALUE
-rb_clanht(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb___out__;
- real __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanht( norm, d, e)\n or\n NumRu::Lapack.clanht # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHT( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* CLANHT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* CLANHT returns the value\n*\n* CLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHT is\n* set to zero.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
-
- __out__ = clanht_(&norm, &n, d, e);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clanht(VALUE mLapack){
- rb_define_module_function(mLapack, "clanht", rb_clanht, -1);
-}
diff --git a/clansb.c b/clansb.c
deleted file mode 100644
index 8c201e1..0000000
--- a/clansb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clansb_(char *norm, char *uplo, integer *n, integer *k, complex *ab, integer *ldab, real *work);
-
-static VALUE
-rb_clansb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- complex *ab;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clansb( norm, uplo, k, ab)\n or\n NumRu::Lapack.clansb # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* CLANSB returns the value\n*\n* CLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_k = argv[2];
- rb_ab = argv[3];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = clansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clansb(VALUE mLapack){
- rb_define_module_function(mLapack, "clansb", rb_clansb, -1);
-}
diff --git a/clansp.c b/clansp.c
deleted file mode 100644
index 397995e..0000000
--- a/clansp.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clansp_(char *norm, char *uplo, integer *n, complex *ap, real *work);
-
-static VALUE
-rb_clansp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb___out__;
- real __out__;
- real *work;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clansp( norm, uplo, n, ap)\n or\n NumRu::Lapack.clansp # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* CLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* CLANSP returns the value\n*\n* CLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANSP is\n* set to zero.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"O")) ? n : 0)));
-
- __out__ = clansp_(&norm, &uplo, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clansp(VALUE mLapack){
- rb_define_module_function(mLapack, "clansp", rb_clansp, -1);
-}
diff --git a/clansy.c b/clansy.c
deleted file mode 100644
index 8c3d8bf..0000000
--- a/clansy.c
+++ /dev/null
@@ -1,53 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clansy_(char *norm, char *uplo, integer *n, complex *a, integer *lda, real *work);
-
-static VALUE
-rb_clansy(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clansy( norm, uplo, a)\n or\n NumRu::Lapack.clansy # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A.\n*\n* Description\n* ===========\n*\n* CLANSY returns the value\n*\n* CLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANSY is\n* set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));
-
- __out__ = clansy_(&norm, &uplo, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clansy(VALUE mLapack){
- rb_define_module_function(mLapack, "clansy", rb_clansy, -1);
-}
diff --git a/clantb.c b/clantb.c
deleted file mode 100644
index 671a0cc..0000000
--- a/clantb.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, complex *ab, integer *ldab, real *work);
-
-static VALUE
-rb_clantb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- complex *ab;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clantb( norm, uplo, diag, k, ab)\n or\n NumRu::Lapack.clantb # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* CLANTB returns the value\n*\n* CLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_k = argv[3];
- rb_ab = argv[4];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (MAX(1,lsame_(&norm,"I") ? n : 0)));
-
- __out__ = clantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clantb(VALUE mLapack){
- rb_define_module_function(mLapack, "clantb", rb_clantb, -1);
-}
diff --git a/clantp.c b/clantp.c
deleted file mode 100644
index 8b47514..0000000
--- a/clantp.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clantp_(char *norm, char *uplo, char *diag, integer *n, complex *ap, real *work);
-
-static VALUE
-rb_clantp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clantp( norm, uplo, diag, n, ap)\n or\n NumRu::Lapack.clantp # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* CLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* CLANTP returns the value\n*\n* CLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANTP is\n* set to zero.\n*\n* AP (input) COMPLEX 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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = clantp_(&norm, &uplo, &diag, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clantp(VALUE mLapack){
- rb_define_module_function(mLapack, "clantp", rb_clantp, -1);
-}
diff --git a/clantr.c b/clantr.c
deleted file mode 100644
index 211772f..0000000
--- a/clantr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern real clantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, complex *a, integer *lda, real *work);
-
-static VALUE
-rb_clantr(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clantr( norm, uplo, diag, m, a)\n or\n NumRu::Lapack.clantr # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* CLANTR returns the value\n*\n* CLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, CLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, CLANTR is set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_m = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = clantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_clantr(VALUE mLapack){
- rb_define_module_function(mLapack, "clantr", rb_clantr, -1);
-}
diff --git a/clapll.c b/clapll.c
deleted file mode 100644
index 70e9704..0000000
--- a/clapll.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clapll_(integer *n, complex *x, integer *incx, complex *y, integer *incy, real *ssmin);
-
-static VALUE
-rb_clapll(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- complex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_ssmin;
- real ssmin;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_y_out__;
- complex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.clapll( n, x, incx, y, incy)\n or\n NumRu::Lapack.clapll # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) REAL\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
-
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- clapll_(&n, x, &incx, y, &incy, &ssmin);
-
- rb_ssmin = rb_float_new((double)ssmin);
- return rb_ary_new3(3, rb_ssmin, rb_x, rb_y);
-}
-
-void
-init_lapack_clapll(VALUE mLapack){
- rb_define_module_function(mLapack, "clapll", rb_clapll, -1);
-}
diff --git a/clapmr.c b/clapmr.c
deleted file mode 100644
index 90e3ec7..0000000
--- a/clapmr.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clapmr_(logical *forwrd, integer *m, integer *n, complex *x, integer *ldx, integer *k);
-
-static VALUE
-rb_clapmr(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_x;
- complex *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.clapmr( forwrd, x, k)\n or\n NumRu::Lapack.clapmr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* CLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n COMPLEX TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_forwrd = argv[0];
- rb_x = argv[1];
- rb_k = argv[2];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (3th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- clapmr_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_clapmr(VALUE mLapack){
- rb_define_module_function(mLapack, "clapmr", rb_clapmr, -1);
-}
diff --git a/clapmt.c b/clapmt.c
deleted file mode 100644
index 0044ad9..0000000
--- a/clapmt.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clapmt_(logical *forwrd, integer *m, integer *n, complex *x, integer *ldx, integer *k);
-
-static VALUE
-rb_clapmt(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_m;
- integer m;
- VALUE rb_x;
- complex *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.clapmt( forwrd, m, x, k)\n or\n NumRu::Lapack.clapmt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* CLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, J, IN\n COMPLEX TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_forwrd = argv[0];
- rb_m = argv[1];
- rb_x = argv[2];
- rb_k = argv[3];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (4th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 0 of k");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- m = NUM2INT(rb_m);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- clapmt_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_clapmt(VALUE mLapack){
- rb_define_module_function(mLapack, "clapmt", rb_clapmt, -1);
-}
diff --git a/claqgb.c b/claqgb.c
deleted file mode 100644
index 6723b5e..0000000
--- a/claqgb.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqgb_(integer *m, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, real *r, real *c, real *rowcnd, real *colcnd, real *amax, char *equed);
-
-static VALUE
-rb_claqgb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.claqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.claqgb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_r = argv[3];
- rb_c = argv[4];
- rb_rowcnd = argv[5];
- rb_colcnd = argv[6];
- rb_amax = argv[7];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- amax = (real)NUM2DBL(rb_amax);
- colcnd = (real)NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (4th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- rowcnd = (real)NUM2DBL(rb_rowcnd);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- claqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_claqgb(VALUE mLapack){
- rb_define_module_function(mLapack, "claqgb", rb_claqgb, -1);
-}
diff --git a/claqge.c b/claqge.c
deleted file mode 100644
index d9bd80c..0000000
--- a/claqge.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqge_(integer *m, integer *n, complex *a, integer *lda, real *r, real *c, real *rowcnd, real *colcnd, real *amax, char *equed);
-
-static VALUE
-rb_claqge(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.claqge( a, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.claqge # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_a = argv[0];
- rb_r = argv[1];
- rb_c = argv[2];
- rb_rowcnd = argv[3];
- rb_colcnd = argv[4];
- rb_amax = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- amax = (real)NUM2DBL(rb_amax);
- colcnd = (real)NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (2th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- rowcnd = (real)NUM2DBL(rb_rowcnd);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- claqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_claqge(VALUE mLapack){
- rb_define_module_function(mLapack, "claqge", rb_claqge, -1);
-}
diff --git a/claqhb.c b/claqhb.c
deleted file mode 100644
index d13b993..0000000
--- a/claqhb.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqhb_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_claqhb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_s;
- real *s;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, equed, ab = NumRu::Lapack.claqhb( uplo, kd, ab, scond, amax)\n or\n NumRu::Lapack.claqhb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQHB equilibrates an Hermitian band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (output) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = (real)NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kd = NUM2INT(rb_kd);
- amax = (real)NUM2DBL(rb_amax);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- claqhb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(3, rb_s, rb_equed, rb_ab);
-}
-
-void
-init_lapack_claqhb(VALUE mLapack){
- rb_define_module_function(mLapack, "claqhb", rb_claqhb, -1);
-}
diff --git a/claqhe.c b/claqhe.c
deleted file mode 100644
index 403fb1c..0000000
--- a/claqhe.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqhe_(char *uplo, integer *n, complex *a, integer *lda, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_claqhe(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.claqhe( uplo, a, s, scond, amax)\n or\n NumRu::Lapack.claqhe # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQHE equilibrates a Hermitian 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* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = (real)NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- claqhe_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_claqhe(VALUE mLapack){
- rb_define_module_function(mLapack, "claqhe", rb_claqhe, -1);
-}
diff --git a/claqhp.c b/claqhp.c
deleted file mode 100644
index 3214efc..0000000
--- a/claqhp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqhp_(char *uplo, integer *n, complex *ap, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_claqhp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ap = NumRu::Lapack.claqhp( uplo, ap, s, scond, amax)\n or\n NumRu::Lapack.claqhp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQHP equilibrates a Hermitian 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* Hermitian 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = (real)NUM2DBL(rb_scond);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- claqhp_(&uplo, &n, ap, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ap);
-}
-
-void
-init_lapack_claqhp(VALUE mLapack){
- rb_define_module_function(mLapack, "claqhp", rb_claqhp, -1);
-}
diff --git a/claqp2.c b/claqp2.c
deleted file mode 100644
index 08d709a..0000000
--- a/claqp2.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqp2_(integer *m, integer *n, integer *offset, complex *a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2, complex *work);
-
-static VALUE
-rb_claqp2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- complex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- real *vn1;
- VALUE rb_vn2;
- real *vn2;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- real *vn1_out__;
- VALUE rb_vn2_out__;
- real *vn2_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.claqp2( m, offset, a, jpvt, vn1, vn2)\n or\n NumRu::Lapack.claqp2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* CLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n* the triangular factor obtained; the elements in block\n* A(OFFSET+1:M,1:N) below the diagonal, together with the\n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_SFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_SFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, real*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_SFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_SFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, real*);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- offset = NUM2INT(rb_offset);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, real*);
- MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, real*);
- MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- work = ALLOC_N(complex, (n));
-
- claqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
-
- free(work);
- return rb_ary_new3(5, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2);
-}
-
-void
-init_lapack_claqp2(VALUE mLapack){
- rb_define_module_function(mLapack, "claqp2", rb_claqp2, -1);
-}
diff --git a/claqps.c b/claqps.c
deleted file mode 100644
index fb86907..0000000
--- a/claqps.c
+++ /dev/null
@@ -1,189 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqps_(integer *m, integer *n, integer *offset, integer *nb, integer *kb, complex *a, integer *lda, integer *jpvt, complex *tau, real *vn1, real *vn2, complex *auxv, complex *f, integer *ldf);
-
-static VALUE
-rb_claqps(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- complex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- real *vn1;
- VALUE rb_vn2;
- real *vn2;
- VALUE rb_auxv;
- complex *auxv;
- VALUE rb_f;
- complex *f;
- VALUE rb_kb;
- integer kb;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- real *vn1_out__;
- VALUE rb_vn2_out__;
- real *vn2_out__;
- VALUE rb_auxv_out__;
- complex *auxv_out__;
- VALUE rb_f_out__;
- complex *f_out__;
-
- integer lda;
- integer n;
- integer nb;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.claqps( m, offset, a, jpvt, vn1, vn2, auxv, f)\n or\n NumRu::Lapack.claqps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* CLAQPS computes a step of QR factorization with column pivoting\n* of a complex M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) COMPLEX array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) COMPLEX array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) COMPLEX array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
- rb_auxv = argv[6];
- rb_f = argv[7];
-
- if (!NA_IsNArray(rb_auxv))
- rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
- if (NA_RANK(rb_auxv) != 1)
- rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
- nb = NA_SHAPE0(rb_auxv);
- if (NA_TYPE(rb_auxv) != NA_SCOMPLEX)
- rb_auxv = na_change_type(rb_auxv, NA_SCOMPLEX);
- auxv = NA_PTR_TYPE(rb_auxv, complex*);
- offset = NUM2INT(rb_offset);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_SFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_SFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, real*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != nb)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_SCOMPLEX)
- rb_f = na_change_type(rb_f, NA_SCOMPLEX);
- f = NA_PTR_TYPE(rb_f, complex*);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_SFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_SFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, real*);
- kb = nb;
- {
- int shape[1];
- shape[0] = kb;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, real*);
- MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, real*);
- MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- {
- int shape[1];
- shape[0] = nb;
- rb_auxv_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- auxv_out__ = NA_PTR_TYPE(rb_auxv_out__, complex*);
- MEMCPY(auxv_out__, auxv, complex, NA_TOTAL(rb_auxv));
- rb_auxv = rb_auxv_out__;
- auxv = auxv_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = nb;
- rb_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, complex*);
- MEMCPY(f_out__, f, complex, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
-
- claqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
-
- rb_kb = INT2NUM(kb);
- return rb_ary_new3(8, rb_kb, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2, rb_auxv, rb_f);
-}
-
-void
-init_lapack_claqps(VALUE mLapack){
- rb_define_module_function(mLapack, "claqps", rb_claqps, -1);
-}
diff --git a/claqr0.c b/claqr0.c
deleted file mode 100644
index 7bb8b7e..0000000
--- a/claqr0.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, complex *h, integer *ldh, complex *w, integer *iloz, integer *ihiz, complex *z, integer *ldz, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_claqr0(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_h;
- complex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- complex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- complex *w;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ihi;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.claqr0( wantt, wantz, ilo, h, iloz, ihiz, z, lwork)\n or\n NumRu::Lapack.claqr0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to CGEBAL, and then passed to CGEHRD when the\n* matrix output by CGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then CLAQR0 does a workspace query.\n* In this case, CLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, CLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_h = argv[3];
- rb_iloz = argv[4];
- rb_ihiz = argv[5];
- rb_z = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- ihi = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (4th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = ihi;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- claqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_claqr0(VALUE mLapack){
- rb_define_module_function(mLapack, "claqr0", rb_claqr0, -1);
-}
diff --git a/claqr1.c b/claqr1.c
deleted file mode 100644
index 2056cc3..0000000
--- a/claqr1.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqr1_(integer *n, complex *h, integer *ldh, complex *s1, complex *s2, complex *v);
-
-static VALUE
-rb_claqr1(int argc, VALUE *argv, VALUE self){
- VALUE rb_h;
- complex *h;
- VALUE rb_s1;
- complex s1;
- VALUE rb_s2;
- complex s2;
- VALUE rb_v;
- complex *v;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n v = NumRu::Lapack.claqr1( h, s1, s2)\n or\n NumRu::Lapack.claqr1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - s1*I)*(H - s2*I)\n*\n* scaling to avoid overflows and most underflows.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) COMPLEX array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* S1 (input) COMPLEX\n* S2 S1 and S2 are the shifts defining K in (*) above.\n*\n* V (output) COMPLEX array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_h = argv[0];
- rb_s1 = argv[1];
- rb_s2 = argv[2];
-
- s1.r = (real)NUM2DBL(rb_funcall(rb_s1, rb_intern("real"), 0));
- s1.i = (real)NUM2DBL(rb_funcall(rb_s1, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (1th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- s2.r = (real)NUM2DBL(rb_funcall(rb_s2, rb_intern("real"), 0));
- s2.i = (real)NUM2DBL(rb_funcall(rb_s2, rb_intern("imag"), 0));
- {
- int shape[1];
- shape[0] = n;
- rb_v = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, complex*);
-
- claqr1_(&n, h, &ldh, &s1, &s2, v);
-
- return rb_v;
-}
-
-void
-init_lapack_claqr1(VALUE mLapack){
- rb_define_module_function(mLapack, "claqr1", rb_claqr1, -1);
-}
diff --git a/claqr2.c b/claqr2.c
deleted file mode 100644
index 809f878..0000000
--- a/claqr2.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, complex *h, integer *ldh, integer *iloz, integer *ihiz, complex *z, integer *ldz, integer *ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh, complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv, complex *work, integer *lwork);
-
-static VALUE
-rb_claqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- complex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- complex *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_ldt;
- integer ldt;
- VALUE rb_nv;
- integer nv;
- VALUE rb_ldwv;
- integer ldwv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sh;
- complex *sh;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_z_out__;
- complex *z_out__;
- complex *v;
- complex *t;
- complex *wv;
- complex *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.claqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, ldt, nv, ldwv, lwork)\n or\n NumRu::Lapack.claqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to CLAQR3 except that it avoids\n* recursion by calling CLAHQR instead of CLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; CLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_ldt = argv[10];
- rb_nv = argv[11];
- rb_ldwv = argv[12];
- rb_lwork = argv[13];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- lwork = NUM2INT(rb_lwork);
- kbot = NUM2INT(rb_kbot);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- sh = NA_PTR_TYPE(rb_sh, complex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
- wv = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
- work = ALLOC_N(complex, (MAX(1,lwork)));
-
- claqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(5, rb_ns, rb_nd, rb_sh, rb_h, rb_z);
-}
-
-void
-init_lapack_claqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "claqr2", rb_claqr2, -1);
-}
diff --git a/claqr3.c b/claqr3.c
deleted file mode 100644
index 2e00abc..0000000
--- a/claqr3.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqr3_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, complex *h, integer *ldh, integer *iloz, integer *ihiz, complex *z, integer *ldz, integer *ns, integer *nd, complex *sh, complex *v, integer *ldv, integer *nh, complex *t, integer *ldt, integer *nv, complex *wv, integer *ldwv, complex *work, integer *lwork);
-
-static VALUE
-rb_claqr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- complex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- complex *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_ldt;
- integer ldt;
- VALUE rb_nv;
- integer nv;
- VALUE rb_ldwv;
- integer ldwv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sh;
- complex *sh;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_z_out__;
- complex *z_out__;
- complex *v;
- complex *t;
- complex *wv;
- complex *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.claqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, ldt, nv, ldwv, lwork)\n or\n NumRu::Lapack.claqr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; CLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_ldt = argv[10];
- rb_nv = argv[11];
- rb_ldwv = argv[12];
- rb_lwork = argv[13];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- lwork = NUM2INT(rb_lwork);
- kbot = NUM2INT(rb_kbot);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- sh = NA_PTR_TYPE(rb_sh, complex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
- wv = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
- work = ALLOC_N(complex, (MAX(1,lwork)));
-
- claqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(5, rb_ns, rb_nd, rb_sh, rb_h, rb_z);
-}
-
-void
-init_lapack_claqr3(VALUE mLapack){
- rb_define_module_function(mLapack, "claqr3", rb_claqr3, -1);
-}
diff --git a/claqr4.c b/claqr4.c
deleted file mode 100644
index 9d01529..0000000
--- a/claqr4.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqr4_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, complex *h, integer *ldh, complex *w, integer *iloz, integer *ihiz, complex *z, integer *ldz, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_claqr4(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_h;
- complex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- complex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- complex *w;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ihi;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.claqr4( wantt, wantz, ilo, h, iloz, ihiz, z, lwork)\n or\n NumRu::Lapack.claqr4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to CGEBAL, and then passed to CGEHRD when the\n* matrix output by CGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then CLAQR4 does a workspace query.\n* In this case, CLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, CLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_h = argv[3];
- rb_iloz = argv[4];
- rb_ihiz = argv[5];
- rb_z = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- ihi = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (4th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = ihi;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- claqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_claqr4(VALUE mLapack){
- rb_define_module_function(mLapack, "claqr4", rb_claqr4, -1);
-}
diff --git a/claqr5.c b/claqr5.c
deleted file mode 100644
index 431e3ca..0000000
--- a/claqr5.c
+++ /dev/null
@@ -1,160 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqr5_(logical *wantt, logical *wantz, integer *kacc22, integer *n, integer *ktop, integer *kbot, integer *nshfts, complex *s, complex *h, integer *ldh, integer *iloz, integer *ihiz, complex *z, integer *ldz, complex *v, integer *ldv, complex *u, integer *ldu, integer *nv, complex *wv, integer *ldwv, integer *nh, complex *wh, integer *ldwh);
-
-static VALUE
-rb_claqr5(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_kacc22;
- integer kacc22;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_s;
- complex *s;
- VALUE rb_h;
- complex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- complex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_nv;
- integer nv;
- VALUE rb_nh;
- integer nh;
- VALUE rb_s_out__;
- complex *s_out__;
- VALUE rb_h_out__;
- complex *h_out__;
- VALUE rb_z_out__;
- complex *z_out__;
- complex *v;
- complex *u;
- complex *wv;
- complex *wh;
-
- integer nshfts;
- integer ldh;
- integer n;
- integer ldv;
- integer ldu;
- integer ldwv;
- integer ldwh;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, h, z = NumRu::Lapack.claqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh)\n or\n NumRu::Lapack.claqr5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by CLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the unitary Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: CLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: CLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: CLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* S (input/output) COMPLEX array of size (NSHFTS)\n* S contains the shifts of origin that define the multi-\n* shift QR sweep. On output S may be reordered.\n*\n* H (input/output) COMPLEX array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) COMPLEX array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep unitary\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) COMPLEX array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) COMPLEX array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) COMPLEX array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) COMPLEX array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_kacc22 = argv[2];
- rb_ktop = argv[3];
- rb_kbot = argv[4];
- rb_s = argv[5];
- rb_h = argv[6];
- rb_iloz = argv[7];
- rb_ihiz = argv[8];
- rb_z = argv[9];
- rb_ldz = argv[10];
- rb_nv = argv[11];
- rb_nh = argv[12];
-
- kacc22 = NUM2INT(rb_kacc22);
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- kbot = NUM2INT(rb_kbot);
- ldz = NUM2INT(rb_ldz);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- nshfts = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SCOMPLEX)
- rb_s = na_change_type(rb_s, NA_SCOMPLEX);
- s = NA_PTR_TYPE(rb_s, complex*);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (7th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SCOMPLEX)
- rb_h = na_change_type(rb_h, NA_SCOMPLEX);
- h = NA_PTR_TYPE(rb_h, complex*);
- ldv = 3;
- wantt = (rb_wantt == Qtrue);
- nv = NUM2INT(rb_nv);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- ldu = 3*nshfts-3;
- ldwv = nv;
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (10th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? ihiz : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- ldwh = 3*nshfts-3;
- {
- int shape[1];
- shape[0] = nshfts;
- rb_s_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, complex*);
- MEMCPY(s_out__, s, complex, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, complex*);
- MEMCPY(h_out__, h, complex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? ihiz : 0;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(complex, (ldv)*(nshfts/2));
- u = ALLOC_N(complex, (ldu)*(3*nshfts-3));
- wv = ALLOC_N(complex, (ldwv)*(3*nshfts-3));
- wh = ALLOC_N(complex, (ldwh)*(MAX(1,nh)));
-
- claqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, s, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
-
- free(v);
- free(u);
- free(wv);
- free(wh);
- return rb_ary_new3(3, rb_s, rb_h, rb_z);
-}
-
-void
-init_lapack_claqr5(VALUE mLapack){
- rb_define_module_function(mLapack, "claqr5", rb_claqr5, -1);
-}
diff --git a/claqsb.c b/claqsb.c
deleted file mode 100644
index 223226d..0000000
--- a/claqsb.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqsb_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_claqsb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.claqsb( uplo, kd, ab, s, scond, amax)\n or\n NumRu::Lapack.claqsb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_s = argv[3];
- rb_scond = argv[4];
- rb_amax = argv[5];
-
- scond = (real)NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kd = NUM2INT(rb_kd);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- claqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_claqsb(VALUE mLapack){
- rb_define_module_function(mLapack, "claqsb", rb_claqsb, -1);
-}
diff --git a/claqsp.c b/claqsp.c
deleted file mode 100644
index 5a3a8cf..0000000
--- a/claqsp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqsp_(char *uplo, integer *n, complex *ap, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_claqsp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ap = NumRu::Lapack.claqsp( uplo, ap, s, scond, amax)\n or\n NumRu::Lapack.claqsp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQSP 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = (real)NUM2DBL(rb_scond);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- claqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ap);
-}
-
-void
-init_lapack_claqsp(VALUE mLapack){
- rb_define_module_function(mLapack, "claqsp", rb_claqsp, -1);
-}
diff --git a/claqsy.c b/claqsy.c
deleted file mode 100644
index 0ebacdb..0000000
--- a/claqsy.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claqsy_(char *uplo, integer *n, complex *a, integer *lda, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_claqsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.claqsy( uplo, a, s, scond, amax)\n or\n NumRu::Lapack.claqsy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQSY 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 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) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = (real)NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- claqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_claqsy(VALUE mLapack){
- rb_define_module_function(mLapack, "claqsy", rb_claqsy, -1);
-}
diff --git a/clar1v.c b/clar1v.c
deleted file mode 100644
index d5f0482..0000000
--- a/clar1v.c
+++ /dev/null
@@ -1,154 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clar1v_(integer *n, integer *b1, integer *bn, real *lambda, real *d, real *l, real *ld, real *lld, real *pivmin, real *gaptol, complex *z, logical *wantnc, integer *negcnt, real *ztz, real *mingma, integer *r, integer *isuppz, real *nrminv, real *resid, real *rqcorr, real *work);
-
-static VALUE
-rb_clar1v(int argc, VALUE *argv, VALUE self){
- VALUE rb_b1;
- integer b1;
- VALUE rb_bn;
- integer bn;
- VALUE rb_lambda;
- real lambda;
- VALUE rb_d;
- real *d;
- VALUE rb_l;
- real *l;
- VALUE rb_ld;
- real *ld;
- VALUE rb_lld;
- real *lld;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_gaptol;
- real gaptol;
- VALUE rb_z;
- complex *z;
- VALUE rb_wantnc;
- logical wantnc;
- VALUE rb_r;
- integer r;
- VALUE rb_negcnt;
- integer negcnt;
- VALUE rb_ztz;
- real ztz;
- VALUE rb_mingma;
- real mingma;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_nrminv;
- real nrminv;
- VALUE rb_resid;
- real resid;
- VALUE rb_rqcorr;
- real rqcorr;
- VALUE rb_z_out__;
- complex *z_out__;
- real *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.clar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r)\n or\n NumRu::Lapack.clar1v # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAR1V( 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* CLAR1V 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) REAL \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) REAL 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) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D.\n*\n* LD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*D(i).\n*\n* LLD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*L(i)*D(i).\n*\n* PIVMIN (input) REAL \n* The minimum pivot in the Sturm sequence.\n*\n* GAPTOL (input) REAL \n* Tolerance that indicates when eigenvector entries are negligible\n* w.r.t. their contribution to the residual.\n*\n* Z (input/output) COMPLEX 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) REAL \n* The square of the 2-norm of Z.\n*\n* MINGMA (output) REAL \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) REAL \n* NRMINV = 1/SQRT( ZTZ )\n*\n* RESID (output) REAL \n* The residual of the FP vector.\n* RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n* RQCORR (output) REAL \n* The Rayleigh Quotient correction to LAMBDA.\n* RQCORR = MINGMA*TMP\n*\n* WORK (workspace) REAL 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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_b1 = argv[0];
- rb_bn = argv[1];
- rb_lambda = argv[2];
- rb_d = argv[3];
- rb_l = argv[4];
- rb_ld = argv[5];
- rb_lld = argv[6];
- rb_pivmin = argv[7];
- rb_gaptol = argv[8];
- rb_z = argv[9];
- rb_wantnc = argv[10];
- rb_r = argv[11];
-
- pivmin = (real)NUM2DBL(rb_pivmin);
- bn = NUM2INT(rb_bn);
- lambda = (real)NUM2DBL(rb_lambda);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (10th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- wantnc = (rb_wantnc == Qtrue);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- r = NUM2INT(rb_r);
- gaptol = (real)NUM2DBL(rb_gaptol);
- b1 = NUM2INT(rb_b1);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_SFLOAT)
- rb_lld = na_change_type(rb_lld, NA_SFLOAT);
- lld = NA_PTR_TYPE(rb_lld, real*);
- if (!NA_IsNArray(rb_ld))
- rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
- if (NA_RANK(rb_ld) != 1)
- rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
- if (NA_TYPE(rb_ld) != NA_SFLOAT)
- rb_ld = na_change_type(rb_ld, NA_SFLOAT);
- ld = NA_PTR_TYPE(rb_ld, real*);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (5th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
- if (NA_TYPE(rb_l) != NA_SFLOAT)
- rb_l = na_change_type(rb_l, NA_SFLOAT);
- l = NA_PTR_TYPE(rb_l, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(real, (4*n));
-
- clar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);
-
- free(work);
- rb_negcnt = INT2NUM(negcnt);
- rb_ztz = rb_float_new((double)ztz);
- rb_mingma = rb_float_new((double)mingma);
- rb_nrminv = rb_float_new((double)nrminv);
- rb_resid = rb_float_new((double)resid);
- rb_rqcorr = rb_float_new((double)rqcorr);
- rb_r = INT2NUM(r);
- return rb_ary_new3(9, rb_negcnt, rb_ztz, rb_mingma, rb_isuppz, rb_nrminv, rb_resid, rb_rqcorr, rb_z, rb_r);
-}
-
-void
-init_lapack_clar1v(VALUE mLapack){
- rb_define_module_function(mLapack, "clar1v", rb_clar1v, -1);
-}
diff --git a/clar2v.c b/clar2v.c
deleted file mode 100644
index 949db91..0000000
--- a/clar2v.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clar2v_(integer *n, complex *x, complex *y, complex *z, integer *incx, real *c, complex *s, integer *incc);
-
-static VALUE
-rb_clar2v(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- complex *x;
- VALUE rb_y;
- complex *y;
- VALUE rb_z;
- complex *z;
- VALUE rb_incx;
- integer incx;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- complex *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_y_out__;
- complex *y_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.clar2v( n, x, y, z, incx, c, s, incc)\n or\n NumRu::Lapack.clar2v # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n* Purpose\n* =======\n*\n* CLAR2V 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 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 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 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) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) COMPLEX 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 REAL CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n $ ZIR\n COMPLEX SI, T2, T3, T4, ZI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC AIMAG, CMPLX, CONJG, REAL\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_y = argv[2];
- rb_z = argv[3];
- rb_incx = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- n = NUM2INT(rb_n);
- incc = NUM2INT(rb_incc);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (3th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_SCOMPLEX)
- rb_s = na_change_type(rb_s, NA_SCOMPLEX);
- s = NA_PTR_TYPE(rb_s, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- clar2v_(&n, x, y, z, &incx, c, s, &incc);
-
- return rb_ary_new3(3, rb_x, rb_y, rb_z);
-}
-
-void
-init_lapack_clar2v(VALUE mLapack){
- rb_define_module_function(mLapack, "clar2v", rb_clar2v, -1);
-}
diff --git a/clarcm.c b/clarcm.c
deleted file mode 100644
index 368cd12..0000000
--- a/clarcm.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarcm_(integer *m, integer *n, real *a, integer *lda, complex *b, integer *ldb, complex *c, integer *ldc, real *rwork);
-
-static VALUE
-rb_clarcm(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_c;
- complex *c;
- real *rwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarcm( a, b)\n or\n NumRu::Lapack.clarcm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n* Purpose\n* =======\n*\n* CLARCM 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) REAL 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) REAL 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 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) REAL array, dimension (2*M*N)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ldc = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, complex*);
- rwork = ALLOC_N(real, (2*m*n));
-
- clarcm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
-
- free(rwork);
- return rb_c;
-}
-
-void
-init_lapack_clarcm(VALUE mLapack){
- rb_define_module_function(mLapack, "clarcm", rb_clarcm, -1);
-}
diff --git a/clarf.c b/clarf.c
deleted file mode 100644
index 161313b..0000000
--- a/clarf.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarf_(char *side, integer *m, integer *n, complex *v, integer *incv, complex *tau, complex *c, integer *ldc, complex *work);
-
-static VALUE
-rb_clarf(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- complex *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- complex tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarf( side, m, v, incv, tau, c)\n or\n NumRu::Lapack.clarf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* CLARF applies a complex elementary reflector H to a complex M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_v = argv[2];
- rb_incv = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- tau.r = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (3th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- clarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_clarf(VALUE mLapack){
- rb_define_module_function(mLapack, "clarf", rb_clarf, -1);
-}
diff --git a/clarfb.c b/clarfb.c
deleted file mode 100644
index 9bc44a5..0000000
--- a/clarfb.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, complex *v, integer *ldv, complex *t, integer *ldt, complex *c, integer *ldc, complex *work, integer *ldwork);
-
-static VALUE
-rb_clarfb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- complex *v;
- VALUE rb_t;
- complex *t;
- VALUE rb_c;
- complex *c;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer ldv;
- integer k;
- integer ldt;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarfb( side, trans, direct, storev, m, v, t, c)\n or\n NumRu::Lapack.clarfb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* CLARFB applies a complex block reflector H or its transpose H' to a\n* complex M-by-N matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) COMPLEX array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_v = argv[5];
- rb_t = argv[6];
- rb_c = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- k = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- direct = StringValueCStr(rb_direct)[0];
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != k)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of v");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SCOMPLEX)
- rb_t = na_change_type(rb_t, NA_SCOMPLEX);
- t = NA_PTR_TYPE(rb_t, complex*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (ldwork)*(k));
-
- clarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_clarfb(VALUE mLapack){
- rb_define_module_function(mLapack, "clarfb", rb_clarfb, -1);
-}
diff --git a/clarfg.c b/clarfg.c
deleted file mode 100644
index 34c03f9..0000000
--- a/clarfg.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarfg_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau);
-
-static VALUE
-rb_clarfg(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- complex tau;
- VALUE rb_x_out__;
- complex *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.clarfg( n, alpha, x, incx)\n or\n NumRu::Lapack.clarfg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* CLARFG generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, with beta real, and x is an\n* (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- clarfg_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
- rb_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_clarfg(VALUE mLapack){
- rb_define_module_function(mLapack, "clarfg", rb_clarfg, -1);
-}
diff --git a/clarfgp.c b/clarfgp.c
deleted file mode 100644
index 236f43b..0000000
--- a/clarfgp.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarfgp_(integer *n, complex *alpha, complex *x, integer *incx, complex *tau);
-
-static VALUE
-rb_clarfgp(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- complex tau;
- VALUE rb_x_out__;
- complex *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.clarfgp( n, alpha, x, incx)\n or\n NumRu::Lapack.clarfgp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* CLARFGP generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is real and non-negative, and\n* x is an (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- clarfgp_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
- rb_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_clarfgp(VALUE mLapack){
- rb_define_module_function(mLapack, "clarfgp", rb_clarfgp, -1);
-}
diff --git a/clarft.c b/clarft.c
deleted file mode 100644
index 23aa034..0000000
--- a/clarft.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarft_(char *direct, char *storev, integer *n, integer *k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt);
-
-static VALUE
-rb_clarft(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- complex *v;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_t;
- complex *t;
- VALUE rb_v_out__;
- complex *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.clarft( direct, storev, n, v, tau)\n or\n NumRu::Lapack.clarft # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* CLARFT forms the triangular factor T of a complex block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, complex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, complex*);
- MEMCPY(v_out__, v, complex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- clarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_clarft(VALUE mLapack){
- rb_define_module_function(mLapack, "clarft", rb_clarft, -1);
-}
diff --git a/clarfx.c b/clarfx.c
deleted file mode 100644
index 12b61e3..0000000
--- a/clarfx.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarfx_(char *side, integer *m, integer *n, complex *v, complex *tau, complex *c, integer *ldc, complex *work);
-
-static VALUE
-rb_clarfx(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_v;
- complex *v;
- VALUE rb_tau;
- complex tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarfx( side, v, tau, c)\n or\n NumRu::Lapack.clarfx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* CLARFX applies a complex elementary reflector H to a complex m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_side = argv[0];
- rb_v = argv[1];
- rb_tau = argv[2];
- rb_c = argv[3];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (2th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- tau.r = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- clarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_clarfx(VALUE mLapack){
- rb_define_module_function(mLapack, "clarfx", rb_clarfx, -1);
-}
diff --git a/clargv.c b/clargv.c
deleted file mode 100644
index 3a0da13..0000000
--- a/clargv.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clargv_(integer *n, complex *x, integer *incx, complex *y, integer *incy, real *c, integer *incc);
-
-static VALUE
-rb_clargv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- complex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_incc;
- integer incc;
- VALUE rb_c;
- real *c;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_y_out__;
- complex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.clargv( n, x, incx, y, incy, incc)\n or\n NumRu::Lapack.clargv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* CLARGV generates a vector of complex plane rotations with real\n* cosines, determined by elements of the complex vectors x and y.\n* For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( r(i) )\n* ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 )\n*\n* where c(i)**2 + ABS(s(i))**2 = 1\n*\n* The following conventions are used (these are the same as in CLARTG,\n* but differ from the BLAS1 routine CROTG):\n* If y(i)=0, then c(i)=1 and s(i)=0.\n* If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* Further Details\n* ======= =======\n*\n* 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_incc = argv[5];
-
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incc;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- clargv_(&n, x, &incx, y, &incy, c, &incc);
-
- return rb_ary_new3(3, rb_c, rb_x, rb_y);
-}
-
-void
-init_lapack_clargv(VALUE mLapack){
- rb_define_module_function(mLapack, "clargv", rb_clargv, -1);
-}
diff --git a/clarnv.c b/clarnv.c
deleted file mode 100644
index 5933927..0000000
--- a/clarnv.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarnv_(integer *idist, integer *iseed, integer *n, complex *x);
-
-static VALUE
-rb_clarnv(int argc, VALUE *argv, VALUE self){
- VALUE rb_idist;
- integer idist;
- VALUE rb_iseed;
- integer *iseed;
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- complex *x;
- VALUE rb_iseed_out__;
- integer *iseed_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.clarnv( idist, iseed, n)\n or\n NumRu::Lapack.clarnv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* CLARNV returns a vector of n random complex numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: real and imaginary parts each uniform (0,1)\n* = 2: real and imaginary parts each uniform (-1,1)\n* = 3: real and imaginary parts each normal (0,1)\n* = 4: uniformly distributed on the disc abs(z) < 1\n* = 5: uniformly distributed on the circle abs(z) = 1\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) COMPLEX array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine SLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_idist = argv[0];
- rb_iseed = argv[1];
- rb_n = argv[2];
-
- n = NUM2INT(rb_n);
- idist = NUM2INT(rb_idist);
- if (!NA_IsNArray(rb_iseed))
- rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
- if (NA_RANK(rb_iseed) != 1)
- rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iseed) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
- if (NA_TYPE(rb_iseed) != NA_LINT)
- rb_iseed = na_change_type(rb_iseed, NA_LINT);
- iseed = NA_PTR_TYPE(rb_iseed, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 4;
- rb_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iseed_out__ = NA_PTR_TYPE(rb_iseed_out__, integer*);
- MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rb_iseed));
- rb_iseed = rb_iseed_out__;
- iseed = iseed_out__;
-
- clarnv_(&idist, iseed, &n, x);
-
- return rb_ary_new3(2, rb_x, rb_iseed);
-}
-
-void
-init_lapack_clarnv(VALUE mLapack){
- rb_define_module_function(mLapack, "clarnv", rb_clarnv, -1);
-}
diff --git a/clarrv.c b/clarrv.c
deleted file mode 100644
index 9cf0eb1..0000000
--- a/clarrv.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarrv_(integer *n, real *vl, real *vu, real *d, real *l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr, real *wgap, integer *iblock, integer *indexw, real *gers, complex *z, integer *ldz, integer *isuppz, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_clarrv(int argc, VALUE *argv, VALUE self){
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_d;
- real *d;
- VALUE rb_l;
- real *l;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_dol;
- integer dol;
- VALUE rb_dou;
- integer dou;
- VALUE rb_minrgp;
- real minrgp;
- VALUE rb_rtol1;
- real rtol1;
- VALUE rb_rtol2;
- real rtol2;
- VALUE rb_w;
- real *w;
- VALUE rb_werr;
- real *werr;
- VALUE rb_wgap;
- real *wgap;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_gers;
- real *gers;
- VALUE rb_z;
- complex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_l_out__;
- real *l_out__;
- VALUE rb_w_out__;
- real *w_out__;
- VALUE rb_werr_out__;
- real *werr_out__;
- VALUE rb_wgap_out__;
- real *wgap_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.clarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers)\n or\n NumRu::Lapack.clarrv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by SLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) REAL \n* VU (input) REAL \n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by SLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (in) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) REAL \n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) REAL array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from SLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) REAL array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) REAL array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) REAL array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in CLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in SLARRB when refining a child's eigenvalues.\n* =-2: Problem in SLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in SLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 (argc != 18)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
- rb_vl = argv[0];
- rb_vu = argv[1];
- rb_d = argv[2];
- rb_l = argv[3];
- rb_pivmin = argv[4];
- rb_isplit = argv[5];
- rb_m = argv[6];
- rb_dol = argv[7];
- rb_dou = argv[8];
- rb_minrgp = argv[9];
- rb_rtol1 = argv[10];
- rb_rtol2 = argv[11];
- rb_w = argv[12];
- rb_werr = argv[13];
- rb_wgap = argv[14];
- rb_iblock = argv[15];
- rb_indexw = argv[16];
- rb_gers = argv[17];
-
- vl = (real)NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (13th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- dol = NUM2INT(rb_dol);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (4th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of w");
- if (NA_TYPE(rb_l) != NA_SFLOAT)
- rb_l = na_change_type(rb_l, NA_SFLOAT);
- l = NA_PTR_TYPE(rb_l, real*);
- pivmin = (real)NUM2DBL(rb_pivmin);
- dou = NUM2INT(rb_dou);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of w");
- if (NA_TYPE(rb_wgap) != NA_SFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_SFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, real*);
- m = NUM2INT(rb_m);
- minrgp = (real)NUM2DBL(rb_minrgp);
- rtol2 = (real)NUM2DBL(rb_rtol2);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_indexw))
- rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
- if (NA_RANK(rb_indexw) != 1)
- rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
- if (NA_SHAPE0(rb_indexw) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of w");
- if (NA_TYPE(rb_indexw) != NA_LINT)
- rb_indexw = na_change_type(rb_indexw, NA_LINT);
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_SFLOAT)
- rb_werr = na_change_type(rb_werr, NA_SFLOAT);
- werr = NA_PTR_TYPE(rb_werr, real*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- rtol1 = (real)NUM2DBL(rb_rtol1);
- vu = (real)NUM2DBL(rb_vu);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_gers))
- rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
- if (NA_RANK(rb_gers) != 1)
- rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_gers) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
- if (NA_TYPE(rb_gers) != NA_SFLOAT)
- rb_gers = na_change_type(rb_gers, NA_SFLOAT);
- gers = NA_PTR_TYPE(rb_gers, real*);
- ldz = n;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_l_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- l_out__ = NA_PTR_TYPE(rb_l_out__, real*);
- MEMCPY(l_out__, l, real, NA_TOTAL(rb_l));
- rb_l = rb_l_out__;
- l = l_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, real*);
- MEMCPY(w_out__, w, real, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, real*);
- MEMCPY(werr_out__, werr, real, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, real*);
- MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- work = ALLOC_N(real, (12*n));
- iwork = ALLOC_N(integer, (7*n));
-
- clarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_z, rb_isuppz, rb_info, rb_d, rb_l, rb_w, rb_werr, rb_wgap);
-}
-
-void
-init_lapack_clarrv(VALUE mLapack){
- rb_define_module_function(mLapack, "clarrv", rb_clarrv, -1);
-}
diff --git a/clarscl2.c b/clarscl2.c
deleted file mode 100644
index 4f5f348..0000000
--- a/clarscl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarscl2_(integer *m, integer *n, real *d, complex *x, integer *ldx);
-
-static VALUE
-rb_clarscl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_x;
- complex *x;
- VALUE rb_x_out__;
- complex *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.clarscl2( d, x)\n or\n NumRu::Lapack.clarscl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* CLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the REAL diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- clarscl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_clarscl2(VALUE mLapack){
- rb_define_module_function(mLapack, "clarscl2", rb_clarscl2, -1);
-}
diff --git a/clartg.c b/clartg.c
deleted file mode 100644
index 16c5fb8..0000000
--- a/clartg.c
+++ /dev/null
@@ -1,44 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clartg_(complex *f, complex *g, real *cs, complex *sn, complex *r);
-
-static VALUE
-rb_clartg(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- complex f;
- VALUE rb_g;
- complex g;
- VALUE rb_cs;
- real cs;
- VALUE rb_sn;
- complex sn;
- VALUE rb_r;
- complex r;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.clartg( f, g)\n or\n NumRu::Lapack.clartg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* CLARTG generates a plane rotation so that\n*\n* [ CS SN ] [ F ] [ R ]\n* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a faster version of the BLAS1 routine CROTG, except for\n* the following differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0, then CS=0 and SN is chosen so that R is real.\n*\n\n* Arguments\n* =========\n*\n* F (input) COMPLEX\n* The first component of vector to be rotated.\n*\n* G (input) COMPLEX\n* The second component of vector to be rotated.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) COMPLEX\n* The sine of the rotation.\n*\n* R (output) COMPLEX\n* The nonzero component of the rotated vector.\n*\n\n* Further Details\n* ======= =======\n*\n* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
-
- f.r = (real)NUM2DBL(rb_funcall(rb_f, rb_intern("real"), 0));
- f.i = (real)NUM2DBL(rb_funcall(rb_f, rb_intern("imag"), 0));
- g.r = (real)NUM2DBL(rb_funcall(rb_g, rb_intern("real"), 0));
- g.i = (real)NUM2DBL(rb_funcall(rb_g, rb_intern("imag"), 0));
-
- clartg_(&f, &g, &cs, &sn, &r);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn.r)), rb_float_new((double)(sn.i)));
- rb_r = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(r.r)), rb_float_new((double)(r.i)));
- return rb_ary_new3(3, rb_cs, rb_sn, rb_r);
-}
-
-void
-init_lapack_clartg(VALUE mLapack){
- rb_define_module_function(mLapack, "clartg", rb_clartg, -1);
-}
diff --git a/clartv.c b/clartv.c
deleted file mode 100644
index abb6489..0000000
--- a/clartv.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clartv_(integer *n, complex *x, integer *incx, complex *y, integer *incy, real *c, complex *s, integer *incc);
-
-static VALUE
-rb_clartv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- complex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- complex *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_y_out__;
- complex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.clartv( n, x, incx, y, incy, c, s, incc)\n or\n NumRu::Lapack.clartv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* CLARTV applies a vector of complex plane rotations with real cosines\n* to elements of the complex vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(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 array, dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (input) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) COMPLEX 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, IY\n COMPLEX XI, YI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_SCOMPLEX)
- rb_s = na_change_type(rb_s, NA_SCOMPLEX);
- s = NA_PTR_TYPE(rb_s, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- clartv_(&n, x, &incx, y, &incy, c, s, &incc);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_clartv(VALUE mLapack){
- rb_define_module_function(mLapack, "clartv", rb_clartv, -1);
-}
diff --git a/clarz.c b/clarz.c
deleted file mode 100644
index 0bd9985..0000000
--- a/clarz.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarz_(char *side, integer *m, integer *n, integer *l, complex *v, integer *incv, complex *tau, complex *c, integer *ldc, complex *work);
-
-static VALUE
-rb_clarz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- complex *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- complex tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarz( side, m, l, v, incv, tau, c)\n or\n NumRu::Lapack.clarz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* CLARZ applies a complex elementary reflector H to a complex\n* M-by-N matrix C, from either the left or the right. H is represented\n* in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n* H is a product of k elementary reflectors as returned by CTZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* CTZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_l = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- tau.r = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1+(l-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- clarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_clarz(VALUE mLapack){
- rb_define_module_function(mLapack, "clarz", rb_clarz, -1);
-}
diff --git a/clarzb.c b/clarzb.c
deleted file mode 100644
index 791ea09..0000000
--- a/clarzb.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarzb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, integer *l, complex *v, integer *ldv, complex *t, integer *ldt, complex *c, integer *ldc, complex *work, integer *ldwork);
-
-static VALUE
-rb_clarzb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- complex *v;
- VALUE rb_t;
- complex *t;
- VALUE rb_c;
- complex *c;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer ldv;
- integer nv;
- integer ldt;
- integer k;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarzb( side, trans, direct, storev, m, l, v, t, c)\n or\n NumRu::Lapack.clarzb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* CLARZB applies a complex block reflector H or its transpose H**H\n* to a complex distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_l = argv[5];
- rb_v = argv[6];
- rb_t = argv[7];
- rb_c = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- nv = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- direct = StringValueCStr(rb_direct)[0];
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (8th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
- k = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SCOMPLEX)
- rb_t = na_change_type(rb_t, NA_SCOMPLEX);
- t = NA_PTR_TYPE(rb_t, complex*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (ldwork)*(k));
-
- clarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_clarzb(VALUE mLapack){
- rb_define_module_function(mLapack, "clarzb", rb_clarzb, -1);
-}
diff --git a/clarzt.c b/clarzt.c
deleted file mode 100644
index 2ee2523..0000000
--- a/clarzt.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clarzt_(char *direct, char *storev, integer *n, integer *k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt);
-
-static VALUE
-rb_clarzt(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- complex *v;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_t;
- complex *t;
- VALUE rb_v_out__;
- complex *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.clarzt( direct, storev, n, v, tau)\n or\n NumRu::Lapack.clarzt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* CLARZT forms the triangular factor T of a complex block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, complex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, complex*);
- MEMCPY(v_out__, v, complex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- clarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_clarzt(VALUE mLapack){
- rb_define_module_function(mLapack, "clarzt", rb_clarzt, -1);
-}
diff --git a/clascl.c b/clascl.c
deleted file mode 100644
index 250afe0..0000000
--- a/clascl.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clascl_(char *type, integer *kl, integer *ku, real *cfrom, real *cto, integer *m, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_clascl(int argc, VALUE *argv, VALUE self){
- VALUE rb_type;
- char type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_cfrom;
- real cfrom;
- VALUE rb_cto;
- real cto;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.clascl( type, kl, ku, cfrom, cto, m, a)\n or\n NumRu::Lapack.clascl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLASCL multiplies the M by N complex matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See CGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) REAL\n* CTO (input) REAL\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_type = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_cfrom = argv[3];
- rb_cto = argv[4];
- rb_m = argv[5];
- rb_a = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- cfrom = (real)NUM2DBL(rb_cfrom);
- type = StringValueCStr(rb_type)[0];
- cto = (real)NUM2DBL(rb_cto);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_clascl(VALUE mLapack){
- rb_define_module_function(mLapack, "clascl", rb_clascl, -1);
-}
diff --git a/clascl2.c b/clascl2.c
deleted file mode 100644
index 3f380bb..0000000
--- a/clascl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clascl2_(integer *m, integer *n, real *d, complex *x, integer *ldx);
-
-static VALUE
-rb_clascl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_x;
- complex *x;
- VALUE rb_x_out__;
- complex *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.clascl2( d, x)\n or\n NumRu::Lapack.clascl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* CLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the diagonal REAL matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- clascl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_clascl2(VALUE mLapack){
- rb_define_module_function(mLapack, "clascl2", rb_clascl2, -1);
-}
diff --git a/claset.c b/claset.c
deleted file mode 100644
index b27a589..0000000
--- a/claset.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claset_(char *uplo, integer *m, integer *n, complex *alpha, complex *beta, complex *a, integer *lda);
-
-static VALUE
-rb_claset(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_beta;
- complex beta;
- VALUE rb_a;
- complex *a;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.claset( uplo, m, alpha, beta, a)\n or\n NumRu::Lapack.claset # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* CLASET initializes a 2-D array A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set. The lower triangle\n* is unchanged.\n* = 'L': Lower triangular part is set. The upper triangle\n* is unchanged.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of A.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of A.\n*\n* ALPHA (input) COMPLEX\n* All the offdiagonal array elements are set to ALPHA.\n*\n* BETA (input) COMPLEX\n* All the diagonal array elements are set to BETA.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n* A(i,i) = BETA , 1 <= i <= min(m,n)\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_beta = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- beta.r = (real)NUM2DBL(rb_funcall(rb_beta, rb_intern("real"), 0));
- beta.i = (real)NUM2DBL(rb_funcall(rb_beta, rb_intern("imag"), 0));
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- claset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_claset(VALUE mLapack){
- rb_define_module_function(mLapack, "claset", rb_claset, -1);
-}
diff --git a/clasr.c b/clasr.c
deleted file mode 100644
index 44c296d..0000000
--- a/clasr.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clasr_(char *side, char *pivot, char *direct, integer *m, integer *n, real *c, real *s, complex *a, integer *lda);
-
-static VALUE
-rb_clasr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_pivot;
- char pivot;
- VALUE rb_direct;
- char direct;
- VALUE rb_m;
- integer m;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- real *s;
- VALUE rb_a;
- complex *a;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.clasr( side, pivot, direct, m, c, s, a)\n or\n NumRu::Lapack.clasr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* CLASR applies a sequence of real plane rotations to a complex matrix\n* A, from either the left or the right.\n*\n* When SIDE = 'L', the transformation takes the form\n*\n* A := P*A\n*\n* and when SIDE = 'R', the transformation takes the form\n*\n* A := A*P**T\n*\n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_pivot = argv[1];
- rb_direct = argv[2];
- rb_m = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
- rb_a = argv[6];
-
- direct = StringValueCStr(rb_direct)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- pivot = StringValueCStr(rb_pivot)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_clasr(VALUE mLapack){
- rb_define_module_function(mLapack, "clasr", rb_clasr, -1);
-}
diff --git a/classq.c b/classq.c
deleted file mode 100644
index 7b27ad1..0000000
--- a/classq.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID classq_(integer *n, complex *x, integer *incx, real *scale, real *sumsq);
-
-static VALUE
-rb_classq(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_scale;
- real scale;
- VALUE rb_sumsq;
- real sumsq;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.classq( x, incx, scale, sumsq)\n or\n NumRu::Lapack.classq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* CLASSQ returns the values scl and ssq such that\n*\n* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n* assumed to be at least unity and the value of ssq will then satisfy\n*\n* 1.0 .le. ssq .le. ( sumsq + 2*n ).\n*\n* scale is assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n* i\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n* SCALE and SUMSQ are overwritten by scl and ssq respectively.\n*\n* The routine makes only one pass through the vector X.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector x as described above.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) REAL\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with the value scl .\n*\n* SUMSQ (input/output) REAL\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with the value ssq .\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_incx = argv[1];
- rb_scale = argv[2];
- rb_sumsq = argv[3];
-
- scale = (real)NUM2DBL(rb_scale);
- sumsq = (real)NUM2DBL(rb_sumsq);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- incx = NUM2INT(rb_incx);
-
- classq_(&n, x, &incx, &scale, &sumsq);
-
- rb_scale = rb_float_new((double)scale);
- rb_sumsq = rb_float_new((double)sumsq);
- return rb_ary_new3(2, rb_scale, rb_sumsq);
-}
-
-void
-init_lapack_classq(VALUE mLapack){
- rb_define_module_function(mLapack, "classq", rb_classq, -1);
-}
diff --git a/claswp.c b/claswp.c
deleted file mode 100644
index dcc70c3..0000000
--- a/claswp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID claswp_(integer *n, complex *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx);
-
-static VALUE
-rb_claswp(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_k1;
- integer k1;
- VALUE rb_k2;
- integer k2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_incx;
- integer incx;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.claswp( a, k1, k2, ipiv, incx)\n or\n NumRu::Lapack.claswp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* CLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n COMPLEX TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_k1 = argv[1];
- rb_k2 = argv[2];
- rb_ipiv = argv[3];
- rb_incx = argv[4];
-
- k2 = NUM2INT(rb_k2);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- k1 = NUM2INT(rb_k1);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != (k2*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- claswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
-
- return rb_a;
-}
-
-void
-init_lapack_claswp(VALUE mLapack){
- rb_define_module_function(mLapack, "claswp", rb_claswp, -1);
-}
diff --git a/clasyf.c b/clasyf.c
deleted file mode 100644
index 957fcd3..0000000
--- a/clasyf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clasyf_(char *uplo, integer *n, integer *nb, integer *kb, complex *a, integer *lda, integer *ipiv, complex *w, integer *ldw, integer *info);
-
-static VALUE
-rb_clasyf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- complex *a;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *w;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.clasyf( uplo, nb, a)\n or\n NumRu::Lapack.clasyf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* CLASYF computes a partial factorization of a complex symmetric matrix\n* A using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the transpose of U.\n*\n* CLASYF is an auxiliary routine called by CSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) COMPLEX 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- w = ALLOC_N(complex, (ldw)*(MAX(1,nb)));
-
- clasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
-
- free(w);
- rb_kb = INT2NUM(kb);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_kb, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_clasyf(VALUE mLapack){
- rb_define_module_function(mLapack, "clasyf", rb_clasyf, -1);
-}
diff --git a/clatbs.c b/clatbs.c
deleted file mode 100644
index 485cbb5..0000000
--- a/clatbs.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clatbs_(char *uplo, char *trans, char *diag, char *normin, integer *n, integer *kd, complex *ab, integer *ldab, complex *x, real *scale, real *cnorm, integer *info);
-
-static VALUE
-rb_clatbs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_x;
- complex *x;
- VALUE rb_cnorm;
- real *cnorm;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_cnorm_out__;
- real *cnorm_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.clatbs( uplo, trans, diag, normin, kd, ab, x, cnorm)\n or\n NumRu::Lapack.clatbs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* CLATBS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, CTBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_kd = argv[4];
- rb_ab = argv[5];
- rb_x = argv[6];
- rb_cnorm = argv[7];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_SFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_SFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, real*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of cnorm");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, real*);
- MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- clatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_clatbs(VALUE mLapack){
- rb_define_module_function(mLapack, "clatbs", rb_clatbs, -1);
-}
diff --git a/clatdf.c b/clatdf.c
deleted file mode 100644
index 176be2e..0000000
--- a/clatdf.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clatdf_(integer *ijob, integer *n, complex *z, integer *ldz, complex *rhs, real *rdsum, real *rdscal, integer *ipiv, integer *jpiv);
-
-static VALUE
-rb_clatdf(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_z;
- complex *z;
- VALUE rb_rhs;
- complex *rhs;
- VALUE rb_rdsum;
- real rdsum;
- VALUE rb_rdscal;
- real rdscal;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_rhs_out__;
- complex *rhs_out__;
-
- integer ldz;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.clatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv)\n or\n NumRu::Lapack.clatdf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* CLATDF computes the contribution to the reciprocal Dif-estimate\n* by solving for x in Z * x = b, where b is chosen such that the norm\n* of x is as large as possible. It is assumed that LU decomposition\n* of Z has been computed by CGETC2. On entry RHS = f holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by CGETC2 has the form\n* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n* triangular with unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using CGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value of\n* 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where\n* all entries of the r.h.s. b is choosen as either +1 or\n* -1. Default.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) REAL array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by CGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) REAL array, dimension (N).\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries according to the value of IJOB (see above).\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by CTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when CTGSY2 is called by CTGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when CTGSY2 is called by\n* CTGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report UMINF-95.05, Department of\n* Computing Science, Umea University, S-901 87 Umea, Sweden,\n* 1995.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_ijob = argv[0];
- rb_z = argv[1];
- rb_rhs = argv[2];
- rb_rdsum = argv[3];
- rb_rdscal = argv[4];
- rb_ipiv = argv[5];
- rb_jpiv = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- rdscal = (real)NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of ipiv");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- rdsum = (real)NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_SCOMPLEX)
- rb_rhs = na_change_type(rb_rhs, NA_SCOMPLEX);
- rhs = NA_PTR_TYPE(rb_rhs, complex*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, complex*);
- MEMCPY(rhs_out__, rhs, complex, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- clatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
-
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(3, rb_rhs, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_clatdf(VALUE mLapack){
- rb_define_module_function(mLapack, "clatdf", rb_clatdf, -1);
-}
diff --git a/clatps.c b/clatps.c
deleted file mode 100644
index b46ad6e..0000000
--- a/clatps.c
+++ /dev/null
@@ -1,105 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clatps_(char *uplo, char *trans, char *diag, char *normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm, integer *info);
-
-static VALUE
-rb_clatps(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_x;
- complex *x;
- VALUE rb_cnorm;
- real *cnorm;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_cnorm_out__;
- real *cnorm_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.clatps( uplo, trans, diag, normin, ap, x, cnorm)\n or\n NumRu::Lapack.clatps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* CLATPS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A**T denotes the\n* transpose of A, A**H denotes the conjugate transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX 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*\n* X (input/output) COMPLEX array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, CTPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_ap = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_SFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_SFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- normin = StringValueCStr(rb_normin)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, real*);
- MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- clatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_clatps(VALUE mLapack){
- rb_define_module_function(mLapack, "clatps", rb_clatps, -1);
-}
diff --git a/clatrd.c b/clatrd.c
deleted file mode 100644
index 2b09fe7..0000000
--- a/clatrd.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clatrd_(char *uplo, integer *n, integer *nb, complex *a, integer *lda, real *e, complex *tau, complex *w, integer *ldw);
-
-static VALUE
-rb_clatrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- complex *a;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_w;
- complex *w;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.clatrd( uplo, nb, a)\n or\n NumRu::Lapack.clatrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* CLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n* Hermitian tridiagonal form by a unitary similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', CLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', CLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by CHETRD.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* E (output) REAL array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) COMPLEX array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a Hermitian rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = ldw;
- shape[1] = MAX(n,nb);
- rb_w = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
-
- return rb_ary_new3(4, rb_e, rb_tau, rb_w, rb_a);
-}
-
-void
-init_lapack_clatrd(VALUE mLapack){
- rb_define_module_function(mLapack, "clatrd", rb_clatrd, -1);
-}
diff --git a/clatrs.c b/clatrs.c
deleted file mode 100644
index 03eb042..0000000
--- a/clatrs.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clatrs_(char *uplo, char *trans, char *diag, char *normin, integer *n, complex *a, integer *lda, complex *x, real *scale, real *cnorm, integer *info);
-
-static VALUE
-rb_clatrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_a;
- complex *a;
- VALUE rb_x;
- complex *x;
- VALUE rb_cnorm;
- real *cnorm;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_cnorm_out__;
- real *cnorm_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.clatrs( uplo, trans, diag, normin, a, x, cnorm)\n or\n NumRu::Lapack.clatrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* CLATRS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A**T denotes the transpose of A, A**H denotes the\n* conjugate transpose of A, x and b are n-element vectors, and s is a\n* scaling factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, CTRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_a = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_SFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_SFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, real*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of cnorm");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- diag = StringValueCStr(rb_diag)[0];
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, real*);
- MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- clatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_clatrs(VALUE mLapack){
- rb_define_module_function(mLapack, "clatrs", rb_clatrs, -1);
-}
diff --git a/clatrz.c b/clatrz.c
deleted file mode 100644
index b84384b..0000000
--- a/clatrz.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clatrz_(integer *m, integer *n, integer *l, complex *a, integer *lda, complex *tau, complex *work);
-
-static VALUE
-rb_clatrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.clatrz( l, a)\n or\n NumRu::Lapack.clatrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means\n* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_l = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- l = NUM2INT(rb_l);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (m));
-
- clatrz_(&m, &n, &l, a, &lda, tau, work);
-
- free(work);
- return rb_ary_new3(2, rb_tau, rb_a);
-}
-
-void
-init_lapack_clatrz(VALUE mLapack){
- rb_define_module_function(mLapack, "clatrz", rb_clatrz, -1);
-}
diff --git a/clatzm.c b/clatzm.c
deleted file mode 100644
index b5e022a..0000000
--- a/clatzm.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clatzm_(char *side, integer *m, integer *n, complex *v, integer *incv, complex *tau, complex *c1, complex *c2, integer *ldc, complex *work);
-
-static VALUE
-rb_clatzm(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- complex *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- complex tau;
- VALUE rb_c1;
- complex *c1;
- VALUE rb_c2;
- complex *c2;
- VALUE rb_c1_out__;
- complex *c1_out__;
- VALUE rb_c2_out__;
- complex *c2_out__;
- complex *work;
-
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.clatzm( side, m, n, v, incv, tau, c1, c2)\n or\n NumRu::Lapack.clatzm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CUNMRZ.\n*\n* CLATZM applies a Householder matrix generated by CTZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of P.\n*\n* C1 (input/output) COMPLEX array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) COMPLEX array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2.\n* LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c1 = argv[6];
- rb_c2 = argv[7];
-
- tau.r = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = (real)NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_c2))
- rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
- if (NA_RANK(rb_c2) != 2)
- rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
- ldc = NA_SHAPE0(rb_c2);
- if (NA_TYPE(rb_c2) != NA_SCOMPLEX)
- rb_c2 = na_change_type(rb_c2, NA_SCOMPLEX);
- c2 = NA_PTR_TYPE(rb_c2, complex*);
- if (!NA_IsNArray(rb_c1))
- rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
- if (NA_RANK(rb_c1) != 2)
- rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
- if (NA_SHAPE0(rb_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
- if (NA_TYPE(rb_c1) != NA_SCOMPLEX)
- rb_c1 = na_change_type(rb_c1, NA_SCOMPLEX);
- c1 = NA_PTR_TYPE(rb_c1, complex*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- {
- int shape[2];
- shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
- rb_c1_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c1_out__ = NA_PTR_TYPE(rb_c1_out__, complex*);
- MEMCPY(c1_out__, c1, complex, NA_TOTAL(rb_c1));
- rb_c1 = rb_c1_out__;
- c1 = c1_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
- rb_c2_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c2_out__ = NA_PTR_TYPE(rb_c2_out__, complex*);
- MEMCPY(c2_out__, c2, complex, NA_TOTAL(rb_c2));
- rb_c2 = rb_c2_out__;
- c2 = c2_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- clatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
-
- free(work);
- return rb_ary_new3(2, rb_c1, rb_c2);
-}
-
-void
-init_lapack_clatzm(VALUE mLapack){
- rb_define_module_function(mLapack, "clatzm", rb_clatzm, -1);
-}
diff --git a/clauu2.c b/clauu2.c
deleted file mode 100644
index 3d91aab..0000000
--- a/clauu2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clauu2_(char *uplo, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_clauu2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.clauu2( uplo, a)\n or\n NumRu::Lapack.clauu2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLAUU2 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) COMPLEX 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clauu2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_clauu2(VALUE mLapack){
- rb_define_module_function(mLapack, "clauu2", rb_clauu2, -1);
-}
diff --git a/clauum.c b/clauum.c
deleted file mode 100644
index 076644d..0000000
--- a/clauum.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID clauum_(char *uplo, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_clauum(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.clauum( uplo, a)\n or\n NumRu::Lapack.clauum # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLAUUM 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) COMPLEX 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- clauum_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_clauum(VALUE mLapack){
- rb_define_module_function(mLapack, "clauum", rb_clauum, -1);
-}
diff --git a/cpbcon.c b/cpbcon.c
deleted file mode 100644
index 454a7ae..0000000
--- a/cpbcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbcon_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *anorm, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cpbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cpbcon( uplo, kd, ab, anorm)\n or\n NumRu::Lapack.cpbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite band matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* CPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the Hermitian band 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cpbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbcon", rb_cpbcon, -1);
-}
diff --git a/cpbequ.c b/cpbequ.c
deleted file mode 100644
index dad357c..0000000
--- a/cpbequ.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbequ_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_cpbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cpbequ( uplo, kd, ab)\n or\n NumRu::Lapack.cpbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPBEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- cpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_cpbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbequ", rb_cpbequ, -1);
-}
diff --git a/cpbrfs.c b/cpbrfs.c
deleted file mode 100644
index 97d578c..0000000
--- a/cpbrfs.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbrfs_(char *uplo, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cpbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cpbrfs( uplo, kd, ab, afb, b, x)\n or\n NumRu::Lapack.cpbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A as computed by\n* CPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPBTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_afb = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cpbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbrfs", rb_cpbrfs, -1);
-}
diff --git a/cpbstf.c b/cpbstf.c
deleted file mode 100644
index 61c1acc..0000000
--- a/cpbstf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbstf_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_cpbstf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.cpbstf( uplo, kd, ab)\n or\n NumRu::Lapack.cpbstf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* CPBSTF computes a split Cholesky factorization of a complex\n* Hermitian positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with CHBGST.\n*\n* The factorization has the form A = S**H*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**H*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine; s12' denotes\n* conjg(s12); the diagonal elements of S are real.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- cpbstf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_cpbstf(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbstf", rb_cpbstf, -1);
-}
diff --git a/cpbsv.c b/cpbsv.c
deleted file mode 100644
index 9713209..0000000
--- a/cpbsv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbsv_(char *uplo, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cpbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.cpbsv( uplo, kd, ab, b)\n or\n NumRu::Lapack.cpbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPBSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CPBTRF, CPBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_cpbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbsv", rb_cpbsv, -1);
-}
diff --git a/cpbsvx.c b/cpbsvx.c
deleted file mode 100644
index ef5dac6..0000000
--- a/cpbsvx.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbsvx_(char *fact, char *uplo, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *afb, integer *ldafb, char *equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cpbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_afb;
- complex *afb;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
- VALUE rb_afb_out__;
- complex *afb_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.cpbsvx( fact, uplo, kd, ab, afb, equed, s, b)\n or\n NumRu::Lapack.cpbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) COMPLEX array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- kd = NUM2INT(rb_kd);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_SCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, complex*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, complex*);
- MEMCPY(afb_out__, afb, complex, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ab, rb_afb, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_cpbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbsvx", rb_cpbsvx, -1);
-}
diff --git a/cpbtf2.c b/cpbtf2.c
deleted file mode 100644
index 86557bf..0000000
--- a/cpbtf2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbtf2_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_cpbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.cpbtf2( uplo, kd, ab)\n or\n NumRu::Lapack.cpbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* CPBTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the conjugate transpose\n* of U, and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- cpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_cpbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbtf2", rb_cpbtf2, -1);
-}
diff --git a/cpbtrf.c b/cpbtrf.c
deleted file mode 100644
index e3ec097..0000000
--- a/cpbtrf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbtrf_(char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_cpbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- complex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.cpbtrf( uplo, kd, ab)\n or\n NumRu::Lapack.cpbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* CPBTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, complex*);
- MEMCPY(ab_out__, ab, complex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- cpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_cpbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbtrf", rb_cpbtrf, -1);
-}
diff --git a/cpbtrs.c b/cpbtrs.c
deleted file mode 100644
index 5b7944b..0000000
--- a/cpbtrs.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpbtrs_(char *uplo, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cpbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpbtrs( uplo, kd, ab, b)\n or\n NumRu::Lapack.cpbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPBTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite band matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by CPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CTBSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cpbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cpbtrs", rb_cpbtrs, -1);
-}
diff --git a/cpftrf.c b/cpftrf.c
deleted file mode 100644
index 6bf3eed..0000000
--- a/cpftrf.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpftrf_(char *transr, char *uplo, integer *n, complex *a, integer *info);
-
-static VALUE
-rb_cpftrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cpftrf( transr, uplo, n, a)\n or\n NumRu::Lapack.cpftrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* CPFTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**H*U or RFP A = L*L**H.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n* Further Notes on RFP Format:\n* ============================\n*\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cpftrf_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cpftrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cpftrf", rb_cpftrf, -1);
-}
diff --git a/cpftri.c b/cpftri.c
deleted file mode 100644
index 933915b..0000000
--- a/cpftri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpftri_(char *transr, char *uplo, integer *n, complex *a, integer *info);
-
-static VALUE
-rb_cpftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cpftri( transr, uplo, n, a)\n or\n NumRu::Lapack.cpftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* CPFTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by CPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the Hermitian inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cpftri_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cpftri(VALUE mLapack){
- rb_define_module_function(mLapack, "cpftri", rb_cpftri, -1);
-}
diff --git a/cpftrs.c b/cpftrs.c
deleted file mode 100644
index 45d4b19..0000000
--- a/cpftrs.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpftrs_(char *transr, char *uplo, integer *n, integer *nrhs, complex *a, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cpftrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpftrs( transr, uplo, n, a, b)\n or\n NumRu::Lapack.cpftrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPFTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by CPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) COMPLEX array, dimension ( N*(N+1)/2 );\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**H*U or RFP A = L*L**H, as computed by CPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cpftrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cpftrs", rb_cpftrs, -1);
-}
diff --git a/cpocon.c b/cpocon.c
deleted file mode 100644
index ccb4d45..0000000
--- a/cpocon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpocon_(char *uplo, integer *n, complex *a, integer *lda, real *anorm, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cpocon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cpocon( uplo, a, anorm)\n or\n NumRu::Lapack.cpocon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPOCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite matrix using the\n* Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the Hermitian 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cpocon(VALUE mLapack){
- rb_define_module_function(mLapack, "cpocon", rb_cpocon, -1);
-}
diff --git a/cpoequ.c b/cpoequ.c
deleted file mode 100644
index 869987f..0000000
--- a/cpoequ.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpoequ_(integer *n, complex *a, integer *lda, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_cpoequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cpoequ( a)\n or\n NumRu::Lapack.cpoequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPOEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N Hermitian positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- cpoequ_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_cpoequ(VALUE mLapack){
- rb_define_module_function(mLapack, "cpoequ", rb_cpoequ, -1);
-}
diff --git a/cpoequb.c b/cpoequb.c
deleted file mode 100644
index 08229a6..0000000
--- a/cpoequb.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpoequb_(integer *n, complex *a, integer *lda, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_cpoequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cpoequb( a)\n or\n NumRu::Lapack.cpoequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPOEQUB computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- cpoequb_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_cpoequb(VALUE mLapack){
- rb_define_module_function(mLapack, "cpoequb", rb_cpoequb, -1);
-}
diff --git a/cporfs.c b/cporfs.c
deleted file mode 100644
index 20107fd..0000000
--- a/cporfs.c
+++ /dev/null
@@ -1,122 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cporfs_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cporfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cporfs( uplo, a, af, b, x)\n or\n NumRu::Lapack.cporfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPOTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cporfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cporfs", rb_cporfs, -1);
-}
diff --git a/cporfsx.c b/cporfsx.c
deleted file mode 100644
index 0f5bd50..0000000
--- a/cporfsx.c
+++ /dev/null
@@ -1,187 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cporfsx_(char *uplo, char *equed, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cporfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cporfsx( uplo, equed, a, af, s, b, x, params)\n or\n NumRu::Lapack.cporfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_s = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
- rb_params = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (5th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_cporfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "cporfsx", rb_cporfsx, -1);
-}
diff --git a/cposv.c b/cposv.c
deleted file mode 100644
index 96e64c5..0000000
--- a/cposv.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cposv_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cposv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.cposv( uplo, a, b)\n or\n NumRu::Lapack.cposv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPOSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CPOTRF, CPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_cposv(VALUE mLapack){
- rb_define_module_function(mLapack, "cposv", rb_cposv, -1);
-}
diff --git a/cposvx.c b/cposvx.c
deleted file mode 100644
index 77cc176..0000000
--- a/cposvx.c
+++ /dev/null
@@ -1,178 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cposvx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cposvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.cposvx( fact, uplo, a, af, equed, s, b)\n or\n NumRu::Lapack.cposvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS righthand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_cposvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cposvx", rb_cposvx, -1);
-}
diff --git a/cposvxx.c b/cposvxx.c
deleted file mode 100644
index f31e83c..0000000
--- a/cposvxx.c
+++ /dev/null
@@ -1,216 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cposvxx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, char *equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cposvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.cposvxx( fact, uplo, a, af, equed, s, b, params)\n or\n NumRu::Lapack.cposvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a complex system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_params = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- n_err_bnds = 3;
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- cposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_cposvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "cposvxx", rb_cposvxx, -1);
-}
diff --git a/cpotf2.c b/cpotf2.c
deleted file mode 100644
index 501d942..0000000
--- a/cpotf2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpotf2_(char *uplo, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_cpotf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cpotf2( uplo, a)\n or\n NumRu::Lapack.cpotf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CPOTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cpotf2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cpotf2(VALUE mLapack){
- rb_define_module_function(mLapack, "cpotf2", rb_cpotf2, -1);
-}
diff --git a/cpotrf.c b/cpotrf.c
deleted file mode 100644
index e723fe1..0000000
--- a/cpotrf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpotrf_(char *uplo, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_cpotrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cpotrf( uplo, a)\n or\n NumRu::Lapack.cpotrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CPOTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cpotrf_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cpotrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cpotrf", rb_cpotrf, -1);
-}
diff --git a/cpotri.c b/cpotri.c
deleted file mode 100644
index 697c49e..0000000
--- a/cpotri.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpotri_(char *uplo, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_cpotri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cpotri( uplo, a)\n or\n NumRu::Lapack.cpotri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CPOTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, as computed by\n* CPOTRF.\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLAUUM, CTRTRI, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cpotri_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cpotri(VALUE mLapack){
- rb_define_module_function(mLapack, "cpotri", rb_cpotri, -1);
-}
diff --git a/cpotrs.c b/cpotrs.c
deleted file mode 100644
index 0b20805..0000000
--- a/cpotrs.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpotrs_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cpotrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpotrs( uplo, a, b)\n or\n NumRu::Lapack.cpotrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPOTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization \n* A = U**H*U or A = L*L**H computed by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cpotrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cpotrs", rb_cpotrs, -1);
-}
diff --git a/cppcon.c b/cppcon.c
deleted file mode 100644
index 0eb0ed6..0000000
--- a/cppcon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cppcon_(char *uplo, integer *n, complex *ap, real *anorm, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cppcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cppcon( uplo, ap, anorm)\n or\n NumRu::Lapack.cppcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPPCON estimates the reciprocal of the condition number (in the \n* 1-norm) of a complex Hermitian positive definite packed matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* CPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the Hermitian 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cppcon_(&uplo, &n, ap, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cppcon(VALUE mLapack){
- rb_define_module_function(mLapack, "cppcon", rb_cppcon, -1);
-}
diff --git a/cppequ.c b/cppequ.c
deleted file mode 100644
index 7e7dda0..0000000
--- a/cppequ.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cppequ_(char *uplo, integer *n, complex *ap, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_cppequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cppequ( uplo, ap)\n or\n NumRu::Lapack.cppequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPPEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- cppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_cppequ(VALUE mLapack){
- rb_define_module_function(mLapack, "cppequ", rb_cppequ, -1);
-}
diff --git a/cpprfs.c b/cpprfs.c
deleted file mode 100644
index 011789e..0000000
--- a/cpprfs.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpprfs_(char *uplo, integer *n, integer *nrhs, complex *ap, complex *afp, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cpprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_afp;
- complex *afp;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cpprfs( uplo, ap, afp, b, x)\n or\n NumRu::Lapack.cpprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPPTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_SCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cpprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cpprfs", rb_cpprfs, -1);
-}
diff --git a/cppsv.c b/cppsv.c
deleted file mode 100644
index 135e913..0000000
--- a/cppsv.c
+++ /dev/null
@@ -1,85 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cppsv_(char *uplo, integer *n, integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cppsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.cppsv( uplo, n, ap, b)\n or\n NumRu::Lapack.cppsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. \n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CPPTRF, CPPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_cppsv(VALUE mLapack){
- rb_define_module_function(mLapack, "cppsv", rb_cppsv, -1);
-}
diff --git a/cppsvx.c b/cppsvx.c
deleted file mode 100644
index f224bcf..0000000
--- a/cppsvx.c
+++ /dev/null
@@ -1,172 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cppsvx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cppsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_afp;
- complex *afp;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- VALUE rb_afp_out__;
- complex *afp_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.cppsvx( fact, uplo, ap, afp, equed, s, b)\n or\n NumRu::Lapack.cppsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U'* U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, L is a lower triangular\n* matrix, and ' indicates conjugate transpose.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_SCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, complex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, complex*);
- MEMCPY(afp_out__, afp, complex, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ap, rb_afp, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_cppsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cppsvx", rb_cppsvx, -1);
-}
diff --git a/cpptrf.c b/cpptrf.c
deleted file mode 100644
index 4eebad3..0000000
--- a/cpptrf.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpptrf_(char *uplo, integer *n, complex *ap, integer *info);
-
-static VALUE
-rb_cpptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.cpptrf( uplo, n, ap)\n or\n NumRu::Lapack.cpptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* CPPTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- cpptrf_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_cpptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cpptrf", rb_cpptrf, -1);
-}
diff --git a/cpptri.c b/cpptri.c
deleted file mode 100644
index 2e19d6c..0000000
--- a/cpptri.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpptri_(char *uplo, integer *n, complex *ap, integer *info);
-
-static VALUE
-rb_cpptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.cpptri( uplo, n, ap)\n or\n NumRu::Lapack.cpptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* CPPTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by CPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- cpptri_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_cpptri(VALUE mLapack){
- rb_define_module_function(mLapack, "cpptri", rb_cpptri, -1);
-}
diff --git a/cpptrs.c b/cpptrs.c
deleted file mode 100644
index 8a0be64..0000000
--- a/cpptrs.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpptrs_(char *uplo, integer *n, integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cpptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpptrs( uplo, n, ap, b)\n or\n NumRu::Lapack.cpptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPPTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**H*U or A = L*L**H computed by CPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cpptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cpptrs", rb_cpptrs, -1);
-}
diff --git a/cpstf2.c b/cpstf2.c
deleted file mode 100644
index 3114c69..0000000
--- a/cpstf2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpstf2_(char *uplo, integer *n, complex *a, integer *lda, integer *piv, integer *rank, real *tol, real *work, integer *info);
-
-static VALUE
-rb_cpstf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_tol;
- real tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.cpstf2( uplo, a, tol)\n or\n NumRu::Lapack.cpstf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CPSTF2 computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- tol = (real)NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (2*n));
-
- cpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_cpstf2(VALUE mLapack){
- rb_define_module_function(mLapack, "cpstf2", rb_cpstf2, -1);
-}
diff --git a/cpstrf.c b/cpstrf.c
deleted file mode 100644
index e21d13f..0000000
--- a/cpstrf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpstrf_(char *uplo, integer *n, complex *a, integer *lda, integer *piv, integer *rank, real *tol, real *work, integer *info);
-
-static VALUE
-rb_cpstrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_tol;
- real tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.cpstrf( uplo, a, tol)\n or\n NumRu::Lapack.cpstrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CPSTRF computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- tol = (real)NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (2*n));
-
- cpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_cpstrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cpstrf", rb_cpstrf, -1);
-}
diff --git a/cptcon.c b/cptcon.c
deleted file mode 100644
index 3f518dc..0000000
--- a/cptcon.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cptcon_(integer *n, real *d, complex *e, real *anorm, real *rcond, real *rwork, integer *info);
-
-static VALUE
-rb_cptcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *rwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cptcon( d, e, anorm)\n or\n NumRu::Lapack.cptcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite tridiagonal matrix\n* using the factorization A = L*D*L**H or A = U**H*D*U computed by\n* CPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by CPTTRF.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by CPTTRF.\n*\n* ANORM (input) REAL\n* The 1-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 the\n* 1-norm of inv(A) computed in this routine.\n*\n* RWORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- rwork = ALLOC_N(real, (n));
-
- cptcon_(&n, d, e, &anorm, &rcond, rwork, &info);
-
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cptcon(VALUE mLapack){
- rb_define_module_function(mLapack, "cptcon", rb_cptcon, -1);
-}
diff --git a/cpteqr.c b/cpteqr.c
deleted file mode 100644
index 1e110e9..0000000
--- a/cpteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpteqr_(char *compz, integer *n, real *d, real *e, complex *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_cpteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_z;
- complex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_z_out__;
- complex *z_out__;
- real *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.cpteqr( compz, d, e, z)\n or\n NumRu::Lapack.cpteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using SPTTRF and then calling CBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band positive definite Hermitian matrix\n* can also be found if CHETRD, CHPTRD, or CHBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to\n* tridiagonal form, however, may preclude the possibility of obtaining\n* high relative accuracy in the small eigenvalues of the original\n* matrix, if these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original Hermitian\n* matrix also. Array Z contains the unitary matrix\n* used to reduce the original matrix to tridiagonal\n* form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original Hermitian matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* ====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(real, (4*n));
-
- cpteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_cpteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "cpteqr", rb_cpteqr, -1);
-}
diff --git a/cptrfs.c b/cptrfs.c
deleted file mode 100644
index 9e6b308..0000000
--- a/cptrfs.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cptrfs_(char *uplo, integer *n, integer *nrhs, real *d, complex *e, real *df, complex *ef, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cptrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_df;
- real *df;
- VALUE rb_ef;
- complex *ef;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.cptrfs( uplo, d, e, df, ef, b, x)\n or\n NumRu::Lapack.cptrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the superdiagonal or the subdiagonal of the\n* tridiagonal matrix A is stored and the form of the\n* factorization:\n* = 'U': E is the superdiagonal of A, and A = U**H*D*U;\n* = 'L': E is the subdiagonal of A, and A = L*D*L**H.\n* (The two forms are equivalent if A is real.)\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* D (input) REAL array, dimension (N)\n* The n real diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix A\n* (see UPLO).\n*\n* DF (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from\n* the factorization computed by CPTTRF.\n*\n* EF (input) COMPLEX array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal\n* factor U or L from the factorization computed by CPTTRF\n* (see UPLO).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPTTRS.\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 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).\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) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_df = argv[3];
- rb_ef = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (4th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
- if (NA_TYPE(rb_df) != NA_SFLOAT)
- rb_df = na_change_type(rb_df, NA_SFLOAT);
- df = NA_PTR_TYPE(rb_df, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_SCOMPLEX)
- rb_ef = na_change_type(rb_ef, NA_SCOMPLEX);
- ef = NA_PTR_TYPE(rb_ef, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (n));
-
- cptrfs_(&uplo, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_cptrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "cptrfs", rb_cptrfs, -1);
-}
diff --git a/cptsv.c b/cptsv.c
deleted file mode 100644
index 4e4bb3d..0000000
--- a/cptsv.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cptsv_(integer *n, integer *nrhs, real *d, complex *e, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cptsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- complex *e_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.cptsv( d, e, b)\n or\n NumRu::Lapack.cptsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPTSV computes the solution to a complex system of linear equations\n* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**H, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**H.\n*\n* E (input/output) COMPLEX array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**H factorization of\n* A. E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**H*D*U factorization of A.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL CPTTRF, CPTTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, complex*);
- MEMCPY(e_out__, e, complex, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cptsv_(&n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_cptsv(VALUE mLapack){
- rb_define_module_function(mLapack, "cptsv", rb_cptsv, -1);
-}
diff --git a/cptsvx.c b/cptsvx.c
deleted file mode 100644
index 347ee50..0000000
--- a/cptsvx.c
+++ /dev/null
@@ -1,152 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cptsvx_(char *fact, integer *n, integer *nrhs, real *d, complex *e, real *df, complex *ef, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cptsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_df;
- real *df;
- VALUE rb_ef;
- complex *ef;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_df_out__;
- real *df_out__;
- VALUE rb_ef_out__;
- complex *ef_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.cptsvx( fact, d, e, df, ef, b)\n or\n NumRu::Lapack.cptsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTSVX uses the factorization A = L*D*L**H to compute the solution\n* to a complex system of linear equations A*X = B, where A is an\n* N-by-N Hermitian positive definite tridiagonal matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**H*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix\n* A is supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) REAL array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n*\n* EF (input or output) COMPLEX array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) REAL array, dimension (NRHS)\n* The 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).\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 any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_df = argv[3];
- rb_ef = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (4th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_df);
- if (NA_TYPE(rb_df) != NA_SFLOAT)
- rb_df = na_change_type(rb_df, NA_SFLOAT);
- df = NA_PTR_TYPE(rb_df, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_SCOMPLEX)
- rb_ef = na_change_type(rb_ef, NA_SCOMPLEX);
- ef = NA_PTR_TYPE(rb_ef, complex*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, real*);
- MEMCPY(df_out__, df, real, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_ef_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ef_out__ = NA_PTR_TYPE(rb_ef_out__, complex*);
- MEMCPY(ef_out__, ef, complex, NA_TOTAL(rb_ef));
- rb_ef = rb_ef_out__;
- ef = ef_out__;
- work = ALLOC_N(complex, (n));
- rwork = ALLOC_N(real, (n));
-
- cptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_df, rb_ef);
-}
-
-void
-init_lapack_cptsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cptsvx", rb_cptsvx, -1);
-}
diff --git a/cpttrf.c b/cpttrf.c
deleted file mode 100644
index 2f01f0e..0000000
--- a/cpttrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpttrf_(integer *n, real *d, complex *e, integer *info);
-
-static VALUE
-rb_cpttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- complex *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.cpttrf( d, e)\n or\n NumRu::Lapack.cpttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* CPTTRF computes the L*D*L' factorization of a complex Hermitian\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) COMPLEX array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, complex*);
- MEMCPY(e_out__, e, complex, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- cpttrf_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_cpttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "cpttrf", rb_cpttrf, -1);
-}
diff --git a/cpttrs.c b/cpttrs.c
deleted file mode 100644
index 2187f8b..0000000
--- a/cpttrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cpttrs_(char *uplo, integer *n, integer *nrhs, real *d, complex *e, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cpttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpttrs( uplo, d, e, b)\n or\n NumRu::Lapack.cpttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 'U': A = U'*D*U, E is the superdiagonal of U\n* = 'L': A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER IUPLO, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CPTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cpttrs_(&uplo, &n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_cpttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "cpttrs", rb_cpttrs, -1);
-}
diff --git a/cptts2.c b/cptts2.c
deleted file mode 100644
index ccb7bdf..0000000
--- a/cptts2.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cptts2_(integer *iuplo, integer *n, integer *nrhs, real *d, complex *e, complex *b, integer *ldb);
-
-static VALUE
-rb_cptts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_iuplo;
- integer iuplo;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_b;
- complex *b;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.cptts2( iuplo, d, e, b)\n or\n NumRu::Lapack.cptts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* CPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* IUPLO (input) INTEGER\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 1: A = U'*D*U, E is the superdiagonal of U\n* = 0: A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL CSSCAL\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_iuplo = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- iuplo = NUM2INT(rb_iuplo);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cptts2_(&iuplo, &n, &nrhs, d, e, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_cptts2(VALUE mLapack){
- rb_define_module_function(mLapack, "cptts2", rb_cptts2, -1);
-}
diff --git a/crot.c b/crot.c
deleted file mode 100644
index 669463d..0000000
--- a/crot.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID crot_(integer *n, complex *cx, integer *incx, complex *cy, integer *incy, real *c, complex *s);
-
-static VALUE
-rb_crot(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- complex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_cy;
- complex *cy;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- real c;
- VALUE rb_s;
- complex s;
- VALUE rb_cx_out__;
- complex *cx_out__;
- VALUE rb_cy_out__;
- complex *cy_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.crot( cx, incx, cy, incy, c, s)\n or\n NumRu::Lapack.crot # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* CROT applies a plane rotation, where the cos (C) is real and the\n* sin (S) is complex, and the vectors CX and CY are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX array, dimension (N)\n* On input, the vector X.\n* On output, CX is overwritten with C*X + S*Y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* CY (input/output) COMPLEX array, dimension (N)\n* On input, the vector Y.\n* On output, CY is overwritten with -CONJG(S)*X + C*Y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* C (input) REAL\n* S (input) COMPLEX\n* C and S define a rotation\n* [ C S ]\n* [ -conjg(S) C ]\n* where C*C + S*CONJG(S) = 1.0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
- rb_cy = argv[2];
- rb_incy = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
-
- if (!NA_IsNArray(rb_cy))
- rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
- if (NA_RANK(rb_cy) != 1)
- rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cy);
- if (NA_TYPE(rb_cy) != NA_SCOMPLEX)
- rb_cy = na_change_type(rb_cy, NA_SCOMPLEX);
- cy = NA_PTR_TYPE(rb_cy, complex*);
- c = (real)NUM2DBL(rb_c);
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- s.r = (real)NUM2DBL(rb_funcall(rb_s, rb_intern("real"), 0));
- s.i = (real)NUM2DBL(rb_funcall(rb_s, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_cx) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of cx must be the same as shape 0 of cy");
- if (NA_TYPE(rb_cx) != NA_SCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_SCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_cx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- cx_out__ = NA_PTR_TYPE(rb_cx_out__, complex*);
- MEMCPY(cx_out__, cx, complex, NA_TOTAL(rb_cx));
- rb_cx = rb_cx_out__;
- cx = cx_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cy_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- cy_out__ = NA_PTR_TYPE(rb_cy_out__, complex*);
- MEMCPY(cy_out__, cy, complex, NA_TOTAL(rb_cy));
- rb_cy = rb_cy_out__;
- cy = cy_out__;
-
- crot_(&n, cx, &incx, cy, &incy, &c, &s);
-
- return rb_ary_new3(2, rb_cx, rb_cy);
-}
-
-void
-init_lapack_crot(VALUE mLapack){
- rb_define_module_function(mLapack, "crot", rb_crot, -1);
-}
diff --git a/cspcon.c b/cspcon.c
deleted file mode 100644
index d79d9e4..0000000
--- a/cspcon.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cspcon_(char *uplo, integer *n, complex *ap, integer *ipiv, real *anorm, real *rcond, complex *work, integer *info);
-
-static VALUE
-rb_cspcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cspcon( uplo, ap, ipiv, anorm)\n or\n NumRu::Lapack.cspcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric packed matrix A using the\n* factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- work = ALLOC_N(complex, (2*n));
-
- cspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_cspcon(VALUE mLapack){
- rb_define_module_function(mLapack, "cspcon", rb_cspcon, -1);
-}
diff --git a/cspmv.c b/cspmv.c
deleted file mode 100644
index 09e31dc..0000000
--- a/cspmv.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cspmv_(char *uplo, integer *n, complex *alpha, complex *ap, complex *x, integer *incx, complex *beta, complex *y, integer *incy);
-
-static VALUE
-rb_cspmv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- complex beta;
- VALUE rb_y;
- complex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- complex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.cspmv( uplo, n, alpha, ap, x, incx, beta, y, incy)\n or\n NumRu::Lapack.cspmv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CSPMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* AP (input) COMPLEX array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on.\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX array, dimension at least \n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_alpha = argv[2];
- rb_ap = argv[3];
- rb_x = argv[4];
- rb_incx = argv[5];
- rb_beta = argv[6];
- rb_y = argv[7];
- rb_incy = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- n = NUM2INT(rb_n);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- beta.r = (real)NUM2DBL(rb_funcall(rb_beta, rb_intern("real"), 0));
- beta.i = (real)NUM2DBL(rb_funcall(rb_beta, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*( n + 1 ) )/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*( n + 1 ) )/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- cspmv_(&uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_cspmv(VALUE mLapack){
- rb_define_module_function(mLapack, "cspmv", rb_cspmv, -1);
-}
diff --git a/cspr.c b/cspr.c
deleted file mode 100644
index e5e572c..0000000
--- a/cspr.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cspr_(char *uplo, integer *n, complex *alpha, complex *x, integer *incx, complex *ap);
-
-static VALUE
-rb_cspr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap = NumRu::Lapack.cspr( uplo, n, alpha, x, incx, ap)\n or\n NumRu::Lapack.cspr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n* Purpose\n* =======\n*\n* CSPR performs the symmetric rank 1 operation\n*\n* A := alpha*x*conjg( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* AP (input/output) COMPLEX array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on. On exit, the array\n* AP is overwritten by the upper triangular part of the\n* updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on. On exit, the array\n* AP is overwritten by the lower triangular part of the\n* updated matrix.\n* Note that the imaginary parts of the diagonal elements need\n* not be set, they are assumed to be zero, and on exit they\n* are set to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_alpha = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_ap = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (6th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*( n + 1 ) )/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*( n + 1 ) )/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = ( n*( n + 1 ) )/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- cspr_(&uplo, &n, &alpha, x, &incx, ap);
-
- return rb_ap;
-}
-
-void
-init_lapack_cspr(VALUE mLapack){
- rb_define_module_function(mLapack, "cspr", rb_cspr, -1);
-}
diff --git a/csprfs.c b/csprfs.c
deleted file mode 100644
index 17363ec..0000000
--- a/csprfs.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csprfs_(char *uplo, integer *n, integer *nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_csprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_afp;
- complex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.csprfs( uplo, ap, afp, ipiv, b, x)\n or\n NumRu::Lapack.csprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by CSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CSPTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_SCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- csprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_csprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "csprfs", rb_csprfs, -1);
-}
diff --git a/cspsv.c b/cspsv.c
deleted file mode 100644
index 366cd97..0000000
--- a/cspsv.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cspsv_(char *uplo, integer *n, integer *nrhs, complex *ap, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_cspsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_b;
- complex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldb;
- integer nrhs;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.cspsv( uplo, ap, b)\n or\n NumRu::Lapack.cspsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CSPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSPTRF, CSPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- cspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_cspsv(VALUE mLapack){
- rb_define_module_function(mLapack, "cspsv", rb_cspsv, -1);
-}
diff --git a/cspsvx.c b/cspsvx.c
deleted file mode 100644
index 84bf891..0000000
--- a/cspsvx.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cspsvx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_cspsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_afp;
- complex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_afp_out__;
- complex *afp_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.cspsvx( fact, uplo, ap, afp, ipiv, b)\n or\n NumRu::Lapack.cspsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form\n* of A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CSPTRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_SCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, complex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, complex*);
- MEMCPY(afp_out__, afp, complex, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- cspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_afp, rb_ipiv);
-}
-
-void
-init_lapack_cspsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "cspsvx", rb_cspsvx, -1);
-}
diff --git a/csptrf.c b/csptrf.c
deleted file mode 100644
index 8fd4836..0000000
--- a/csptrf.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csptrf_(char *uplo, integer *n, complex *ap, integer *ipiv, integer *info);
-
-static VALUE
-rb_csptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.csptrf( uplo, ap)\n or\n NumRu::Lapack.csptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CSPTRF computes the factorization of a complex symmetric matrix A\n* stored in packed format using the Bunch-Kaufman diagonal pivoting\n* method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- csptrf_(&uplo, &n, ap, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ap);
-}
-
-void
-init_lapack_csptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "csptrf", rb_csptrf, -1);
-}
diff --git a/csptri.c b/csptri.c
deleted file mode 100644
index 98ac525..0000000
--- a/csptri.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csptri_(char *uplo, integer *n, complex *ap, integer *ipiv, complex *work, integer *info);
-
-static VALUE
-rb_csptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
- complex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.csptri( uplo, ap, ipiv)\n or\n NumRu::Lapack.csptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPTRI computes the inverse of a complex symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* WORK (workspace) COMPLEX 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(complex, (n));
-
- csptri_(&uplo, &n, ap, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_csptri(VALUE mLapack){
- rb_define_module_function(mLapack, "csptri", rb_csptri, -1);
-}
diff --git a/csptrs.c b/csptrs.c
deleted file mode 100644
index c136cf8..0000000
--- a/csptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csptrs_(char *uplo, integer *n, integer *nrhs, complex *ap, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_csptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.csptrs( uplo, ap, ipiv, b)\n or\n NumRu::Lapack.csptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CSPTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- csptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_csptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "csptrs", rb_csptrs, -1);
-}
diff --git a/csrscl.c b/csrscl.c
deleted file mode 100644
index 136ee88..0000000
--- a/csrscl.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csrscl_(integer *n, real *sa, complex *sx, integer *incx);
-
-static VALUE
-rb_csrscl(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_sa;
- real sa;
- VALUE rb_sx;
- complex *sx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_sx_out__;
- complex *sx_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sx = NumRu::Lapack.csrscl( n, sa, sx, incx)\n or\n NumRu::Lapack.csrscl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* CSRSCL multiplies an n-element complex vector x by the real scalar\n* 1/a. This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) REAL\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) COMPLEX array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_sa = argv[1];
- rb_sx = argv[2];
- rb_incx = argv[3];
-
- sa = (real)NUM2DBL(rb_sa);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_sx))
- rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
- if (NA_RANK(rb_sx) != 1)
- rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sx) != (1+(n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
- if (NA_TYPE(rb_sx) != NA_SCOMPLEX)
- rb_sx = na_change_type(rb_sx, NA_SCOMPLEX);
- sx = NA_PTR_TYPE(rb_sx, complex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*abs(incx);
- rb_sx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- sx_out__ = NA_PTR_TYPE(rb_sx_out__, complex*);
- MEMCPY(sx_out__, sx, complex, NA_TOTAL(rb_sx));
- rb_sx = rb_sx_out__;
- sx = sx_out__;
-
- csrscl_(&n, &sa, sx, &incx);
-
- return rb_sx;
-}
-
-void
-init_lapack_csrscl(VALUE mLapack){
- rb_define_module_function(mLapack, "csrscl", rb_csrscl, -1);
-}
diff --git a/cstedc.c b/cstedc.c
deleted file mode 100644
index b675840..0000000
--- a/cstedc.c
+++ /dev/null
@@ -1,140 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cstedc_(char *compz, integer *n, real *d, real *e, complex *z, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_cstedc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_z;
- complex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_rwork;
- real *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, rwork, iwork, info, d, e, z = NumRu::Lapack.cstedc( compz, d, e, z, lwork, lrwork, liwork)\n or\n NumRu::Lapack.cstedc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See SLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original Hermitian matrix\n* also. On entry, Z contains the unitary matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n* Note that for COMPZ = 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be 1.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 3*N + 2*N*lg N + 3*N**2 ,\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1, LRWORK must be at least\n* 1 + 4*N + 2*N**2 .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LRWORK\n* need only be max(1,2*(N-1)).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If COMPZ = 'V' or N > 1, LIWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* If COMPZ = 'I' or N > 1, LIWORK must be at least\n* 3 + 5*N .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
- rb_lwork = argv[4];
- rb_lrwork = argv[5];
- rb_liwork = argv[6];
-
- compz = StringValueCStr(rb_compz)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of d");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- cstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_work, rb_rwork, rb_iwork, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_cstedc(VALUE mLapack){
- rb_define_module_function(mLapack, "cstedc", rb_cstedc, -1);
-}
diff --git a/cstegr.c b/cstegr.c
deleted file mode 100644
index 13662f7..0000000
--- a/cstegr.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cstegr_(char *jobz, char *range, integer *n, real *d, real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z, integer *ldz, integer *isuppz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_cstegr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.cstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.cstegr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* CSTEGR is a compatability wrapper around the improved CSTEMR routine.\n* See SSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : CSTEGR and CSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in CLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* CLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL CSTEMR\n* ..\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- il = NUM2INT(rb_il);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- cstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_cstegr(VALUE mLapack){
- rb_define_module_function(mLapack, "cstegr", rb_cstegr, -1);
-}
diff --git a/cstein.c b/cstein.c
deleted file mode 100644
index 1a1485d..0000000
--- a/cstein.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cstein_(integer *n, real *d, real *e, integer *m, real *w, integer *iblock, integer *isplit, complex *z, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_cstein(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_w;
- real *w;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_z;
- complex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldz;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.cstein( d, e, w, iblock, isplit)\n or\n NumRu::Lapack.cstein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n* Although the eigenvectors are real, they are stored in a complex\n* array, which may be passed to CUNMTR or CUPMTR for back\n* transformation to the eigenvectors of a complex Hermitian matrix\n* which was reduced to tridiagonal form.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, stored in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) REAL array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from SSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from SSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from SSTEBZ is expected here. )\n*\n* Z (output) COMPLEX array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n* The imaginary parts of the eigenvectors are set to zero.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_w = argv[2];
- rb_iblock = argv[3];
- rb_isplit = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- m = n;
- ldz = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = m;
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = m;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- work = ALLOC_N(real, (5*n));
- iwork = ALLOC_N(integer, (n));
-
- cstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_z, rb_ifail, rb_info);
-}
-
-void
-init_lapack_cstein(VALUE mLapack){
- rb_define_module_function(mLapack, "cstein", rb_cstein, -1);
-}
diff --git a/cstemr.c b/cstemr.c
deleted file mode 100644
index d71264e..0000000
--- a/cstemr.c
+++ /dev/null
@@ -1,162 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cstemr_(char *jobz, char *range, integer *n, real *d, real *e, real *vl, real *vu, integer *il, integer *iu, integer *m, real *w, complex *z, integer *ldz, integer *nzc, integer *isuppz, logical *tryrac, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_cstemr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_nzc;
- integer nzc;
- VALUE rb_tryrac;
- logical tryrac;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- complex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.cstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)\n or\n NumRu::Lapack.cstemr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.CSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n* real symmetric tridiagonal form.\n*\n* (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n* and potentially complex numbers on its off-diagonals. By applying a\n* similarity transform with an appropriate diagonal matrix\n* diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n* matrix can be transformed into a real symmetric matrix and complex\n* arithmetic can be entirely avoided.)\n*\n* While the eigenvectors of the real symmetric tridiagonal matrix are real,\n* the eigenvectors of original complex Hermitean matrix have complex entries\n* in general.\n* Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n* CSTEMR accepts complex workspace to facilitate interoperability\n* with CUNMTR or CUPMTR.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in CLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* CLARRV, respectively.\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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_nzc = argv[8];
- rb_tryrac = argv[9];
- rb_lwork = argv[10];
- rb_liwork = argv[11];
-
- vl = (real)NUM2DBL(rb_vl);
- nzc = NUM2INT(rb_nzc);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- il = NUM2INT(rb_il);
- tryrac = (rb_tryrac == Qtrue);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- cstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- rb_tryrac = tryrac ? Qtrue : Qfalse;
- return rb_ary_new3(10, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e, rb_tryrac);
-}
-
-void
-init_lapack_cstemr(VALUE mLapack){
- rb_define_module_function(mLapack, "cstemr", rb_cstemr, -1);
-}
diff --git a/csteqr.c b/csteqr.c
deleted file mode 100644
index e1ec3ee..0000000
--- a/csteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csteqr_(char *compz, integer *n, real *d, real *e, complex *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_csteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_z;
- complex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_z_out__;
- complex *z_out__;
- real *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.csteqr( compz, d, e, z)\n or\n NumRu::Lapack.csteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* Hermitian matrix. On entry, Z must contain the\n* unitary matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is unitarily similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(real, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
-
- csteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_csteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "csteqr", rb_csteqr, -1);
-}
diff --git a/csycon.c b/csycon.c
deleted file mode 100644
index a6fa04f..0000000
--- a/csycon.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csycon_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, real *anorm, real *rcond, complex *work, integer *info);
-
-static VALUE
-rb_csycon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.csycon( uplo, a, ipiv, anorm)\n or\n NumRu::Lapack.csycon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by CSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(complex, (2*n));
-
- csycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_csycon(VALUE mLapack){
- rb_define_module_function(mLapack, "csycon", rb_csycon, -1);
-}
diff --git a/csyconv.c b/csyconv.c
deleted file mode 100644
index 6fa57ae..0000000
--- a/csyconv.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csyconv_(char *uplo, char *way, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *info);
-
-static VALUE
-rb_csyconv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_way;
- char way;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info = NumRu::Lapack.csyconv( uplo, way, a, ipiv)\n or\n NumRu::Lapack.csyconv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYCONV convert A given by TRF into L and D and vice-versa.\n* Get Non-diag elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_way = argv[1];
- rb_a = argv[2];
- rb_ipiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- way = StringValueCStr(rb_way)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(complex, (MAX(1,n)));
-
- csyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_info;
-}
-
-void
-init_lapack_csyconv(VALUE mLapack){
- rb_define_module_function(mLapack, "csyconv", rb_csyconv, -1);
-}
diff --git a/csyequb.c b/csyequb.c
deleted file mode 100644
index a0fe1ed..0000000
--- a/csyequb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csyequb_(char *uplo, integer *n, complex *a, integer *lda, real *s, real *scond, real *amax, complex *work, integer *info);
-
-static VALUE
-rb_csyequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.csyequb( uplo, a)\n or\n NumRu::Lapack.csyequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) COMPLEX array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- work = ALLOC_N(complex, (3*n));
-
- csyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
-
- free(work);
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_csyequb(VALUE mLapack){
- rb_define_module_function(mLapack, "csyequb", rb_csyequb, -1);
-}
diff --git a/csymv.c b/csymv.c
deleted file mode 100644
index 60a0f8a..0000000
--- a/csymv.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csymv_(char *uplo, integer *n, complex *alpha, complex *a, integer *lda, complex *x, integer *incx, complex *beta, complex *y, integer *incy);
-
-static VALUE
-rb_csymv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_a;
- complex *a;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- complex beta;
- VALUE rb_y;
- complex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- complex *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.csymv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.csymv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CSYMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- beta.r = (real)NUM2DBL(rb_funcall(rb_beta, rb_intern("real"), 0));
- beta.i = (real)NUM2DBL(rb_funcall(rb_beta, rb_intern("imag"), 0));
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SCOMPLEX)
- rb_y = na_change_type(rb_y, NA_SCOMPLEX);
- y = NA_PTR_TYPE(rb_y, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, complex*);
- MEMCPY(y_out__, y, complex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- csymv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_csymv(VALUE mLapack){
- rb_define_module_function(mLapack, "csymv", rb_csymv, -1);
-}
diff --git a/csyr.c b/csyr.c
deleted file mode 100644
index 50cc82b..0000000
--- a/csyr.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csyr_(char *uplo, integer *n, complex *alpha, complex *x, integer *incx, complex *a, integer *lda);
-
-static VALUE
-rb_csyr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_x;
- complex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_a;
- complex *a;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.csyr( uplo, alpha, x, incx, a)\n or\n NumRu::Lapack.csyr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n* Purpose\n* =======\n*\n* CSYR performs the symmetric rank 1 operation\n*\n* A := alpha*x*( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* A (input/output) COMPLEX array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced. On exit, the\n* upper triangular part of the array A is overwritten by the\n* upper triangular part of the updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced. On exit, the\n* lower triangular part of the array A is overwritten by the\n* lower triangular part of the updated matrix.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- csyr_(&uplo, &n, &alpha, x, &incx, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_csyr(VALUE mLapack){
- rb_define_module_function(mLapack, "csyr", rb_csyr, -1);
-}
diff --git a/csyrfs.c b/csyrfs.c
deleted file mode 100644
index 5c4c8f7..0000000
--- a/csyrfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csyrfs_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_csyrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- complex *x_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.csyrfs( uplo, a, af, ipiv, b, x)\n or\n NumRu::Lapack.csyrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CSYTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- csyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_csyrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "csyrfs", rb_csyrfs, -1);
-}
diff --git a/csyrfsx.c b/csyrfsx.c
deleted file mode 100644
index b6d493c..0000000
--- a/csyrfsx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csyrfsx_(char *uplo, char *equed, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_csyrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_x_out__;
- complex *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.csyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)\n or\n NumRu::Lapack.csyrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
- rb_params = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, complex*);
- MEMCPY(x_out__, x, complex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- csyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_csyrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "csyrfsx", rb_csyrfsx, -1);
-}
diff --git a/csysv.c b/csysv.c
deleted file mode 100644
index ddf45a8..0000000
--- a/csysv.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csysv_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_csysv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.csysv( uplo, a, b, lwork)\n or\n NumRu::Lapack.csysv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* CSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSYTRF, CSYTRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- csysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_csysv(VALUE mLapack){
- rb_define_module_function(mLapack, "csysv", rb_csysv, -1);
-}
diff --git a/csysvx.c b/csysvx.c
deleted file mode 100644
index 26a6564..0000000
--- a/csysvx.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csysvx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr, complex *work, integer *lwork, real *rwork, integer *info);
-
-static VALUE
-rb_csysvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.csysvx( fact, uplo, a, af, ipiv, b, lwork)\n or\n NumRu::Lapack.csysvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CSYTRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for CSYTRF.\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* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- lwork = NUM2INT(rb_lwork);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- rwork = ALLOC_N(real, (n));
-
- csysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_af, rb_ipiv);
-}
-
-void
-init_lapack_csysvx(VALUE mLapack){
- rb_define_module_function(mLapack, "csysvx", rb_csysvx, -1);
-}
diff --git a/csysvxx.c b/csysvxx.c
deleted file mode 100644
index e0cf6f8..0000000
--- a/csysvxx.c
+++ /dev/null
@@ -1,239 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csysvxx_(char *fact, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_csysvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_af;
- complex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- complex *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- complex *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_af_out__;
- complex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.csysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)\n or\n NumRu::Lapack.csysvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
- rb_params = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SCOMPLEX)
- rb_af = na_change_type(rb_af, NA_SCOMPLEX);
- af = NA_PTR_TYPE(rb_af, complex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, complex*);
- MEMCPY(af_out__, af, complex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- csysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(14, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_csysvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "csysvxx", rb_csysvxx, -1);
-}
diff --git a/csyswapr.c b/csyswapr.c
deleted file mode 100644
index d30cc26..0000000
--- a/csyswapr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csyswapr_(char *uplo, integer *n, complex *a, integer *i1, integer *i2);
-
-static VALUE
-rb_csyswapr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_i1;
- integer i1;
- VALUE rb_i2;
- integer i2;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.csyswapr( uplo, a, i1, i2)\n or\n NumRu::Lapack.csyswapr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* CSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n COMPLEX TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSWAP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_i1 = argv[2];
- rb_i2 = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- i1 = NUM2INT(rb_i1);
- i2 = NUM2INT(rb_i2);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- csyswapr_(&uplo, &n, a, &i1, &i2);
-
- return rb_a;
-}
-
-void
-init_lapack_csyswapr(VALUE mLapack){
- rb_define_module_function(mLapack, "csyswapr", rb_csyswapr, -1);
-}
diff --git a/csytf2.c b/csytf2.c
deleted file mode 100644
index 67da865..0000000
--- a/csytf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csytf2_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_csytf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.csytf2( uplo, a)\n or\n NumRu::Lapack.csytf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CSYTF2 computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.209 and l.377\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- csytf2_(&uplo, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_csytf2(VALUE mLapack){
- rb_define_module_function(mLapack, "csytf2", rb_csytf2, -1);
-}
diff --git a/csytrf.c b/csytrf.c
deleted file mode 100644
index ce4137f..0000000
--- a/csytrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csytrf_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_csytrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.csytrf( uplo, a, lwork)\n or\n NumRu::Lapack.csytrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRF computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CLASYF, CSYTF2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- csytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_csytrf(VALUE mLapack){
- rb_define_module_function(mLapack, "csytrf", rb_csytrf, -1);
-}
diff --git a/csytri.c b/csytri.c
deleted file mode 100644
index e1569bc..0000000
--- a/csytri.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csytri_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *info);
-
-static VALUE
-rb_csytri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.csytri( uplo, a, ipiv)\n or\n NumRu::Lapack.csytri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRI computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* CSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (2*n));
-
- csytri_(&uplo, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_csytri(VALUE mLapack){
- rb_define_module_function(mLapack, "csytri", rb_csytri, -1);
-}
diff --git a/csytri2.c b/csytri2.c
deleted file mode 100644
index f1ce887..0000000
--- a/csytri2.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csytri2_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_csytri2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- integer c__1;
- integer nb;
- integer c__m1;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.csytri2( uplo, a, ipiv, lwork)\n or\n NumRu::Lapack.csytri2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* CSYTRF. CSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling CSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CSYTRI2X\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- c__1 = 1;
- uplo = StringValueCStr(rb_uplo)[0];
- c__m1 = -1;
- lwork = NUM2INT(rb_lwork);
- nb = ilaenv_(&c__1, "CSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, ((n+nb+1)*(nb+3)));
-
- csytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_csytri2(VALUE mLapack){
- rb_define_module_function(mLapack, "csytri2", rb_csytri2, -1);
-}
diff --git a/csytri2x.c b/csytri2x.c
deleted file mode 100644
index f1e5245..0000000
--- a/csytri2x.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csytri2x_(char *uplo, integer *n, complex *a, integer *lda, integer *ipiv, complex *work, integer *nb, integer *info);
-
-static VALUE
-rb_csytri2x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_nb;
- integer nb;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.csytri2x( uplo, a, ipiv, nb)\n or\n NumRu::Lapack.csytri2x # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRI2X computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* CSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_nb = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- nb = NUM2INT(rb_nb);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n+nb+1)*(nb+3));
-
- csytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_csytri2x(VALUE mLapack){
- rb_define_module_function(mLapack, "csytri2x", rb_csytri2x, -1);
-}
diff --git a/csytrs.c b/csytrs.c
deleted file mode 100644
index e1a9551..0000000
--- a/csytrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csytrs_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_csytrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.csytrs( uplo, a, ipiv, b)\n or\n NumRu::Lapack.csytrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- csytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_csytrs(VALUE mLapack){
- rb_define_module_function(mLapack, "csytrs", rb_csytrs, -1);
-}
diff --git a/csytrs2.c b/csytrs2.c
deleted file mode 100644
index 8cc8d8b..0000000
--- a/csytrs2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID csytrs2_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, complex *work, integer *info);
-
-static VALUE
-rb_csytrs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.csytrs2( uplo, a, ipiv, b)\n or\n NumRu::Lapack.csytrs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRS2 solves a system of linear equations A*X = B with a COMPLEX\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) COMPLEX 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(complex, (n));
-
- csytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_csytrs2(VALUE mLapack){
- rb_define_module_function(mLapack, "csytrs2", rb_csytrs2, -1);
-}
diff --git a/ctbcon.c b/ctbcon.c
deleted file mode 100644
index fba3b82..0000000
--- a/ctbcon.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctbcon_(char *norm, char *uplo, char *diag, integer *n, integer *kd, complex *ab, integer *ldab, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.ctbcon( norm, uplo, diag, kd, ab)\n or\n NumRu::Lapack.ctbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- ctbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_ctbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "ctbcon", rb_ctbcon, -1);
-}
diff --git a/ctbrfs.c b/ctbrfs.c
deleted file mode 100644
index 5eb4ded..0000000
--- a/ctbrfs.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctbrfs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.ctbrfs( uplo, trans, diag, kd, ab, b, x)\n or\n NumRu::Lapack.ctbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by CTBTRS or some other\n* means before entering this routine. CTBRFS 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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- ctbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_ctbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ctbrfs", rb_ctbrfs, -1);
-}
diff --git a/ctbtrs.c b/ctbtrs.c
deleted file mode 100644
index dfa0100..0000000
--- a/ctbtrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctbtrs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ctbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- complex *ab;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ctbtrs( uplo, trans, diag, kd, ab, b)\n or\n NumRu::Lapack.ctbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CTBTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by-NRHS matrix. A check is made to verify that A is nonsingular.\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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_SCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ctbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ctbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ctbtrs", rb_ctbtrs, -1);
-}
diff --git a/ctfsm.c b/ctfsm.c
deleted file mode 100644
index e545895..0000000
--- a/ctfsm.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctfsm_(char *transr, char *side, char *uplo, char *trans, char *diag, integer *m, integer *n, complex *alpha, complex *a, complex *b, integer *ldb);
-
-static VALUE
-rb_ctfsm(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- complex alpha;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldb;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.ctfsm( transr, side, uplo, trans, diag, m, alpha, a, b)\n or\n NumRu::Lapack.ctfsm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* CTFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = conjg( A' ).\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'C' or 'c' op( A ) = conjg( A' ).\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension (N*(N+1)/2)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_side = argv[1];
- rb_uplo = argv[2];
- rb_trans = argv[3];
- rb_diag = argv[4];
- rb_m = argv[5];
- rb_alpha = argv[6];
- rb_a = argv[7];
- rb_b = argv[8];
-
- transr = StringValueCStr(rb_transr)[0];
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = (real)NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- trans = StringValueCStr(rb_trans)[0];
- diag = StringValueCStr(rb_diag)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (8th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ctfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_ctfsm(VALUE mLapack){
- rb_define_module_function(mLapack, "ctfsm", rb_ctfsm, -1);
-}
diff --git a/ctftri.c b/ctftri.c
deleted file mode 100644
index c232a42..0000000
--- a/ctftri.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctftri_(char *transr, char *uplo, char *diag, integer *n, complex *a, integer *info);
-
-static VALUE
-rb_ctftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ctftri( transr, uplo, diag, n, a)\n or\n NumRu::Lapack.ctftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* CTFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\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* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the triangular matrix A in RFP format. RFP format\n* is described by TRANSR, UPLO, and N as follows: If TRANSR =\n* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ctftri_(&transr, &uplo, &diag, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ctftri(VALUE mLapack){
- rb_define_module_function(mLapack, "ctftri", rb_ctftri, -1);
-}
diff --git a/ctfttp.c b/ctfttp.c
deleted file mode 100644
index 62d37e8..0000000
--- a/ctfttp.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctfttp_(char *transr, char *uplo, integer *n, complex *arf, complex *ap, integer *info);
-
-static VALUE
-rb_ctfttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_arf;
- complex *arf;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.ctfttp( transr, uplo, n, arf)\n or\n NumRu::Lapack.ctfttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* CTFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_arf = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_arf) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_arf) != NA_SCOMPLEX)
- rb_arf = na_change_type(rb_arf, NA_SCOMPLEX);
- arf = NA_PTR_TYPE(rb_arf, complex*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_ap = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, complex*);
-
- ctfttp_(&transr, &uplo, &n, arf, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_ctfttp(VALUE mLapack){
- rb_define_module_function(mLapack, "ctfttp", rb_ctfttp, -1);
-}
diff --git a/ctfttr.c b/ctfttr.c
deleted file mode 100644
index c4eea9e..0000000
--- a/ctfttr.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctfttr_(char *transr, char *uplo, integer *n, complex *arf, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ctfttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_arf;
- complex *arf;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
-
- integer ldarf;
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.ctfttr( transr, uplo, arf)\n or\n NumRu::Lapack.ctfttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* A (output) COMPLEX array, dimension ( LDA, N ) \n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_arf = argv[2];
-
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
- ldarf = NA_SHAPE0(rb_arf);
- if (NA_TYPE(rb_arf) != NA_SCOMPLEX)
- rb_arf = na_change_type(rb_arf, NA_SCOMPLEX);
- arf = NA_PTR_TYPE(rb_arf, complex*);
- n = ((int)sqrtf(ldarf*8+1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, complex*);
-
- ctfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_ctfttr(VALUE mLapack){
- rb_define_module_function(mLapack, "ctfttr", rb_ctfttr, -1);
-}
diff --git a/ctgevc.c b/ctgevc.c
deleted file mode 100644
index 01be016..0000000
--- a/ctgevc.c
+++ /dev/null
@@ -1,137 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgevc_(char *side, char *howmny, logical *select, integer *n, complex *s, integer *lds, complex *p, integer *ldp, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctgevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_s;
- complex *s;
- VALUE rb_p;
- complex *p;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_vl_out__;
- complex *vl_out__;
- VALUE rb_vr_out__;
- complex *vr_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer lds;
- integer ldp;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, vl, vr = NumRu::Lapack.ctgevc( side, howmny, select, s, p, vl, vr)\n or\n NumRu::Lapack.ctgevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of complex matrices (S,P), where S and P are upper triangular.\n* Matrix pairs of this type are produced by the generalized Schur\n* factorization of a complex matrix pair (A,B):\n* \n* A = Q*S*Z**H, B = Q*P*Z**H\n* \n* as computed by CGGHRD + CHGEQZ.\n* \n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal elements of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the unitary factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. The eigenvector corresponding to the j-th\n* eigenvalue is computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) COMPLEX array, dimension (LDS,N)\n* The upper triangular matrix S from a generalized Schur\n* factorization, as computed by CHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) COMPLEX array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by CHGEQZ. P must have real\n* diagonal elements.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) COMPLEX array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q\n* of left Schur vectors returned by CHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n*\n* VR (input/output) COMPLEX array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Z\n* of right Schur vectors returned by CHGEQZ).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Z*X;\n* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VR, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one column.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_s = argv[3];
- rb_p = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_SCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_p))
- rb_raise(rb_eArgError, "p (5th argument) must be NArray");
- if (NA_RANK(rb_p) != 2)
- rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_p);
- ldp = NA_SHAPE0(rb_p);
- if (NA_TYPE(rb_p) != NA_SCOMPLEX)
- rb_p = na_change_type(rb_p, NA_SCOMPLEX);
- p = NA_PTR_TYPE(rb_p, complex*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_SCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, complex*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 2)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 1 of p");
- lds = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SCOMPLEX)
- rb_s = na_change_type(rb_s, NA_SCOMPLEX);
- s = NA_PTR_TYPE(rb_s, complex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of p");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, complex*);
- MEMCPY(vl_out__, vl, complex, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, complex*);
- MEMCPY(vr_out__, vr, complex, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (2*n));
-
- ctgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_m, rb_info, rb_vl, rb_vr);
-}
-
-void
-init_lapack_ctgevc(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgevc", rb_ctgevc, -1);
-}
diff --git a/ctgex2.c b/ctgex2.c
deleted file mode 100644
index 1a2f689..0000000
--- a/ctgex2.c
+++ /dev/null
@@ -1,152 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgex2_(logical *wantq, logical *wantz, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *q, integer *ldq, complex *z, integer *ldz, integer *j1, integer *info);
-
-static VALUE
-rb_ctgex2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_q;
- complex *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_z;
- complex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_j1;
- integer j1;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.ctgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1)\n or\n NumRu::Lapack.ctgex2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n* Purpose\n* =======\n*\n* CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n* in an upper triangular matrix pair (A, B) by an unitary equivalence\n* transformation.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX arrays, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX arrays, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDZ,N)\n* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n* the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n* the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11).\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned.\n*\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n* Department of Computing Science, Umea University, S-901 87 Umea,\n* Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n* Numerical Algorithms, 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_ldq = argv[5];
- rb_z = argv[6];
- rb_ldz = argv[7];
- rb_j1 = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- wantz = (rb_wantz == Qtrue);
- ldz = NUM2INT(rb_ldz);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- j1 = NUM2INT(rb_j1);
- wantq = (rb_wantq == Qtrue);
- ldq = NUM2INT(rb_ldq);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != (wantq ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", wantq ? n : 0);
- if (NA_SHAPE0(rb_q) != (wantq ? ldq : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", wantq ? ldq : 0);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantq ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantq ? n : 0);
- if (NA_SHAPE0(rb_z) != (wantq ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantq ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = wantq ? ldq : 0;
- shape[1] = wantq ? n : 0;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = wantq ? ldz : 0;
- shape[1] = wantq ? n : 0;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- ctgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_ctgex2(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgex2", rb_ctgex2, -1);
-}
diff --git a/ctgexc.c b/ctgexc.c
deleted file mode 100644
index ec580cd..0000000
--- a/ctgexc.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgexc_(logical *wantq, logical *wantz, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *q, integer *ldq, complex *z, integer *ldz, integer *ifst, integer *ilst, integer *info);
-
-static VALUE
-rb_ctgexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_q;
- complex *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_z;
- complex *z;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z, ilst = NumRu::Lapack.ctgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst)\n or\n NumRu::Lapack.ctgexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* CTGEXC reorders the generalized Schur decomposition of a complex\n* matrix pair (A,B), using an unitary equivalence transformation\n* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n* row index IFST is moved to row ILST.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the upper triangular matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the upper triangular matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the unitary matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the unitary matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* <0: if INFO = -i, the i-th argument had an illegal value.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\n*\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER HERE\n* ..\n* .. External Subroutines ..\n EXTERNAL CTGEX2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_ldq = argv[5];
- rb_z = argv[6];
- rb_ifst = argv[7];
- rb_ilst = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- ldq = NUM2INT(rb_ldq);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- if (NA_SHAPE0(rb_q) != ldz)
- rb_raise(rb_eRuntimeError, "shape 0 of q must be the same as shape 0 of z");
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- ctgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, &info);
-
- rb_info = INT2NUM(info);
- rb_ilst = INT2NUM(ilst);
- return rb_ary_new3(6, rb_info, rb_a, rb_b, rb_q, rb_z, rb_ilst);
-}
-
-void
-init_lapack_ctgexc(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgexc", rb_ctgexc, -1);
-}
diff --git a/ctgsen.c b/ctgsen.c
deleted file mode 100644
index 999fce7..0000000
--- a/ctgsen.c
+++ /dev/null
@@ -1,213 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgsen_(integer *ijob, logical *wantq, logical *wantz, logical *select, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *beta, complex *q, integer *ldq, complex *z, integer *ldz, integer *m, real *pl, real *pr, real *dif, complex *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_ctgsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_q;
- complex *q;
- VALUE rb_z;
- complex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_alpha;
- complex *alpha;
- VALUE rb_beta;
- complex *beta;
- VALUE rb_m;
- integer m;
- VALUE rb_pl;
- real pl;
- VALUE rb_pr;
- real pr;
- VALUE rb_dif;
- real *dif;
- VALUE rb_work;
- complex *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- VALUE rb_z_out__;
- complex *z_out__;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ctgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)\n or\n NumRu::Lapack.ctgsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTGSEN reorders the generalized Schur decomposition of a complex\n* matrix pair (A, B) (in terms of an unitary equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the pair (A,B). The leading\n* columns of Q and Z form unitary bases of the corresponding left and\n* right eigenspaces (deflating subspaces). (A, B) must be in\n* generalized Schur canonical form, that is, A and B are both upper\n* triangular.\n*\n* CTGSEN also computes the generalized eigenvalues\n*\n* w(j)= ALPHA(j) / BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, the routine computes estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) integer\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select an eigenvalue w(j), SELECT(j) must be set to\n* .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension(LDA,N)\n* On entry, the upper triangular matrix A, in generalized\n* Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, in generalized\n* Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* The diagonal elements of A and B, respectively,\n* when the pair (A,B) has been reduced to generalized Schur\n* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized\n* eigenvalues.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right\n* eigenspaces, (deflating subspaces) 0 <= M <= N.\n*\n* PL (output) REAL\n* PR (output) REAL\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspace with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3 PL, PR are not referenced.\n*\n* DIF (output) REAL array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl, computed using reversed\n* communication with CLACN2.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\n*\n* WORK (workspace/output) COMPLEX 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, 2 or 4, LWORK >= 2*M*(N-M)\n* If IJOB = 3 or 5, LWORK >= 4*M*(N-M)\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+2;\n* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n*\n\n* Further Details\n* ===============\n*\n* CTGSEN first collects the selected eigenvalues by computing unitary\n* U and W that move them to the top left corner of (A, B). In other\n* words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the conjugate transpose of U. The first\n* n1 columns of U and W span the specified pair of left and right\n* eigenspaces (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see CLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF\n* (IJOB = 2 will be used)). See CTGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_ijob = argv[0];
- rb_wantq = argv[1];
- rb_wantz = argv[2];
- rb_select = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
- rb_lwork = argv[8];
- rb_liwork = argv[9];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- liwork = NUM2INT(rb_liwork);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SCOMPLEX)
- rb_z = na_change_type(rb_z, NA_SCOMPLEX);
- z = NA_PTR_TYPE(rb_z, complex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, complex*);
- {
- int shape[1];
- shape[0] = 2;
- rb_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, real*);
- {
- int shape[1];
- shape[0] = ijob==0 ? 0 : MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[1];
- shape[0] = ijob==0 ? 0 : MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, complex*);
- MEMCPY(z_out__, z, complex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- ctgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alpha, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_pl = rb_float_new((double)pl);
- rb_pr = rb_float_new((double)pr);
- rb_info = INT2NUM(info);
- return rb_ary_new3(13, rb_alpha, rb_beta, rb_m, rb_pl, rb_pr, rb_dif, rb_work, rb_iwork, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_ctgsen(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgsen", rb_ctgsen, -1);
-}
diff --git a/ctgsja.c b/ctgsja.c
deleted file mode 100644
index 50e3c03..0000000
--- a/ctgsja.c
+++ /dev/null
@@ -1,208 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgsja_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, integer *k, integer *l, complex *a, integer *lda, complex *b, integer *ldb, real *tola, real *tolb, real *alpha, real *beta, complex *u, integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, complex *work, integer *ncycle, integer *info);
-
-static VALUE
-rb_ctgsja(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_tola;
- real tola;
- VALUE rb_tolb;
- real tolb;
- VALUE rb_u;
- complex *u;
- VALUE rb_v;
- complex *v;
- VALUE rb_q;
- complex *q;
- VALUE rb_alpha;
- real *alpha;
- VALUE rb_beta;
- real *beta;
- VALUE rb_ncycle;
- integer ncycle;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- VALUE rb_b_out__;
- complex *b_out__;
- VALUE rb_u_out__;
- complex *u_out__;
- VALUE rb_v_out__;
- complex *v_out__;
- VALUE rb_q_out__;
- complex *q_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ctgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)\n or\n NumRu::Lapack.ctgsja # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* CTGSJA computes the generalized singular value decomposition (GSVD)\n* of two complex upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine CGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are unitary matrices, Z' denotes the conjugate\n* transpose of Z, R is a nonsingular upper triangular matrix, and D1\n* and D2 are ``diagonal'' matrices, which are of the following\n* structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the unitary transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain a unitary matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* unitary matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain a unitary matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* unitary matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain a unitary matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by CTGSJA.\n* See Further Details.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) COMPLEX array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the unitary matrix returned by CGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the unitary matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) COMPLEX array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the unitary matrix returned by CGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the unitary matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the unitary matrix returned by CGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the unitary matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n* transpose of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_k = argv[3];
- rb_l = argv[4];
- rb_a = argv[5];
- rb_b = argv[6];
- rb_tola = argv[7];
- rb_tolb = argv[8];
- rb_u = argv[9];
- rb_v = argv[10];
- rb_q = argv[11];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (11th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
- p = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SCOMPLEX)
- rb_v = na_change_type(rb_v, NA_SCOMPLEX);
- v = NA_PTR_TYPE(rb_v, complex*);
- k = NUM2INT(rb_k);
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- l = NUM2INT(rb_l);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (12th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- tola = (real)NUM2DBL(rb_tola);
- tolb = (real)NUM2DBL(rb_tolb);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (10th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
- m = NA_SHAPE1(rb_u);
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_SCOMPLEX)
- rb_u = na_change_type(rb_u, NA_SCOMPLEX);
- u = NA_PTR_TYPE(rb_u, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, complex*);
- MEMCPY(u_out__, u, complex, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, complex*);
- MEMCPY(v_out__, v, complex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(complex, (2*n));
-
- ctgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
-
- free(work);
- rb_ncycle = INT2NUM(ncycle);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_ncycle, rb_info, rb_a, rb_b, rb_u, rb_v, rb_q);
-}
-
-void
-init_lapack_ctgsja(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgsja", rb_ctgsja, -1);
-}
diff --git a/ctgsna.c b/ctgsna.c
deleted file mode 100644
index 60a332b..0000000
--- a/ctgsna.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgsna_(char *job, char *howmny, logical *select, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real *dif, integer *mm, integer *m, complex *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_ctgsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_dif;
- real *dif;
- VALUE rb_m;
- integer m;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- integer *iwork;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.ctgsna( job, howmny, select, a, b, vl, vr, lwork)\n or\n NumRu::Lapack.ctgsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B).\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the corresponding j-th eigenvalue and/or eigenvector,\n* SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The upper triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A, B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) COMPLEX array, dimension (LDVL,M)\n* IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by CTGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; and\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX array, dimension (LDVR,M)\n* IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VR, as returned by CTGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1;\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array.\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If the eigenvalues cannot be reordered to compute DIF(j),\n* DIF(j) is set to 0; this can only occur when the true value\n* would be very small anyway.\n* For each eigenvalue/vector specified by SELECT, DIF stores\n* a Frobenius norm-based estimate of Difl.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected eigenvalue\n* one element is used. If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n* eigenvalue w = (a, b) is defined as\n*\n* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u. The pair\n* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n* matrix pair (A, B). If both a and b equal zero, then (A,B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows. Suppose\n*\n* (A, B) = ( a * ) ( b * ) 1\n* ( 0 A22 ),( 0 B22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(I) is\n*\n* Difl[(a, b), (A22, B22)] = sigma-min( Zl )\n*\n* where sigma-min(Zl) denotes the smallest singular value of\n*\n* Zl = [ kron(a, In-1) -kron(1, A22) ]\n* [ kron(b, In-1) -kron(1, B22) ].\n*\n* Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n* transpose of X. kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* We approximate the smallest singular value of Zl with an upper\n* bound. This is done by CLATDF.\n*\n* An approximate error bound for a computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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.\n* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
- rb_lwork = argv[7];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_SCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, complex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_SCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, complex*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = mm;
- rb_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n+2));
-
- ctgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_s, rb_dif, rb_m, rb_work, rb_info);
-}
-
-void
-init_lapack_ctgsna(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgsna", rb_ctgsna, -1);
-}
diff --git a/ctgsy2.c b/ctgsy2.c
deleted file mode 100644
index 2583fc7..0000000
--- a/ctgsy2.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgsy2_(char *trans, integer *ijob, integer *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *c, integer *ldc, complex *d, integer *ldd, complex *e, integer *lde, complex *f, integer *ldf, real *scale, real *rdsum, real *rdscal, integer *info);
-
-static VALUE
-rb_ctgsy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_c;
- complex *c;
- VALUE rb_d;
- complex *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_f;
- complex *f;
- VALUE rb_rdsum;
- real rdsum;
- VALUE rb_rdscal;
- real rdscal;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- VALUE rb_f_out__;
- complex *f_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ctgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)\n or\n NumRu::Lapack.ctgsy2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n* Purpose\n* =======\n*\n* CTGSY2 solves the generalized Sylvester equation\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F\n*\n* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n* (i.e., (A,D) and (B,E) in generalized Schur form).\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 solving equation (1) corresponds to solve\n* Zx = scale * b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n* is solved for, 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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* = sigma_min(Z) using reverse communicaton with CLACON.\n*\n* CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n* CTGSYL.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* =2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (SGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) COMPLEX array, dimension (LDA, M)\n* On entry, A contains an upper triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) COMPLEX array, dimension (LDB, N)\n* On entry, B contains an upper triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1, N).\n*\n* C (input/output) COMPLEX array, dimension (LDC, N)\n* On entry, C contains the right-hand-side of the first matrix\n* equation in (1).\n* On exit, if IJOB = 0, C has been overwritten by the solution\n* R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) COMPLEX array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) COMPLEX array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix E. LDE >= max(1, N).\n*\n* F (input/output) COMPLEX array, dimension (LDF, N)\n* On entry, F contains the right-hand-side of the second matrix\n* equation in (1).\n* On exit, if IJOB = 0, F has been overwritten by the solution\n* L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) REAL\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0.\n* Normally, SCALE = 1.\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by CTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when CTGSY2 is called by\n* CTGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when CTGSY2 is called by\n* CTGSYL.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, input argument number i is illegal.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_rdsum = argv[8];
- rb_rdscal = argv[9];
-
- rdscal = (real)NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- rdsum = (real)NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_SCOMPLEX)
- rb_f = na_change_type(rb_f, NA_SCOMPLEX);
- f = NA_PTR_TYPE(rb_f, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, complex*);
- MEMCPY(f_out__, f, complex, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
-
- ctgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(6, rb_scale, rb_info, rb_c, rb_f, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_ctgsy2(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgsy2", rb_ctgsy2, -1);
-}
diff --git a/ctgsyl.c b/ctgsyl.c
deleted file mode 100644
index 494fe7c..0000000
--- a/ctgsyl.c
+++ /dev/null
@@ -1,165 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctgsyl_(char *trans, integer *ijob, integer *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *c, integer *ldc, complex *d, integer *ldd, complex *e, integer *lde, complex *f, integer *ldf, real *scale, real *dif, complex *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_ctgsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_c;
- complex *c;
- VALUE rb_d;
- complex *d;
- VALUE rb_e;
- complex *e;
- VALUE rb_f;
- complex *f;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_scale;
- real scale;
- VALUE rb_dif;
- real dif;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- VALUE rb_f_out__;
- complex *f_out__;
- integer *iwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, dif, work, info, c, f = NumRu::Lapack.ctgsyl( trans, ijob, a, b, c, d, e, f, lwork)\n or\n NumRu::Lapack.ctgsyl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSYL( 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* CTGSYL 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 complex entries. A, B, D and E are upper\n* triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n* is an output scaling factor chosen to avoid overflow.\n*\n* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n* is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Here Ix is the identity matrix of size x and X' is the conjugate\n* transpose of X. Kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n* is solved for, 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 = 'C') 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 CLACON.\n*\n* If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of\n* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n* reciprocal of the smallest singular value of Z.\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* = 'C': solve the \"conjugate 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 is used).\n* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n* (CGECON on sub-systems is used).\n* Not referenced if TRANS = 'C'.\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) COMPLEX array, dimension (LDA, M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, M).\n*\n* B (input) COMPLEX array, dimension (LDB, N)\n* The upper 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) COMPLEX 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 = 'C', DIF is not referenced.\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,\n* D and E have not been changed. If SCALE = 0, R and L will\n* hold the solutions to the homogenious system with C = F = 0.\n*\n* WORK (workspace/output) COMPLEX 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+2)\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 very close\n* 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 CCOPY by calls to CLASET.\n* Sven Hammarling, 1/5/02.\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_lwork = argv[8];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SCOMPLEX)
- rb_d = na_change_type(rb_d, NA_SCOMPLEX);
- d = NA_PTR_TYPE(rb_d, complex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_SCOMPLEX)
- rb_e = na_change_type(rb_e, NA_SCOMPLEX);
- e = NA_PTR_TYPE(rb_e, complex*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_SCOMPLEX)
- rb_f = na_change_type(rb_f, NA_SCOMPLEX);
- f = NA_PTR_TYPE(rb_f, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, complex*);
- MEMCPY(f_out__, f, complex, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
- iwork = ALLOC_N(integer, (m+n+2));
-
- ctgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_scale = rb_float_new((double)scale);
- rb_dif = rb_float_new((double)dif);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_scale, rb_dif, rb_work, rb_info, rb_c, rb_f);
-}
-
-void
-init_lapack_ctgsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "ctgsyl", rb_ctgsyl, -1);
-}
diff --git a/ctpcon.c b/ctpcon.c
deleted file mode 100644
index e784794..0000000
--- a/ctpcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctpcon_(char *norm, char *uplo, char *diag, integer *n, complex *ap, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctpcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.ctpcon( norm, uplo, diag, ap)\n or\n NumRu::Lapack.ctpcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTPCON 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- ctpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_ctpcon(VALUE mLapack){
- rb_define_module_function(mLapack, "ctpcon", rb_ctpcon, -1);
-}
diff --git a/ctprfs.c b/ctprfs.c
deleted file mode 100644
index fb7ec29..0000000
--- a/ctprfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.ctprfs( uplo, trans, diag, ap, b, x)\n or\n NumRu::Lapack.ctprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTPRFS 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 CTPTRS or some other\n* means before entering this routine. CTPRFS 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)\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) COMPLEX 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* B (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- ctprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_ctprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ctprfs", rb_ctprfs, -1);
-}
diff --git a/ctptri.c b/ctptri.c
deleted file mode 100644
index a79a8e5..0000000
--- a/ctptri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctptri_(char *uplo, char *diag, integer *n, complex *ap, integer *info);
-
-static VALUE
-rb_ctptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- complex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.ctptri( uplo, diag, n, ap)\n or\n NumRu::Lapack.ctptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* CTPTRI computes the inverse of a complex 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) COMPLEX 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, complex*);
- MEMCPY(ap_out__, ap, complex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- ctptri_(&uplo, &diag, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_ctptri(VALUE mLapack){
- rb_define_module_function(mLapack, "ctptri", rb_ctptri, -1);
-}
diff --git a/ctptrs.c b/ctptrs.c
deleted file mode 100644
index 3edc694..0000000
--- a/ctptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctptrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ctptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ctptrs( uplo, trans, diag, n, ap, b)\n or\n NumRu::Lapack.ctptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CTPTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* AP (input) COMPLEX 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*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ctptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ctptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ctptrs", rb_ctptrs, -1);
-}
diff --git a/ctpttf.c b/ctpttf.c
deleted file mode 100644
index 50d8694..0000000
--- a/ctpttf.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctpttf_(char *transr, char *uplo, integer *n, complex *ap, complex *arf, integer *info);
-
-static VALUE
-rb_ctpttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_arf;
- complex *arf;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ctpttf( transr, uplo, n, ap)\n or\n NumRu::Lapack.ctpttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* CTPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'C': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_arf = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, complex*);
-
- ctpttf_(&transr, &uplo, &n, ap, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_ctpttf(VALUE mLapack){
- rb_define_module_function(mLapack, "ctpttf", rb_ctpttf, -1);
-}
diff --git a/ctpttr.c b/ctpttr.c
deleted file mode 100644
index 137f8ad..0000000
--- a/ctpttr.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctpttr_(char *uplo, integer *n, complex *ap, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ctpttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.ctpttr( uplo, ap)\n or\n NumRu::Lapack.ctpttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) COMPLEX array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -i, the i-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, complex*);
-
- ctpttr_(&uplo, &n, ap, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_ctpttr(VALUE mLapack){
- rb_define_module_function(mLapack, "ctpttr", rb_ctpttr, -1);
-}
diff --git a/ctrcon.c b/ctrcon.c
deleted file mode 100644
index 8b3f6f9..0000000
--- a/ctrcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrcon_(char *norm, char *uplo, char *diag, integer *n, complex *a, integer *lda, real *rcond, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctrcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- complex *a;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.ctrcon( norm, uplo, diag, a)\n or\n NumRu::Lapack.ctrcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRCON estimates the reciprocal of the condition number of a\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* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- ctrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_ctrcon(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrcon", rb_ctrcon, -1);
-}
diff --git a/ctrevc.c b/ctrevc.c
deleted file mode 100644
index bbae65d..0000000
--- a/ctrevc.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrevc_(char *side, char *howmny, logical *select, integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, complex *vr, integer *ldvr, integer *mm, integer *m, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctrevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- complex *t;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- complex *t_out__;
- VALUE rb_vl_out__;
- complex *vl_out__;
- VALUE rb_vr_out__;
- complex *vr_out__;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, t, vl, vr = NumRu::Lapack.ctrevc( side, howmny, select, t, vl, vr)\n or\n NumRu::Lapack.ctrevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTREVC computes some or all of the right and/or left eigenvectors of\n* a complex upper triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of the vector y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the unitary factor that reduces a matrix A to\n* Schur form T, then Q*X and Q*Y are the matrices of right and left\n* eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed using the matrices supplied in\n* VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* The eigenvector corresponding to the j-th eigenvalue is\n* computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX array, dimension (LDT,N)\n* The upper triangular matrix T. T is modified, but restored\n* on exit.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) COMPLEX array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by CHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) COMPLEX array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by CHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B'; LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one\n* column.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_SCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_SCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, complex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_select);
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SCOMPLEX)
- rb_t = na_change_type(rb_t, NA_SCOMPLEX);
- t = NA_PTR_TYPE(rb_t, complex*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, complex*);
- MEMCPY(t_out__, t, complex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, complex*);
- MEMCPY(vl_out__, vl, complex, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, complex*);
- MEMCPY(vr_out__, vr, complex, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- ctrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_m, rb_info, rb_t, rb_vl, rb_vr);
-}
-
-void
-init_lapack_ctrevc(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrevc", rb_ctrevc, -1);
-}
diff --git a/ctrexc.c b/ctrexc.c
deleted file mode 100644
index 381ebc5..0000000
--- a/ctrexc.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrexc_(char *compq, integer *n, complex *t, integer *ldt, complex *q, integer *ldq, integer *ifst, integer *ilst, integer *info);
-
-static VALUE
-rb_ctrexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_t;
- complex *t;
- VALUE rb_q;
- complex *q;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- complex *t_out__;
- VALUE rb_q_out__;
- complex *q_out__;
-
- integer ldt;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.ctrexc( compq, t, q, ifst, ilst)\n or\n NumRu::Lapack.ctrexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* CTREXC reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n* is moved to row ILST.\n*\n* The Schur form T is reordered by a unitary similarity transformation\n* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n* postmultplying it with Z.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, the reordered upper triangular matrix.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input) INTEGER\n* ILST (input) INTEGER\n* Specify the reordering of the diagonal elements of T:\n* The element with row index IFST is moved to row ILST by a\n* sequence of transpositions between adjacent elements.\n* 1 <= IFST <= N; 1 <= ILST <= 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* .. Local Scalars ..\n LOGICAL WANTQ\n INTEGER K, M1, M2, M3\n REAL CS\n COMPLEX SN, T11, T22, TEMP\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLARTG, CROT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_compq = argv[0];
- rb_t = argv[1];
- rb_q = argv[2];
- rb_ifst = argv[3];
- rb_ilst = argv[4];
-
- compq = StringValueCStr(rb_compq)[0];
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (2th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SCOMPLEX)
- rb_t = na_change_type(rb_t, NA_SCOMPLEX);
- t = NA_PTR_TYPE(rb_t, complex*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, complex*);
- MEMCPY(t_out__, t, complex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
-
- ctrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_ctrexc(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrexc", rb_ctrexc, -1);
-}
diff --git a/ctrrfs.c b/ctrrfs.c
deleted file mode 100644
index d77a705..0000000
--- a/ctrrfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info);
-
-static VALUE
-rb_ctrrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_x;
- complex *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.ctrrfs( uplo, trans, diag, a, b, x)\n or\n NumRu::Lapack.ctrrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by CTRTRS or some other\n* means before entering this routine. CTRRFS 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)\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* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SCOMPLEX)
- rb_x = na_change_type(rb_x, NA_SCOMPLEX);
- x = NA_PTR_TYPE(rb_x, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- work = ALLOC_N(complex, (2*n));
- rwork = ALLOC_N(real, (n));
-
- ctrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_ctrrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrrfs", rb_ctrrfs, -1);
-}
diff --git a/ctrsen.c b/ctrsen.c
deleted file mode 100644
index cff0523..0000000
--- a/ctrsen.c
+++ /dev/null
@@ -1,129 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrsen_(char *job, char *compq, logical *select, integer *n, complex *t, integer *ldt, complex *q, integer *ldq, complex *w, integer *m, real *s, real *sep, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ctrsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- complex *t;
- VALUE rb_q;
- complex *q;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- complex *w;
- VALUE rb_m;
- integer m;
- VALUE rb_s;
- real s;
- VALUE rb_sep;
- real sep;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- complex *t_out__;
- VALUE rb_q_out__;
- complex *q_out__;
-
- integer n;
- integer ldt;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, m, s, sep, work, info, t, q = NumRu::Lapack.ctrsen( job, compq, select, t, q, lwork)\n or\n NumRu::Lapack.ctrsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRSEN reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n* the leading positions on the diagonal of the upper triangular matrix\n* T, and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, T is overwritten by the reordered matrix T, with the\n* selected eigenvalues as the leading diagonal elements.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix which reorders T; the leading M\n* columns of Q form an orthonormal basis for the specified\n* invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* W (output) COMPLEX array, dimension (N)\n* The reordered eigenvalues of T, in the same order as they\n* appear on the diagonal of T.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 <= M <= N.\n*\n* S (output) REAL\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) REAL\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\n*\n* WORK (workspace/output) COMPLEX 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.\n* If JOB = 'N', LWORK >= 1;\n* if JOB = 'E', LWORK = max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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* CTRSEN first collects the selected eigenvalues by computing a unitary\n* transformation Z to move them to the top left corner of T. In other\n* words, the selected eigenvalues are the eigenvalues of T11 in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n* n1 columns of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the Schur factorization of a matrix\n* A = Q*T*Q', then the reordered Schur factorization of A is given by\n* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n* corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_q = argv[4];
- rb_lwork = argv[5];
-
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SCOMPLEX)
- rb_q = na_change_type(rb_q, NA_SCOMPLEX);
- q = NA_PTR_TYPE(rb_q, complex*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of q");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SCOMPLEX)
- rb_t = na_change_type(rb_t, NA_SCOMPLEX);
- t = NA_PTR_TYPE(rb_t, complex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, complex*);
- MEMCPY(t_out__, t, complex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, complex*);
- MEMCPY(q_out__, q, complex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
-
- ctrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, w, &m, &s, &sep, work, &lwork, &info);
-
- rb_m = INT2NUM(m);
- rb_s = rb_float_new((double)s);
- rb_sep = rb_float_new((double)sep);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_w, rb_m, rb_s, rb_sep, rb_work, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_ctrsen(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrsen", rb_ctrsen, -1);
-}
diff --git a/ctrsna.c b/ctrsna.c
deleted file mode 100644
index 529bd61..0000000
--- a/ctrsna.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrsna_(char *job, char *howmny, logical *select, integer *n, complex *t, integer *ldt, complex *vl, integer *ldvl, complex *vr, integer *ldvr, real *s, real *sep, integer *mm, integer *m, complex *work, integer *ldwork, real *rwork, integer *info);
-
-static VALUE
-rb_ctrsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- complex *t;
- VALUE rb_vl;
- complex *vl;
- VALUE rb_vr;
- complex *vr;
- VALUE rb_ldwork;
- integer ldwork;
- VALUE rb_s;
- real *s;
- VALUE rb_sep;
- real *sep;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.ctrsna( job, howmny, select, t, vl, vr, ldwork)\n or\n NumRu::Lapack.ctrsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a complex upper triangular\n* matrix T (or of any matrix Q*T*Q**H with Q unitary).\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) COMPLEX array, dimension (LDT,N)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) COMPLEX array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* CHSEIN or CTREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* CHSEIN or CTREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n* all correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) COMPLEX array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* RWORK (workspace) REAL array, dimension (N)\n* If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
- rb_ldwork = argv[6];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SCOMPLEX)
- rb_t = na_change_type(rb_t, NA_SCOMPLEX);
- t = NA_PTR_TYPE(rb_t, complex*);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_SCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, complex*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_SCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, complex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of t");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- job = StringValueCStr(rb_job)[0];
- ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = mm;
- rb_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sep = NA_PTR_TYPE(rb_sep, real*);
- work = ALLOC_N(complex, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
- rwork = ALLOC_N(real, (lsame_(&job,"E") ? 0 : n));
-
- ctrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, rwork, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_sep, rb_m, rb_info);
-}
-
-void
-init_lapack_ctrsna(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrsna", rb_ctrsna, -1);
-}
diff --git a/ctrsyl.c b/ctrsyl.c
deleted file mode 100644
index 48626c5..0000000
--- a/ctrsyl.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *c, integer *ldc, real *scale, integer *info);
-
-static VALUE
-rb_ctrsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trana;
- char trana;
- VALUE rb_tranb;
- char tranb;
- VALUE rb_isgn;
- integer isgn;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_c;
- complex *c;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.ctrsyl( trana, tranb, isgn, a, b, c)\n or\n NumRu::Lapack.ctrsyl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* CTRSYL solves the complex Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**H, and A and B are both upper triangular. A is\n* M-by-M and B is N-by-N; the right hand side C and the solution X are\n* M-by-N; and scale is an output scale factor, set <= 1 to avoid\n* overflow in X.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'C': op(A) = A**H (Conjugate transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'C': op(B) = B**H (Conjugate transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The upper 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) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) REAL\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trana = argv[0];
- rb_tranb = argv[1];
- rb_isgn = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- trana = StringValueCStr(rb_trana)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- tranb = StringValueCStr(rb_tranb)[0];
- isgn = NUM2INT(rb_isgn);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- ctrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_scale, rb_info, rb_c);
-}
-
-void
-init_lapack_ctrsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrsyl", rb_ctrsyl, -1);
-}
diff --git a/ctrti2.c b/ctrti2.c
deleted file mode 100644
index 2ab6fe0..0000000
--- a/ctrti2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrti2_(char *uplo, char *diag, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ctrti2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ctrti2( uplo, diag, a)\n or\n NumRu::Lapack.ctrti2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTRTI2 computes the inverse of a complex upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ctrti2_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ctrti2(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrti2", rb_ctrti2, -1);
-}
diff --git a/ctrtri.c b/ctrtri.c
deleted file mode 100644
index 6dd22f1..0000000
--- a/ctrtri.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrtri_(char *uplo, char *diag, integer *n, complex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ctrtri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ctrtri( uplo, diag, a)\n or\n NumRu::Lapack.ctrtri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTRTRI computes the inverse of a complex upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ctrtri_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ctrtri(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrtri", rb_ctrtri, -1);
-}
diff --git a/ctrtrs.c b/ctrtrs.c
deleted file mode 100644
index 3690010..0000000
--- a/ctrtrs.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ctrtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- complex *a;
- VALUE rb_b;
- complex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- complex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ctrtrs( uplo, trans, diag, a, b)\n or\n NumRu::Lapack.ctrtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CTRTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SCOMPLEX)
- rb_b = na_change_type(rb_b, NA_SCOMPLEX);
- b = NA_PTR_TYPE(rb_b, complex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, complex*);
- MEMCPY(b_out__, b, complex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ctrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ctrtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrtrs", rb_ctrtrs, -1);
-}
diff --git a/ctrttf.c b/ctrttf.c
deleted file mode 100644
index a890f60..0000000
--- a/ctrttf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrttf_(char *transr, char *uplo, integer *n, complex *a, integer *lda, doublecomplex *arf, integer *info);
-
-static VALUE
-rb_ctrttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_arf;
- doublecomplex *arf;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ctrttf( transr, uplo, a)\n or\n NumRu::Lapack.ctrttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* CTRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal mode is wanted;\n* = 'C': ARF in Conjugate Transpose mode is wanted;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension ( LDA, N ) \n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- transr = StringValueCStr(rb_transr)[0];
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, doublecomplex*);
-
- ctrttf_(&transr, &uplo, &n, a, &lda, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_ctrttf(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrttf", rb_ctrttf, -1);
-}
diff --git a/ctrttp.c b/ctrttp.c
deleted file mode 100644
index 6157557..0000000
--- a/ctrttp.c
+++ /dev/null
@@ -1,54 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctrttp_(char *uplo, integer *n, complex *a, integer *lda, complex *ap, integer *info);
-
-static VALUE
-rb_ctrttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.ctrttp( uplo, a)\n or\n NumRu::Lapack.ctrttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* CTRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_ap = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, complex*);
-
- ctrttp_(&uplo, &n, a, &lda, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_ctrttp(VALUE mLapack){
- rb_define_module_function(mLapack, "ctrttp", rb_ctrttp, -1);
-}
diff --git a/ctzrqf.c b/ctzrqf.c
deleted file mode 100644
index e8e5279..0000000
--- a/ctzrqf.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctzrqf_(integer *m, integer *n, complex *a, integer *lda, complex *tau, integer *info);
-
-static VALUE
-rb_ctzrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.ctzrqf( a)\n or\n NumRu::Lapack.ctzrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CTZRZF.\n*\n* CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), whose conjugate transpose is used to\n* introduce zeros into the (m - k + 1)th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ctzrqf_(&m, &n, a, &lda, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_ctzrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "ctzrqf", rb_ctzrqf, -1);
-}
diff --git a/ctzrzf.c b/ctzrzf.c
deleted file mode 100644
index f7d7ef3..0000000
--- a/ctzrzf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ctzrzf_(integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ctzrzf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.ctzrzf( a, lwork)\n or\n NumRu::Lapack.ctzrzf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_lwork = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ctzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_ctzrzf(VALUE mLapack){
- rb_define_module_function(mLapack, "ctzrzf", rb_ctzrzf, -1);
-}
diff --git a/cunbdb.c b/cunbdb.c
deleted file mode 100644
index 4cd5466..0000000
--- a/cunbdb.c
+++ /dev/null
@@ -1,212 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunbdb_(char *trans, char *signs, integer *m, integer *p, integer *q, complex *x11, integer *ldx11, complex *x12, integer *ldx12, complex *x21, integer *ldx21, complex *x22, integer *ldx22, real *theta, real *phi, complex *taup1, complex *taup2, complex *tauq1, complex *tauq2, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunbdb(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- complex *x11;
- VALUE rb_x12;
- complex *x12;
- VALUE rb_x21;
- complex *x21;
- VALUE rb_x22;
- complex *x22;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_theta;
- real *theta;
- VALUE rb_phi;
- real *phi;
- VALUE rb_taup1;
- complex *taup1;
- VALUE rb_taup2;
- complex *taup2;
- VALUE rb_tauq1;
- complex *tauq1;
- VALUE rb_tauq2;
- complex *tauq2;
- VALUE rb_info;
- integer info;
- VALUE rb_x11_out__;
- complex *x11_out__;
- VALUE rb_x12_out__;
- complex *x12_out__;
- VALUE rb_x21_out__;
- complex *x21_out__;
- VALUE rb_x22_out__;
- complex *x22_out__;
- complex *work;
-
- integer ldx11;
- integer q;
- integer ldx12;
- integer ldx21;
- integer ldx22;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.cunbdb( trans, signs, m, x11, x12, x21, x22, lwork)\n or\n NumRu::Lapack.cunbdb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNBDB( 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* CUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n* partitioned unitary matrix X:\n*\n* [ B11 | B12 0 0 ]\n* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H\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 CUNCSD\n* for details.)\n*\n* The unitary 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) COMPLEX array, dimension (LDX11,Q)\n* On entry, the top-left block of the unitary 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) CMPLX array, dimension (LDX12,M-Q)\n* On entry, the top-right block of the unitary 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) COMPLEX array, dimension (LDX21,Q)\n* On entry, the bottom-left block of the unitary 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) COMPLEX array, dimension (LDX22,M-Q)\n* On entry, the bottom-right block of the unitary 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) REAL 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) REAL 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) COMPLEX array, dimension (P)\n* The scalar factors of the elementary reflectors that define\n* P1.\n*\n* TAUP2 (output) COMPLEX array, dimension (M-P)\n* The scalar factors of the elementary reflectors that define\n* P2.\n*\n* TAUQ1 (output) COMPLEX array, dimension (Q)\n* The scalar factors of the elementary reflectors that define\n* Q1.\n*\n* TAUQ2 (output) COMPLEX array, dimension (M-Q)\n* The scalar factors of the elementary reflectors that define\n* Q2.\n*\n* WORK (workspace) COMPLEX 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 CUNCSD for details.\n*\n* P1, P2, Q1, and Q2 are represented as products of elementary\n* reflectors. See CUNCSD for details on generating P1, P2, Q1, and Q2\n* using CUNGQR and CUNGLQ.\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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_signs = argv[1];
- rb_m = argv[2];
- rb_x11 = argv[3];
- rb_x12 = argv[4];
- rb_x21 = argv[5];
- rb_x22 = argv[6];
- rb_lwork = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- ldx21 = NA_SHAPE0(rb_x21);
- if (ldx21 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x21 must be %d", p);
- p = ldx21;
- if (NA_TYPE(rb_x21) != NA_SCOMPLEX)
- rb_x21 = na_change_type(rb_x21, NA_SCOMPLEX);
- x21 = NA_PTR_TYPE(rb_x21, complex*);
- signs = StringValueCStr(rb_signs)[0];
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- ldx11 = NA_SHAPE0(rb_x11);
- if (NA_TYPE(rb_x11) != NA_SCOMPLEX)
- rb_x11 = na_change_type(rb_x11, NA_SCOMPLEX);
- x11 = NA_PTR_TYPE(rb_x11, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- ldx12 = NA_SHAPE0(rb_x12);
- if (ldx12 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be %d", p);
- p = ldx12;
- if (NA_TYPE(rb_x12) != NA_SCOMPLEX)
- rb_x12 = na_change_type(rb_x12, NA_SCOMPLEX);
- x12 = NA_PTR_TYPE(rb_x12, complex*);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- ldx22 = NA_SHAPE0(rb_x22);
- if (ldx22 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be %d", p);
- p = ldx22;
- if (NA_TYPE(rb_x22) != NA_SCOMPLEX)
- rb_x22 = na_change_type(rb_x22, NA_SCOMPLEX);
- x22 = NA_PTR_TYPE(rb_x22, complex*);
- ldx12 = p;
- ldx21 = p;
- ldx22 = p;
- {
- int shape[1];
- shape[0] = q;
- rb_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- phi = NA_PTR_TYPE(rb_phi, real*);
- {
- int shape[1];
- shape[0] = p;
- rb_taup1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taup1 = NA_PTR_TYPE(rb_taup1, complex*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_taup2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- taup2 = NA_PTR_TYPE(rb_taup2, complex*);
- {
- int shape[1];
- shape[0] = q;
- rb_tauq1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tauq1 = NA_PTR_TYPE(rb_tauq1, complex*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_tauq2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- tauq2 = NA_PTR_TYPE(rb_tauq2, complex*);
- {
- int shape[2];
- shape[0] = ldx11;
- shape[1] = q;
- rb_x11_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x11_out__ = NA_PTR_TYPE(rb_x11_out__, complex*);
- MEMCPY(x11_out__, x11, complex, NA_TOTAL(rb_x11));
- rb_x11 = rb_x11_out__;
- x11 = x11_out__;
- {
- int shape[2];
- shape[0] = ldx12;
- shape[1] = m-q;
- rb_x12_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x12_out__ = NA_PTR_TYPE(rb_x12_out__, complex*);
- MEMCPY(x12_out__, x12, complex, NA_TOTAL(rb_x12));
- rb_x12 = rb_x12_out__;
- x12 = x12_out__;
- {
- int shape[2];
- shape[0] = ldx21;
- shape[1] = q;
- rb_x21_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x21_out__ = NA_PTR_TYPE(rb_x21_out__, complex*);
- MEMCPY(x21_out__, x21, complex, NA_TOTAL(rb_x21));
- rb_x21 = rb_x21_out__;
- x21 = x21_out__;
- {
- int shape[2];
- shape[0] = ldx22;
- shape[1] = m-q;
- rb_x22_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- x22_out__ = NA_PTR_TYPE(rb_x22_out__, complex*);
- MEMCPY(x22_out__, x22, complex, NA_TOTAL(rb_x22));
- rb_x22 = rb_x22_out__;
- x22 = x22_out__;
- work = ALLOC_N(complex, (MAX(1,lwork)));
-
- cunbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_theta, rb_phi, rb_taup1, rb_taup2, rb_tauq1, rb_tauq2, rb_info, rb_x11, rb_x12, rb_x21, rb_x22);
-}
-
-void
-init_lapack_cunbdb(VALUE mLapack){
- rb_define_module_function(mLapack, "cunbdb", rb_cunbdb, -1);
-}
diff --git a/cuncsd.c b/cuncsd.c
deleted file mode 100644
index 24d67e0..0000000
--- a/cuncsd.c
+++ /dev/null
@@ -1,201 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cuncsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, char *signs, integer *m, integer *p, integer *q, complex *x11, integer *ldx11, complex *x12, integer *ldx12, complex *x21, integer *ldx21, complex *x22, integer *ldx22, real *theta, complex *u1, integer *ldu1, complex *u2, integer *ldu2, complex *v1t, integer *ldv1t, complex *v2t, integer *ldv2t, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *info);
-
-static VALUE
-rb_cuncsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- complex *x11;
- VALUE rb_ldx11;
- integer ldx11;
- VALUE rb_x12;
- complex *x12;
- VALUE rb_ldx12;
- integer ldx12;
- VALUE rb_x21;
- complex *x21;
- VALUE rb_ldx21;
- integer ldx21;
- VALUE rb_x22;
- complex *x22;
- VALUE rb_ldx22;
- integer ldx22;
- VALUE rb_ldu1;
- integer ldu1;
- VALUE rb_ldu2;
- integer ldu2;
- VALUE rb_ldv1t;
- integer ldv1t;
- VALUE rb_ldv2t;
- integer ldv2t;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_theta;
- real *theta;
- VALUE rb_u1;
- complex *u1;
- VALUE rb_u2;
- complex *u2;
- VALUE rb_v1t;
- complex *v1t;
- VALUE rb_v2t;
- complex *v2t;
- VALUE rb_info;
- integer info;
- complex *work;
- real *rwork;
- integer *iwork;
-
- integer p;
- integer q;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, ldu1, ldu2, ldv1t, ldv2t, lwork, lrwork)\n or\n NumRu::Lapack.cuncsd # print help\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNCSD computes the CS decomposition of an M-by-M partitioned\n* unitary matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) COMPLEX array, dimension (LDX,M)\n* On entry, the unitary matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) REAL array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) COMPLEX array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) COMPLEX array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) COMPLEX array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n* matrix V1**H.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) COMPLEX array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n* matrix V2**H.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) COMPLEX 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.\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* RWORK (workspace) REAL array, dimension MAX(1,LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n* If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n*\n* If LRWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the RWORK array, returns\n* this value as the first entry of the work array, and no error\n* message related to LRWORK is issued by XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (M-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: CBBCSD did not converge. See the description of RWORK\n* above for details.\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\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_signs = argv[5];
- rb_m = argv[6];
- rb_x11 = argv[7];
- rb_ldx11 = argv[8];
- rb_x12 = argv[9];
- rb_ldx12 = argv[10];
- rb_x21 = argv[11];
- rb_ldx21 = argv[12];
- rb_x22 = argv[13];
- rb_ldx22 = argv[14];
- rb_ldu1 = argv[15];
- rb_ldu2 = argv[16];
- rb_ldv1t = argv[17];
- rb_ldv2t = argv[18];
- rb_lwork = argv[19];
- rb_lrwork = argv[20];
-
- trans = StringValueCStr(rb_trans)[0];
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (12th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (12th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- p = NA_SHAPE0(rb_x21);
- if (NA_TYPE(rb_x21) != NA_SCOMPLEX)
- rb_x21 = na_change_type(rb_x21, NA_SCOMPLEX);
- x21 = NA_PTR_TYPE(rb_x21, complex*);
- signs = StringValueCStr(rb_signs)[0];
- jobu1 = StringValueCStr(rb_jobu1)[0];
- lrwork = NUM2INT(rb_lrwork);
- jobu2 = StringValueCStr(rb_jobu2)[0];
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- if (NA_SHAPE0(rb_x11) != p)
- rb_raise(rb_eRuntimeError, "shape 0 of x11 must be the same as shape 0 of x21");
- if (NA_TYPE(rb_x11) != NA_SCOMPLEX)
- rb_x11 = na_change_type(rb_x11, NA_SCOMPLEX);
- x11 = NA_PTR_TYPE(rb_x11, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (14th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- if (NA_SHAPE0(rb_x22) != p)
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be the same as shape 0 of x21");
- if (NA_TYPE(rb_x22) != NA_SCOMPLEX)
- rb_x22 = na_change_type(rb_x22, NA_SCOMPLEX);
- x22 = NA_PTR_TYPE(rb_x22, complex*);
- ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
- ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (10th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- if (NA_SHAPE0(rb_x12) != p)
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be the same as shape 0 of x21");
- if (NA_TYPE(rb_x12) != NA_SCOMPLEX)
- rb_x12 = na_change_type(rb_x12, NA_SCOMPLEX);
- x12 = NA_PTR_TYPE(rb_x12, complex*);
- ldx12 = p;
- ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
- ldx11 = p;
- ldx22 = p;
- ldx21 = p;
- ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
- {
- int shape[1];
- shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
- rb_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, real*);
- {
- int shape[1];
- shape[0] = p;
- rb_u1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- u1 = NA_PTR_TYPE(rb_u1, complex*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_u2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- u2 = NA_PTR_TYPE(rb_u2, complex*);
- {
- int shape[1];
- shape[0] = q;
- rb_v1t = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- v1t = NA_PTR_TYPE(rb_v1t, complex*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_v2t = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- v2t = NA_PTR_TYPE(rb_v2t, complex*);
- work = ALLOC_N(complex, (MAX(1,lwork)));
- rwork = ALLOC_N(real, (MAX(1,lrwork)));
- iwork = ALLOC_N(integer, (m-q));
-
- cuncsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, rwork, &lrwork, iwork, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t, rb_info);
-}
-
-void
-init_lapack_cuncsd(VALUE mLapack){
- rb_define_module_function(mLapack, "cuncsd", rb_cuncsd, -1);
-}
diff --git a/cung2l.c b/cung2l.c
deleted file mode 100644
index 70069e2..0000000
--- a/cung2l.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cung2l_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cung2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cung2l( m, a, tau)\n or\n NumRu::Lapack.cung2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNG2L generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n));
-
- cung2l_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cung2l(VALUE mLapack){
- rb_define_module_function(mLapack, "cung2l", rb_cung2l, -1);
-}
diff --git a/cung2r.c b/cung2r.c
deleted file mode 100644
index 644f302..0000000
--- a/cung2r.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cung2r_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cung2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cung2r( m, a, tau)\n or\n NumRu::Lapack.cung2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNG2R generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (n));
-
- cung2r_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cung2r(VALUE mLapack){
- rb_define_module_function(mLapack, "cung2r", rb_cung2r, -1);
-}
diff --git a/cungbr.c b/cungbr.c
deleted file mode 100644
index f5f9483..0000000
--- a/cungbr.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cungbr_(char *vect, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cungbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungbr( vect, m, k, a, tau, lwork)\n or\n NumRu::Lapack.cungbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGBR generates one of the complex unitary matrices Q or P**H\n* determined by CGEBRD when reducing a complex matrix A to bidiagonal\n* form: A = Q * B * P**H. Q and P**H are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and CUNGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n* is of order N:\n* if k < n, P**H = G(k) . . . G(2) G(1) and CUNGBR returns the first m\n* rows of P**H, where n >= m >= k;\n* if k >= n, P**H = G(n-1) . . . G(2) G(1) and CUNGBR returns P**H as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**H is\n* required, as defined in the transformation applied by CGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**H to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**H to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by CGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by CGEBRD.\n* K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by CGEBRD.\n* On exit, the M-by-N matrix Q or P**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= M.\n*\n* TAU (input) COMPLEX array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**H, as\n* returned by CGEBRD in its array argument TAUQ or TAUP.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_m = argv[1];
- rb_k = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_lwork = argv[5];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(m,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cungbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cungbr(VALUE mLapack){
- rb_define_module_function(mLapack, "cungbr", rb_cungbr, -1);
-}
diff --git a/cunghr.c b/cunghr.c
deleted file mode 100644
index ba8d980..0000000
--- a/cunghr.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunghr_(integer *n, integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunghr(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cunghr( ilo, ihi, a, tau, lwork)\n or\n NumRu::Lapack.cunghr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGHR generates a complex unitary matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* CGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of CGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by CGEHRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEHRD.\n*\n* WORK (workspace/output) COMPLEX 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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cunghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cunghr(VALUE mLapack){
- rb_define_module_function(mLapack, "cunghr", rb_cunghr, -1);
-}
diff --git a/cungl2.c b/cungl2.c
deleted file mode 100644
index 5a0b2cf..0000000
--- a/cungl2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cungl2_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cungl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cungl2( a, tau)\n or\n NumRu::Lapack.cungl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by CGELQF in the first k rows of its array argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* WORK (workspace) COMPLEX array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (m));
-
- cungl2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cungl2(VALUE mLapack){
- rb_define_module_function(mLapack, "cungl2", rb_cungl2, -1);
-}
diff --git a/cunglq.c b/cunglq.c
deleted file mode 100644
index 153a19e..0000000
--- a/cunglq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunglq_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunglq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cunglq( m, a, tau, lwork)\n or\n NumRu::Lapack.cunglq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by CGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cunglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cunglq(VALUE mLapack){
- rb_define_module_function(mLapack, "cunglq", rb_cunglq, -1);
-}
diff --git a/cungql.c b/cungql.c
deleted file mode 100644
index 01dc84e..0000000
--- a/cungql.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cungql_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cungql(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungql( m, a, tau, lwork)\n or\n NumRu::Lapack.cungql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cungql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cungql(VALUE mLapack){
- rb_define_module_function(mLapack, "cungql", rb_cungql, -1);
-}
diff --git a/cungqr.c b/cungqr.c
deleted file mode 100644
index 6002029..0000000
--- a/cungqr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cungqr_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cungqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungqr( m, a, tau, lwork)\n or\n NumRu::Lapack.cungqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cungqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cungqr(VALUE mLapack){
- rb_define_module_function(mLapack, "cungqr", rb_cungqr, -1);
-}
diff --git a/cungr2.c b/cungr2.c
deleted file mode 100644
index 7c48ff3..0000000
--- a/cungr2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cungr2_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *info);
-
-static VALUE
-rb_cungr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
- complex *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cungr2( a, tau)\n or\n NumRu::Lapack.cungr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGERQF in the last k rows of its array argument\n* A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* WORK (workspace) COMPLEX array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(complex, (m));
-
- cungr2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_cungr2(VALUE mLapack){
- rb_define_module_function(mLapack, "cungr2", rb_cungr2, -1);
-}
diff --git a/cungrq.c b/cungrq.c
deleted file mode 100644
index 9fe201a..0000000
--- a/cungrq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cungrq_(integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cungrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungrq( m, a, tau, lwork)\n or\n NumRu::Lapack.cungrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cungrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cungrq(VALUE mLapack){
- rb_define_module_function(mLapack, "cungrq", rb_cungrq, -1);
-}
diff --git a/cungtr.c b/cungtr.c
deleted file mode 100644
index fb1f9e5..0000000
--- a/cungtr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cungtr_(char *uplo, integer *n, complex *a, integer *lda, complex *tau, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cungtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungtr( uplo, a, tau, lwork)\n or\n NumRu::Lapack.cungtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* CHETRD:\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 triangle of A contains elementary reflectors\n* from CHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from CHETRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by CHETRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= N.\n*\n* TAU (input) COMPLEX array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CHETRD.\n*\n* WORK (workspace/output) COMPLEX 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 >= N-1.\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- cungtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_cungtr(VALUE mLapack){
- rb_define_module_function(mLapack, "cungtr", rb_cungtr, -1);
-}
diff --git a/cunm2l.c b/cunm2l.c
deleted file mode 100644
index 5cd20da..0000000
--- a/cunm2l.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunm2l_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *info);
-
-static VALUE
-rb_cunm2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.cunm2l( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.cunm2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNM2L overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- cunm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_cunm2l(VALUE mLapack){
- rb_define_module_function(mLapack, "cunm2l", rb_cunm2l, -1);
-}
diff --git a/cunm2r.c b/cunm2r.c
deleted file mode 100644
index 38d80a9..0000000
--- a/cunm2r.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunm2r_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *info);
-
-static VALUE
-rb_cunm2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.cunm2r( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.cunm2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNM2R overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- cunm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_cunm2r(VALUE mLapack){
- rb_define_module_function(mLapack, "cunm2r", rb_cunm2r, -1);
-}
diff --git a/cunmbr.c b/cunmbr.c
deleted file mode 100644
index c855bef..0000000
--- a/cunmbr.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmbr_(char *vect, char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- integer nq;
-
- integer lda;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmbr( vect, side, trans, m, k, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'C': P**H * C C * P**H\n*\n* Here Q and P**H are the unitary matrices determined by CGEBRD when\n* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n* and P**H are defined as products of elementary reflectors H(i) and\n* G(i) respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the unitary matrix Q or P**H that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**H;\n* = 'P': apply P or P**H.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**H, P or P**H from the Left;\n* = 'R': apply Q, Q**H, P or P**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'C': Conjugate transpose, apply Q**H or P**H.\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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by CGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by CGEBRD.\n* K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by CGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) COMPLEX array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by CGEBRD in the array argument TAUQ or TAUP.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n* or P*C or P**H*C or C*P or C*P**H.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M);\n* if N = 0 or M = 0, LWORK >= 1.\n* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n* optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CUNMLQ, CUNMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_vect = argv[0];
- rb_side = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_k = argv[4];
- rb_a = argv[5];
- rb_tau = argv[6];
- rb_c = argv[7];
- rb_lwork = argv[8];
-
- k = NUM2INT(rb_k);
- lwork = NUM2INT(rb_lwork);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- trans = StringValueCStr(rb_trans)[0];
- nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmbr(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmbr", rb_cunmbr, -1);
-}
diff --git a/cunmhr.c b/cunmhr.c
deleted file mode 100644
index 36db415..0000000
--- a/cunmhr.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmhr_(char *side, char *trans, integer *m, integer *n, integer *ilo, integer *ihi, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmhr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmhr( side, trans, ilo, ihi, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmhr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMHR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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* IHI-ILO elementary reflectors, as returned by CGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q**H (Conjugate transpose)\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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of CGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by CGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEHRD.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CUNMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
- rb_lwork = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- ihi = NUM2INT(rb_ihi);
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmhr(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmhr", rb_cunmhr, -1);
-}
diff --git a/cunml2.c b/cunml2.c
deleted file mode 100644
index 6244d88..0000000
--- a/cunml2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunml2_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *info);
-
-static VALUE
-rb_cunml2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.cunml2( side, trans, a, tau, c)\n or\n NumRu::Lapack.cunml2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNML2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- cunml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_cunml2(VALUE mLapack){
- rb_define_module_function(mLapack, "cunml2", rb_cunml2, -1);
-}
diff --git a/cunmlq.c b/cunmlq.c
deleted file mode 100644
index 7b30935..0000000
--- a/cunmlq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmlq_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmlq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmlq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmlq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMLQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmlq(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmlq", rb_cunmlq, -1);
-}
diff --git a/cunmql.c b/cunmql.c
deleted file mode 100644
index 5435fa3..0000000
--- a/cunmql.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmql_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmql(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmql( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMQL overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmql(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmql", rb_cunmql, -1);
-}
diff --git a/cunmqr.c b/cunmqr.c
deleted file mode 100644
index 9eb3dab..0000000
--- a/cunmqr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmqr_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmqr( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMQR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmqr(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmqr", rb_cunmqr, -1);
-}
diff --git a/cunmr2.c b/cunmr2.c
deleted file mode 100644
index fb5df8b..0000000
--- a/cunmr2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmr2_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *info);
-
-static VALUE
-rb_cunmr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.cunmr2( side, trans, a, tau, c)\n or\n NumRu::Lapack.cunmr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMR2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- cunmr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmr2(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmr2", rb_cunmr2, -1);
-}
diff --git a/cunmr3.c b/cunmr3.c
deleted file mode 100644
index 75cc7cc..0000000
--- a/cunmr3.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmr3_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *info);
-
-static VALUE
-rb_cunmr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.cunmr3( side, trans, l, a, tau, c)\n or\n NumRu::Lapack.cunmr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMR3 overwrites the general complex m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CTZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CTZRZF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n COMPLEX TAUI\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLARZ, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- cunmr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmr3(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmr3", rb_cunmr3, -1);
-}
diff --git a/cunmrq.c b/cunmrq.c
deleted file mode 100644
index 0026550..0000000
--- a/cunmrq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmrq_(char *side, char *trans, integer *m, integer *n, integer *k, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmrq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMRQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmrq(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmrq", rb_cunmrq, -1);
-}
diff --git a/cunmrz.c b/cunmrz.c
deleted file mode 100644
index 5b8d216..0000000
--- a/cunmrz.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmrz( side, trans, l, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMRZ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CTZRZF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmrz(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmrz", rb_cunmrz, -1);
-}
diff --git a/cunmtr.c b/cunmtr.c
deleted file mode 100644
index ec0558b..0000000
--- a/cunmtr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cunmtr_(char *side, char *uplo, char *trans, integer *m, integer *n, complex *a, integer *lda, complex *tau, complex *c, integer *ldc, complex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_cunmtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- complex *a;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- complex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmtr( side, uplo, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.cunmtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 CHETRD:\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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A contains elementary reflectors\n* from CHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from CHETRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by CHETRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CHETRD.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CUNMQL, CUNMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- cunmtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_cunmtr(VALUE mLapack){
- rb_define_module_function(mLapack, "cunmtr", rb_cunmtr, -1);
-}
diff --git a/cupgtr.c b/cupgtr.c
deleted file mode 100644
index b9f2861..0000000
--- a/cupgtr.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cupgtr_(char *uplo, integer *n, complex *ap, complex *tau, complex *q, integer *ldq, complex *work, integer *info);
-
-static VALUE
-rb_cupgtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_q;
- complex *q;
- VALUE rb_info;
- integer info;
- complex *work;
-
- integer ldap;
- integer ldtau;
- integer ldq;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, info = NumRu::Lapack.cupgtr( uplo, ap, tau)\n or\n NumRu::Lapack.cupgtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUPGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors H(i) of order n, as returned by\n* CHPTRD 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 CHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to CHPTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The vectors which define the elementary reflectors, as\n* returned by CHPTRD.\n*\n* TAU (input) COMPLEX array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CHPTRD.\n*\n* Q (output) COMPLEX array, dimension (LDQ,N)\n* The N-by-N unitary matrix Q.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* WORK (workspace) COMPLEX 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_tau = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- ldtau = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- n = ldtau+1;
- ldq = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, complex*);
- work = ALLOC_N(complex, (n-1));
-
- cupgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_q, rb_info);
-}
-
-void
-init_lapack_cupgtr(VALUE mLapack){
- rb_define_module_function(mLapack, "cupgtr", rb_cupgtr, -1);
-}
diff --git a/cupmtr.c b/cupmtr.c
deleted file mode 100644
index c7484fe..0000000
--- a/cupmtr.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID cupmtr_(char *side, char *uplo, char *trans, integer *m, integer *n, complex *ap, complex *tau, complex *c, integer *ldc, complex *work, integer *info);
-
-static VALUE
-rb_cupmtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_ap;
- complex *ap;
- VALUE rb_tau;
- complex *tau;
- VALUE rb_c;
- complex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- complex *c_out__;
- complex *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.cupmtr( side, uplo, trans, m, ap, tau, c)\n or\n NumRu::Lapack.cupmtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUPMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 CHPTRD 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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular packed storage used in previous\n* call to CHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to CHPTRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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) COMPLEX 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 CHPTRD. AP is modified by the routine but\n* restored on exit.\n*\n* TAU (input) COMPLEX 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 CHPTRD.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_ap = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SCOMPLEX)
- rb_c = na_change_type(rb_c, NA_SCOMPLEX);
- c = NA_PTR_TYPE(rb_c, complex*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_SCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_SCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, complex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (m*(m+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
- if (NA_TYPE(rb_ap) != NA_SCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_SCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, complex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, complex*);
- MEMCPY(c_out__, c, complex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- cupmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_cupmtr(VALUE mLapack){
- rb_define_module_function(mLapack, "cupmtr", rb_cupmtr, -1);
-}
diff --git a/dbbcsd.c b/dbbcsd.c
deleted file mode 100644
index cdd4bed..0000000
--- a/dbbcsd.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dbbcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, integer *m, integer *p, integer *q, doublereal *theta, doublereal *phi, doublereal *u1, integer *ldu1, doublereal *u2, integer *ldu2, doublereal *v1t, integer *ldv1t, doublereal *v2t, integer *ldv2t, doublereal *b11d, doublereal *b11e, doublereal *b12d, doublereal *b12e, doublereal *b21d, doublereal *b21e, doublereal *b22d, doublereal *b22e, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dbbcsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_theta;
- doublereal *theta;
- VALUE rb_phi;
- doublereal *phi;
- VALUE rb_u1;
- doublereal *u1;
- VALUE rb_u2;
- doublereal *u2;
- VALUE rb_v1t;
- doublereal *v1t;
- VALUE rb_v2t;
- doublereal *v2t;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_b11d;
- doublereal *b11d;
- VALUE rb_b11e;
- doublereal *b11e;
- VALUE rb_b12d;
- doublereal *b12d;
- VALUE rb_b12e;
- doublereal *b12e;
- VALUE rb_b21d;
- doublereal *b21d;
- VALUE rb_b21e;
- doublereal *b21e;
- VALUE rb_b22d;
- doublereal *b22d;
- VALUE rb_b22e;
- doublereal *b22e;
- VALUE rb_info;
- integer info;
- VALUE rb_theta_out__;
- doublereal *theta_out__;
- VALUE rb_u1_out__;
- doublereal *u1_out__;
- VALUE rb_u2_out__;
- doublereal *u2_out__;
- VALUE rb_v1t_out__;
- doublereal *v1t_out__;
- VALUE rb_v2t_out__;
- doublereal *v2t_out__;
- doublereal *work;
-
- integer q;
- integer ldu1;
- integer p;
- integer ldu2;
- integer ldv1t;
- integer ldv2t;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.dbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, lwork)\n or\n NumRu::Lapack.dbbcsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DBBCSD computes the CS decomposition of an orthogonal matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See DORCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the orthogonal matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) DOUBLE PRECISION array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) DOUBLE PRECISION array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) DOUBLE PRECISION array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) DOUBLE PRECISION array, dimension (Q)\n* When DBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If DBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When DBBCSD converges, B11E contains zeros. If DBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) DOUBLE PRECISION array, dimension (Q)\n* When DBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When DBBCSD converges, B12E contains zeros. If DBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* WORK (workspace) DOUBLE PRECISION 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 >= MAX(1,8*Q).\n*\n* If LWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the WORK array,\n* returns this value as the first entry of the work array, and\n* no error 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* > 0: if DBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_m = argv[5];
- rb_theta = argv[6];
- rb_phi = argv[7];
- rb_u1 = argv[8];
- rb_u2 = argv[9];
- rb_v1t = argv[10];
- rb_v2t = argv[11];
- rb_lwork = argv[12];
-
- if (!NA_IsNArray(rb_theta))
- rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
- if (NA_RANK(rb_theta) != 1)
- rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
- q = NA_SHAPE0(rb_theta);
- if (NA_TYPE(rb_theta) != NA_DFLOAT)
- rb_theta = na_change_type(rb_theta, NA_DFLOAT);
- theta = NA_PTR_TYPE(rb_theta, doublereal*);
- jobu1 = StringValueCStr(rb_jobu1)[0];
- trans = StringValueCStr(rb_trans)[0];
- m = NUM2INT(rb_m);
- jobu2 = StringValueCStr(rb_jobu2)[0];
- if (!NA_IsNArray(rb_v1t))
- rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
- if (NA_RANK(rb_v1t) != 2)
- rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v1t) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
- ldv1t = NA_SHAPE0(rb_v1t);
- if (NA_TYPE(rb_v1t) != NA_DFLOAT)
- rb_v1t = na_change_type(rb_v1t, NA_DFLOAT);
- v1t = NA_PTR_TYPE(rb_v1t, doublereal*);
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- if (!NA_IsNArray(rb_u1))
- rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
- if (NA_RANK(rb_u1) != 2)
- rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
- p = NA_SHAPE1(rb_u1);
- ldu1 = NA_SHAPE0(rb_u1);
- if (NA_TYPE(rb_u1) != NA_DFLOAT)
- rb_u1 = na_change_type(rb_u1, NA_DFLOAT);
- u1 = NA_PTR_TYPE(rb_u1, doublereal*);
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_u2))
- rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
- if (NA_RANK(rb_u2) != 2)
- rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u2) != (m-p))
- rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
- ldu2 = NA_SHAPE0(rb_u2);
- if (NA_TYPE(rb_u2) != NA_DFLOAT)
- rb_u2 = na_change_type(rb_u2, NA_DFLOAT);
- u2 = NA_PTR_TYPE(rb_u2, doublereal*);
- if (!NA_IsNArray(rb_phi))
- rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
- if (NA_RANK(rb_phi) != 1)
- rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_phi) != (q-1))
- rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
- if (NA_TYPE(rb_phi) != NA_DFLOAT)
- rb_phi = na_change_type(rb_phi, NA_DFLOAT);
- phi = NA_PTR_TYPE(rb_phi, doublereal*);
- if (!NA_IsNArray(rb_v2t))
- rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
- if (NA_RANK(rb_v2t) != 2)
- rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v2t) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
- ldv2t = NA_SHAPE0(rb_v2t);
- if (NA_TYPE(rb_v2t) != NA_DFLOAT)
- rb_v2t = na_change_type(rb_v2t, NA_DFLOAT);
- v2t = NA_PTR_TYPE(rb_v2t, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b11d = NA_PTR_TYPE(rb_b11d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b11e = NA_PTR_TYPE(rb_b11e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b12d = NA_PTR_TYPE(rb_b12d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b12e = NA_PTR_TYPE(rb_b12e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b21d = NA_PTR_TYPE(rb_b21d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b21e = NA_PTR_TYPE(rb_b21e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b22d = NA_PTR_TYPE(rb_b22d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b22e = NA_PTR_TYPE(rb_b22e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_theta_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- theta_out__ = NA_PTR_TYPE(rb_theta_out__, doublereal*);
- MEMCPY(theta_out__, theta, doublereal, NA_TOTAL(rb_theta));
- rb_theta = rb_theta_out__;
- theta = theta_out__;
- {
- int shape[2];
- shape[0] = ldu1;
- shape[1] = p;
- rb_u1_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u1_out__ = NA_PTR_TYPE(rb_u1_out__, doublereal*);
- MEMCPY(u1_out__, u1, doublereal, NA_TOTAL(rb_u1));
- rb_u1 = rb_u1_out__;
- u1 = u1_out__;
- {
- int shape[2];
- shape[0] = ldu2;
- shape[1] = m-p;
- rb_u2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u2_out__ = NA_PTR_TYPE(rb_u2_out__, doublereal*);
- MEMCPY(u2_out__, u2, doublereal, NA_TOTAL(rb_u2));
- rb_u2 = rb_u2_out__;
- u2 = u2_out__;
- {
- int shape[2];
- shape[0] = ldv1t;
- shape[1] = q;
- rb_v1t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v1t_out__ = NA_PTR_TYPE(rb_v1t_out__, doublereal*);
- MEMCPY(v1t_out__, v1t, doublereal, NA_TOTAL(rb_v1t));
- rb_v1t = rb_v1t_out__;
- v1t = v1t_out__;
- {
- int shape[2];
- shape[0] = ldv2t;
- shape[1] = m-q;
- rb_v2t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v2t_out__ = NA_PTR_TYPE(rb_v2t_out__, doublereal*);
- MEMCPY(v2t_out__, v2t, doublereal, NA_TOTAL(rb_v2t));
- rb_v2t = rb_v2t_out__;
- v2t = v2t_out__;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- dbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(14, rb_b11d, rb_b11e, rb_b12d, rb_b12e, rb_b21d, rb_b21e, rb_b22d, rb_b22e, rb_info, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t);
-}
-
-void
-init_lapack_dbbcsd(VALUE mLapack){
- rb_define_module_function(mLapack, "dbbcsd", rb_dbbcsd, -1);
-}
diff --git a/dbdsdc.c b/dbdsdc.c
deleted file mode 100644
index ce706ea..0000000
--- a/dbdsdc.c
+++ /dev/null
@@ -1,136 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dbdsdc_(char *uplo, char *compq, integer *n, doublereal *d, doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, doublereal *q, integer *iq, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dbdsdc(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_compq;
- char compq;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_ldu;
- integer ldu;
- VALUE rb_ldvt;
- integer ldvt;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_iq;
- integer *iq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- integer c__9;
- integer c__0;
- real smlsiz;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n u, vt, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, ldu, ldvt)\n or\n NumRu::Lapack.dbdsdc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DBDSDC computes the singular value decomposition (SVD) of a real\n* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,\n* using a divide and conquer method, where S is a diagonal matrix\n* with non-negative diagonal elements (the singular values of B), and\n* U and VT are orthogonal matrices of left and right singular vectors,\n* respectively. DBDSDC can be used to compute all singular values,\n* and optionally, singular vectors or singular vectors in compact form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See DLASD3 for details.\n*\n* The code currently calls DLASDQ if singular values only are desired.\n* However, it can be slightly modified to compute singular values\n* using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal.\n* = 'L': B is lower bidiagonal.\n*\n* COMPQ (input) CHARACTER*1\n* Specifies whether singular vectors are to be computed\n* as follows:\n* = 'N': Compute singular values only;\n* = 'P': Compute singular values and compute singular\n* vectors in compact form;\n* = 'I': Compute singular values and singular vectors.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the elements of E contain the offdiagonal\n* elements of the bidiagonal matrix whose SVD is desired.\n* On exit, E has been destroyed.\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, U contains the left singular vectors\n* of the bidiagonal matrix.\n* For other values of COMPQ, U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1.\n* If singular vectors are desired, then LDU >= max( 1, N ).\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, VT' contains the right singular\n* vectors of the bidiagonal matrix.\n* For other values of COMPQ, VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1.\n* If singular vectors are desired, then LDVT >= max( 1, N ).\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, Q contains all the DOUBLE PRECISION data in\n* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, Q is not referenced.\n*\n* IQ (output) INTEGER array, dimension (LDIQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, IQ contains all INTEGER data in\n* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, IQ is not referenced.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* If COMPQ = 'N' then LWORK >= (4 * N).\n* If COMPQ = 'P' then LWORK >= (6 * N).\n* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n*\n* IWORK (workspace) INTEGER array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value.\n* The update process of divide and conquer failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n* Changed dimension statement in comment describing E from (N) to\n* (N-1). Sven, 17 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_compq = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_ldu = argv[4];
- rb_ldvt = argv[5];
-
- c__9 = 9;
- c__0 = 0;
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- compq = StringValueCStr(rb_compq)[0];
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- ldu = lsame_(&compq,"I") ? MAX(1,n) : 0;
- smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
- ldvt = lsame_(&compq,"I") ? MAX(1,n) : 0;
- {
- int shape[2];
- shape[0] = lsame_(&compq,"I") ? ldu : 0;
- shape[1] = lsame_(&compq,"I") ? n : 0;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = lsame_(&compq,"I") ? ldvt : 0;
- shape[1] = lsame_(&compq,"I") ? n : 0;
- rb_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- {
- int shape[1];
- shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
- rb_q = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[1];
- shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
- rb_iq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iq = NA_PTR_TYPE(rb_iq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(doublereal, (MAX(1,lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0)));
- iwork = ALLOC_N(integer, (8*n));
-
- dbdsdc_(&uplo, &compq, &n, d, e, u, &ldu, vt, &ldvt, q, iq, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_u, rb_vt, rb_q, rb_iq, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dbdsdc(VALUE mLapack){
- rb_define_module_function(mLapack, "dbdsdc", rb_dbdsdc, -1);
-}
diff --git a/dbdsqr.c b/dbdsqr.c
deleted file mode 100644
index 52049bd..0000000
--- a/dbdsqr.c
+++ /dev/null
@@ -1,163 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dbdsqr_(char *uplo, integer *n, integer *ncvt, integer *nru, integer *ncc, doublereal *d, doublereal *e, doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dbdsqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nru;
- integer nru;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_vt_out__;
- doublereal *vt_out__;
- VALUE rb_u_out__;
- doublereal *u_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer n;
- integer ldvt;
- integer ncvt;
- integer ldu;
- integer ldc;
- integer ncc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.dbdsqr( uplo, nru, d, e, vt, u, c)\n or\n NumRu::Lapack.dbdsqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**T\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**T*VT instead of\n* P**T, for given real input matrices U and VT. When U and VT are the\n* orthogonal matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by DGEBRD, then\n*\n* A = (U*Q) * S * (P**T*VT)\n*\n* is the SVD of A. Optionally, the subroutine may also compute Q**T*C\n* for a given real input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B. \n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**T * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**T * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0:\n* if NCVT = NRU = NCC = 0,\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n* else NCVT = NRU = NCC = 0,\n* the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_nru = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vt = argv[4];
- rb_u = argv[5];
- rb_c = argv[6];
-
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (6th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_DFLOAT)
- rb_u = na_change_type(rb_u, NA_DFLOAT);
- u = NA_PTR_TYPE(rb_u, doublereal*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
- ncvt = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_DFLOAT)
- rb_vt = na_change_type(rb_vt, NA_DFLOAT);
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- nru = NUM2INT(rb_nru);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = ncvt;
- rb_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, doublereal*);
- MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, doublereal*);
- MEMCPY(u_out__, u, doublereal, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (4*n));
-
- dbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_info, rb_d, rb_e, rb_vt, rb_u, rb_c);
-}
-
-void
-init_lapack_dbdsqr(VALUE mLapack){
- rb_define_module_function(mLapack, "dbdsqr", rb_dbdsqr, -1);
-}
diff --git a/ddisna.c b/ddisna.c
deleted file mode 100644
index 6c9456a..0000000
--- a/ddisna.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ddisna_(char *job, integer *m, integer *n, doublereal *d, doublereal *sep, integer *info);
-
-static VALUE
-rb_ddisna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_n;
- integer n;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_sep;
- doublereal *sep;
- VALUE rb_info;
- integer info;
-
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sep, info = NumRu::Lapack.ddisna( job, n, d)\n or\n NumRu::Lapack.ddisna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )\n\n* Purpose\n* =======\n*\n* DDISNA computes the reciprocal condition numbers for the eigenvectors\n* of a real symmetric or complex Hermitian matrix or for the left or\n* right singular vectors of a general m-by-n matrix. The reciprocal\n* condition number is the 'gap' between the corresponding eigenvalue or\n* singular value and the nearest other one.\n*\n* The bound on the error, measured by angle in radians, in the I-th\n* computed vector is given by\n*\n* DLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n*\n* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed\n* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of\n* the error bound.\n*\n* DDISNA may also be used to compute error bounds for eigenvectors of\n* the generalized symmetric definite eigenproblem.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies for which problem the reciprocal condition numbers\n* should be computed:\n* = 'E': the eigenvectors of a symmetric/Hermitian matrix;\n* = 'L': the left singular vectors of a general matrix;\n* = 'R': the right singular vectors of a general matrix.\n*\n* M (input) INTEGER\n* The number of rows of the matrix. M >= 0.\n*\n* N (input) INTEGER\n* If JOB = 'L' or 'R', the number of columns of the matrix,\n* in which case N >= 0. Ignored if JOB = 'E'.\n*\n* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The eigenvalues (if JOB = 'E') or singular values (if JOB =\n* 'L' or 'R') of the matrix, in either increasing or decreasing\n* order. If singular values, they must be non-negative.\n*\n* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The reciprocal condition numbers of the vectors.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_job = argv[0];
- rb_n = argv[1];
- rb_d = argv[2];
-
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = lsame_(&job,"E") ? m : ((lsame_(&job,"L")) || (lsame_(&job,"R"))) ? MIN(m,n) : 0;
- rb_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sep = NA_PTR_TYPE(rb_sep, doublereal*);
-
- ddisna_(&job, &m, &n, d, sep, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_sep, rb_info);
-}
-
-void
-init_lapack_ddisna(VALUE mLapack){
- rb_define_module_function(mLapack, "ddisna", rb_ddisna, -1);
-}
diff --git a/dev/common.rb b/dev/common.rb
index f487721..7978113 100644
--- a/dev/common.rb
+++ b/dev/common.rb
@@ -1,6 +1,6 @@
def get_vars(dim)
ary = Array.new
- dim.gsub(/MAX\(/,",").gsub(/MIN\(/,",").gsub(/log\(/,",").gsub(/abs\(/,",").gsub(/sqrt\(/,",").gsub(/pow\(/,",").gsub(/LG\(/,",").gsub(/lsame_\(\&([^,]+),[^)]+\)/,'\1').gsub(/[\(\)\+\-\*\/:\?=\&\|]+/,",").split(",").each{|d|
+ dim.gsub(/MAX\(/,",").gsub(/MIN\(/,",").gsub(/log\(/,",").gsub(/abs\(/,",").gsub(/sqrt\(/,",").gsub(/pow\(/,",").gsub(/LG\(/,",").gsub(/lsame_\(\&([^,]+),[^)]+\)/,'\1').gsub(/ilatrans_\([^)]+\)/,",").gsub(/ilaenv_\(([^,]+),[^,]+/,'\1').gsub(/[\(\)\+\-\*\/:\?=\&\|]+/,",").split(",").each{|d|
d.strip!
next if (d == "") || (/^\d+(\.\d+)?$/ =~ d) || /^\"[^\"]+\"$/ =~ d || d=="int" || d=="double"
ary.push d
diff --git a/dev/defs/cbbcsd b/dev/defs/cbbcsd
index 979ca23..0b8d84b 100644
--- a/dev/defs/cbbcsd
+++ b/dev/defs/cbbcsd
@@ -121,6 +121,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*q
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgbequb b/dev/defs/cgbequb
index 19f876d..5409179 100644
--- a/dev/defs/cgbequb
+++ b/dev/defs/cgbequb
@@ -47,7 +47,7 @@
:type: integer
:intent: output
:substitutions:
- ldab: m
+ m: ldab
:fortran_help: " SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgbsvx b/dev/defs/cgbsvx
index d656654..503e1ee 100644
--- a/dev/defs/cgbsvx
+++ b/dev/defs/cgbsvx
@@ -36,6 +36,7 @@
:dims:
- ldafb
- n
+ :option: true
- ldafb:
:type: integer
:intent: input
@@ -44,19 +45,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: complex
:intent: input/output
@@ -102,7 +107,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldafb: 2*kl+ku+1
:fortran_help: " SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgebrd b/dev/defs/cgebrd
index 3794bfe..defd230 100644
--- a/dev/defs/cgebrd
+++ b/dev/defs/cgebrd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgeequb b/dev/defs/cgeequb
index a9622e0..4c7f04c 100644
--- a/dev/defs/cgeequb
+++ b/dev/defs/cgeequb
@@ -41,7 +41,7 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
:fortran_help: " SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgees b/dev/defs/cgees
index 2f2f058..0873fbb 100644
--- a/dev/defs/cgees
+++ b/dev/defs/cgees
@@ -51,6 +51,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cgeesx b/dev/defs/cgeesx
index a5d3561..b9f2a5e 100644
--- a/dev/defs/cgeesx
+++ b/dev/defs/cgeesx
@@ -60,6 +60,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n/2 : 2*n"
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cgeev b/dev/defs/cgeev
index 0e48556..2e6bbb9 100644
--- a/dev/defs/cgeev
+++ b/dev/defs/cgeev
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cgeevx b/dev/defs/cgeevx
index ccb15ee..0504b0b 100644
--- a/dev/defs/cgeevx
+++ b/dev/defs/cgeevx
@@ -82,6 +82,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n+2*n : 0"
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cgegs b/dev/defs/cgegs
index 4e1ef33..d5972b2 100644
--- a/dev/defs/cgegs
+++ b/dev/defs/cgegs
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cgegv b/dev/defs/cgegv
index c151085..f7518b0 100644
--- a/dev/defs/cgegv
+++ b/dev/defs/cgegv
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: output
diff --git a/dev/defs/cgehrd b/dev/defs/cgehrd
index 0db14a2..94b5de9 100644
--- a/dev/defs/cgehrd
+++ b/dev/defs/cgehrd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgelqf b/dev/defs/cgelqf
index a8e0131..4b8cbb4 100644
--- a/dev/defs/cgelqf
+++ b/dev/defs/cgelqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgels b/dev/defs/cgels
index 410760c..c67be13 100644
--- a/dev/defs/cgels
+++ b/dev/defs/cgels
@@ -28,7 +28,10 @@
:type: complex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -41,11 +44,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n) + MAX(MIN(m,n),nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgelsd b/dev/defs/cgelsd
index 7cc2071..6d66fda 100644
--- a/dev/defs/cgelsd
+++ b/dev/defs/cgelsd
@@ -14,7 +14,7 @@
:intent: input
- a:
:type: complex
- :intent: input/output
+ :intent: input
:dims:
- lda
- n
@@ -25,7 +25,10 @@
:type: complex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "m>=n ? 2*n+n*nrhs : 2*m+m*nrhs"
- rwork:
:type: real
:intent: workspace
@@ -63,6 +68,8 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
+ ldb: MAX(m,n)
c__9: "9"
c__0: "0"
liwork: MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)))
diff --git a/dev/defs/cgelss b/dev/defs/cgelss
index 7cc5b24..ece6c18 100644
--- a/dev/defs/cgelss
+++ b/dev/defs/cgelss
@@ -25,7 +25,10 @@
:type: complex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs)
- rwork:
:type: real
:intent: workspace
@@ -57,8 +62,9 @@
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m, n)
:fortran_help: " SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgelsy b/dev/defs/cgelsy
index a596381..daf89dd 100644
--- a/dev/defs/cgelsy
+++ b/dev/defs/cgelsy
@@ -25,7 +25,10 @@
:type: complex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs)
- rwork:
:type: real
:intent: workspace
@@ -57,8 +62,9 @@
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgeqlf b/dev/defs/cgeqlf
index 607c97e..c7e7fca 100644
--- a/dev/defs/cgeqlf
+++ b/dev/defs/cgeqlf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgeqp3 b/dev/defs/cgeqp3
index 61d1894..de5ee08 100644
--- a/dev/defs/cgeqp3
+++ b/dev/defs/cgeqp3
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n+1
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cgeqrf b/dev/defs/cgeqrf
index 4d78337..d86215d 100644
--- a/dev/defs/cgeqrf
+++ b/dev/defs/cgeqrf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgeqrfp b/dev/defs/cgeqrfp
index 87e8a25..ec2ab4e 100644
--- a/dev/defs/cgeqrfp
+++ b/dev/defs/cgeqrfp
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgerqf b/dev/defs/cgerqf
index d1b5413..5f38a7c 100644
--- a/dev/defs/cgerqf
+++ b/dev/defs/cgerqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgesdd b/dev/defs/cgesdd
index c2791f3..9e338f9 100644
--- a/dev/defs/cgesdd
+++ b/dev/defs/cgesdd
@@ -52,11 +52,13 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"N\") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,\"O\") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0"
- rwork:
:type: real
:intent: workspace
:dims:
- - "MAX(1, lsame_(&jobz,\"N\") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1))"
+ - "MAX(1, (lsame_(&jobz,\"N\") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))"
- iwork:
:type: integer
:intent: workspace
@@ -66,9 +68,10 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0"
- ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m == n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
- ldu: "((lsame_(&jobz,\"S\")) || ((('a') || (((lsame_(&jobz,\"O\")) && (m < n)))))) ? m : 1"
+ ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
+ ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1"
:fortran_help: " SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgesvd b/dev/defs/cgesvd
index 6588183..a43f088 100644
--- a/dev/defs/cgesvd
+++ b/dev/defs/cgesvd
@@ -21,6 +21,9 @@
:dims:
- lda
- n
+ :outdims:
+ - lda
+ - MIN(m,n)
- lda:
:type: integer
:intent: input
@@ -55,6 +58,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(1, 2*MIN(m,n)+MAX(m,n))
- rwork:
:type: real
:intent: workspace
@@ -64,6 +69,7 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1"
ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1"
:fortran_help: " SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n\
diff --git a/dev/defs/cgesvx b/dev/defs/cgesvx
index e179536..26b57b1 100644
--- a/dev/defs/cgesvx
+++ b/dev/defs/cgesvx
@@ -30,6 +30,7 @@
:dims:
- ldaf
- n
+ :option: true
- ldaf:
:type: integer
:intent: input
@@ -38,19 +39,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: complex
:intent: input/output
@@ -96,7 +101,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldaf: n
:fortran_help: " SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cgetri b/dev/defs/cgetri
index cb259c4..36eda79 100644
--- a/dev/defs/cgetri
+++ b/dev/defs/cgetri
@@ -28,6 +28,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cggbal b/dev/defs/cggbal
index 670c038..e9b2213 100644
--- a/dev/defs/cggbal
+++ b/dev/defs/cggbal
@@ -46,7 +46,8 @@
- work:
:type: real
:intent: workspace
- :dims: "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0"
+ :dims:
+ - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgges b/dev/defs/cgges
index c841c61..7709ed4 100644
--- a/dev/defs/cgges
+++ b/dev/defs/cgges
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cggesx b/dev/defs/cggesx
index e1250cc..401cb43 100644
--- a/dev/defs/cggesx
+++ b/dev/defs/cggesx
@@ -90,6 +90,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(2*n,n*n/2) : 2*n"
- rwork:
:type: real
:intent: workspace
@@ -103,6 +105,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+2"
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/cggev b/dev/defs/cggev
index 59cd94b..1d38b97 100644
--- a/dev/defs/cggev
+++ b/dev/defs/cggev
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(1,2*n)
- rwork:
:type: real
:intent: output
diff --git a/dev/defs/cggevx b/dev/defs/cggevx
index b2b0c6a..daa1b18 100644
--- a/dev/defs/cggevx
+++ b/dev/defs/cggevx
@@ -104,6 +104,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&sense,\"E\") ? 4*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+2*n : 2*n"
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cggglm b/dev/defs/cggglm
index 04b7930..bfe5694 100644
--- a/dev/defs/cggglm
+++ b/dev/defs/cggglm
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cgglse b/dev/defs/cgglse
index 64a46db..e103e42 100644
--- a/dev/defs/cgglse
+++ b/dev/defs/cgglse
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cggqrf b/dev/defs/cggqrf
index f1fcdf9..32cd3c3 100644
--- a/dev/defs/cggqrf
+++ b/dev/defs/cggqrf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cggrqf b/dev/defs/cggrqf
index 733a938..d7e5349 100644
--- a/dev/defs/cggrqf
+++ b/dev/defs/cggrqf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cggsvd b/dev/defs/cggsvd
index 3d5ac9a..1faf048 100644
--- a/dev/defs/cggsvd
+++ b/dev/defs/cggsvd
@@ -102,9 +102,9 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
- ldb: p
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
:fortran_help: " SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n\
diff --git a/dev/defs/cggsvp b/dev/defs/cggsvp
index a28d6d8..3a115bb 100644
--- a/dev/defs/cggsvp
+++ b/dev/defs/cggsvp
@@ -103,8 +103,8 @@
:type: integer
:intent: output
:substitutions:
- lda: m
- ldb: p
+ m: lda
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
diff --git a/dev/defs/chbevd b/dev/defs/chbevd
index 1827fb9..01edd46 100644
--- a/dev/defs/chbevd
+++ b/dev/defs/chbevd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0"
- rwork:
:type: real
:intent: output
@@ -54,6 +56,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -62,6 +66,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/chbgvd b/dev/defs/chbgvd
index db78195..81a66ee 100644
--- a/dev/defs/chbgvd
+++ b/dev/defs/chbgvd
@@ -58,6 +58,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0"
- rwork:
:type: real
:intent: output
@@ -66,6 +68,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -74,6 +78,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/chbgvx b/dev/defs/chbgvx
index b545075..33644d1 100644
--- a/dev/defs/chbgvx
+++ b/dev/defs/chbgvx
@@ -105,7 +105,7 @@
:intent: output
:substitutions:
ldz: "lsame_(&jobz,\"V\") ? n : 1"
- ldq: "1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0"
+ ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0"
:fortran_help: " SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cheev b/dev/defs/cheev
index 7379e65..1b6de80 100644
--- a/dev/defs/cheev
+++ b/dev/defs/cheev
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n-1
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/cheevd b/dev/defs/cheevd
index d4941db..f068a16 100644
--- a/dev/defs/cheevd
+++ b/dev/defs/cheevd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0"
- rwork:
:type: real
:intent: output
@@ -42,6 +44,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -50,6 +54,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cheevr b/dev/defs/cheevr
index d378e9e..8a3d244 100644
--- a/dev/defs/cheevr
+++ b/dev/defs/cheevr
@@ -69,6 +69,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: output
@@ -77,6 +79,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: 24*n
- iwork:
:type: integer
:intent: output
@@ -85,6 +89,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: 10*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cheevx b/dev/defs/cheevx
index c57b151..e84325e 100644
--- a/dev/defs/cheevx
+++ b/dev/defs/cheevx
@@ -64,6 +64,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : 2*n"
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/chegv b/dev/defs/chegv
index d652cde..eafce5b 100644
--- a/dev/defs/chegv
+++ b/dev/defs/chegv
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n-1
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/chegvd b/dev/defs/chegvd
index 023745c..0871317 100644
--- a/dev/defs/chegvd
+++ b/dev/defs/chegvd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0"
- rwork:
:type: real
:intent: output
@@ -54,6 +56,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -62,6 +66,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/chegvx b/dev/defs/chegvx
index 259fe92..96c4a3f 100644
--- a/dev/defs/chegvx
+++ b/dev/defs/chegvx
@@ -76,6 +76,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/chesvx b/dev/defs/chesvx
index 06cc8ad..e6e715d 100644
--- a/dev/defs/chesvx
+++ b/dev/defs/chesvx
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/chfrk b/dev/defs/chfrk
index 7b9accd..1349a45 100644
--- a/dev/defs/chfrk
+++ b/dev/defs/chfrk
@@ -37,9 +37,12 @@
:type: complex
:intent: input/output
:dims:
- - n*(n+1)/2
+ - ldc
:substitutions:
lda: "lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)"
+ n: ((int)sqrtf(ldc*8+1.0f)-1)/2
+:extra:
+ ldc: integer
:fortran_help: " SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/chgeqz b/dev/defs/chgeqz
index abc2e62..6076f17 100644
--- a/dev/defs/chgeqz
+++ b/dev/defs/chgeqz
@@ -75,6 +75,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/chpevd b/dev/defs/chpevd
index 76b25bd..0810f89 100644
--- a/dev/defs/chpevd
+++ b/dev/defs/chpevd
@@ -39,6 +39,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0"
- rwork:
:type: real
:intent: output
@@ -47,6 +49,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -55,6 +59,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/chpgvd b/dev/defs/chpgvd
index 27fc9f8..734544f 100644
--- a/dev/defs/chpgvd
+++ b/dev/defs/chpgvd
@@ -47,6 +47,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0"
- rwork:
:type: real
:intent: workspace
@@ -55,6 +57,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -63,6 +67,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/chseqr b/dev/defs/chseqr
index cd5b908..76694ef 100644
--- a/dev/defs/chseqr
+++ b/dev/defs/chseqr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cla_gbamv b/dev/defs/cla_gbamv
index 42df528..d61eaf2 100644
--- a/dev/defs/cla_gbamv
+++ b/dev/defs/cla_gbamv
@@ -34,7 +34,7 @@
:type: real
:intent: input
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
- incx:
:type: integer
:intent: input
@@ -45,7 +45,7 @@
:type: real
:intent: input/output
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
- incy:
:type: integer
:intent: input
diff --git a/dev/defs/cla_geamv b/dev/defs/cla_geamv
index fd96df2..b42670d 100644
--- a/dev/defs/cla_geamv
+++ b/dev/defs/cla_geamv
@@ -28,7 +28,7 @@
:type: complex
:intent: input
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
- incx:
:type: integer
:intent: input
@@ -39,7 +39,7 @@
:type: real
:intent: input/output
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
- incy:
:type: integer
:intent: input
diff --git a/dev/defs/cla_heamv b/dev/defs/cla_heamv
index 317c40f..af42a48 100644
--- a/dev/defs/cla_heamv
+++ b/dev/defs/cla_heamv
@@ -41,7 +41,7 @@
:type: integer
:intent: input
:substitutions:
- lda: MAX(1,n)
+ lda: n
:fortran_help: " SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cla_syamv b/dev/defs/cla_syamv
index c55b449..bbdde07 100644
--- a/dev/defs/cla_syamv
+++ b/dev/defs/cla_syamv
@@ -41,7 +41,7 @@
:type: integer
:intent: input
:substitutions:
- lda: MAX(1, n)
+ n: lda
:fortran_help: " SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/claqr0 b/dev/defs/claqr0
index 9a3b1a1..9ab0fbf 100644
--- a/dev/defs/claqr0
+++ b/dev/defs/claqr0
@@ -55,6 +55,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/claqr2 b/dev/defs/claqr2
index 61f793c..004a194 100644
--- a/dev/defs/claqr2
+++ b/dev/defs/claqr2
@@ -97,6 +97,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/claqr3 b/dev/defs/claqr3
index d19531a..fa5dca5 100644
--- a/dev/defs/claqr3
+++ b/dev/defs/claqr3
@@ -97,6 +97,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/claqr4 b/dev/defs/claqr4
index 1911f03..b9df94e 100644
--- a/dev/defs/claqr4
+++ b/dev/defs/claqr4
@@ -55,6 +55,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/clarfb b/dev/defs/clarfb
index 34016d6..808e83e 100644
--- a/dev/defs/clarfb
+++ b/dev/defs/clarfb
@@ -61,7 +61,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/clarzb b/dev/defs/clarzb
index 24ca8ae..5a3ccc1 100644
--- a/dev/defs/clarzb
+++ b/dev/defs/clarzb
@@ -64,7 +64,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cspmv b/dev/defs/cspmv
index b23f509..d225edb 100644
--- a/dev/defs/cspmv
+++ b/dev/defs/cspmv
@@ -16,12 +16,12 @@
:type: complex
:intent: input
:dims:
- - ( n*( n + 1 ) )/2
+ - ldap
- x:
:type: complex
:intent: input
:dims:
- - 1 + ( n - 1 )*abs( incx )
+ - 1 + (n-1)*abs(incx)
- incx:
:type: integer
:intent: input
@@ -32,12 +32,14 @@
:type: complex
:intent: input/output
:dims:
- - 1 + ( n - 1 )*abs( incy )
+ - 1 + (n-1)*abs(incy)
- incy:
:type: integer
:intent: input
-:substitutions: {}
-
+:substitutions:
+ n: ((integer)sqrtf(8*ldap+1.0f)-1)/2
+:extras:
+ ldap: integer
:fortran_help: " SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/cstedc b/dev/defs/cstedc
index 9a9ce60..eddd405 100644
--- a/dev/defs/cstedc
+++ b/dev/defs/cstedc
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||lsame_(&compz,\"I\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? n*n : 0"
- rwork:
:type: real
:intent: output
@@ -44,6 +46,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -52,6 +56,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cstegr b/dev/defs/cstegr
index e648cd0..59c7931 100644
--- a/dev/defs/cstegr
+++ b/dev/defs/cstegr
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -75,6 +77,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cstemr b/dev/defs/cstemr
index dd6f08e..9b36906 100644
--- a/dev/defs/cstemr
+++ b/dev/defs/cstemr
@@ -70,6 +70,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -78,6 +80,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/csysv b/dev/defs/csysv
index d89c91b..9a3f3e6 100644
--- a/dev/defs/csysv
+++ b/dev/defs/csysv
@@ -43,6 +43,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/csysvx b/dev/defs/csysvx
index e3ad7ec..5ab0c3f 100644
--- a/dev/defs/csysvx
+++ b/dev/defs/csysvx
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n
- rwork:
:type: real
:intent: workspace
diff --git a/dev/defs/csytri2 b/dev/defs/csytri2
index 08bb0ee..5ef2924 100644
--- a/dev/defs/csytri2
+++ b/dev/defs/csytri2
@@ -27,10 +27,12 @@
:type: complex
:intent: workspace
:dims:
- - (n+nb+1)*(nb+3)
+ - lwork
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: (n+nb+1)*(nb+3)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ctgsen b/dev/defs/ctgsen
index f955939..3a47219 100644
--- a/dev/defs/ctgsen
+++ b/dev/defs/ctgsen
@@ -84,18 +84,22 @@
:type: complex
:intent: output
:dims:
- - "ijob==0 ? 0 : MAX(1,lwork)"
+ - MAX(1,lwork)
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0"
- iwork:
:type: integer
:intent: output
:dims:
- - "ijob==0 ? 0 : MAX(1,liwork)"
+ - MAX(1,liwork)
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ctgsna b/dev/defs/ctgsna
index 966c468..467b0d8 100644
--- a/dev/defs/ctgsna
+++ b/dev/defs/ctgsna
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/ctgsyl b/dev/defs/ctgsyl
index 1593ee9..79335e6 100644
--- a/dev/defs/ctgsyl
+++ b/dev/defs/ctgsyl
@@ -83,6 +83,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/ctrsen b/dev/defs/ctrsen
index 14248d4..11e792c 100644
--- a/dev/defs/ctrsen
+++ b/dev/defs/ctrsen
@@ -57,6 +57,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ctzrzf b/dev/defs/ctzrzf
index f2fa40d..c8e1fc2 100644
--- a/dev/defs/ctzrzf
+++ b/dev/defs/ctzrzf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunbdb b/dev/defs/cunbdb
index e5435b4..e69ba3e 100644
--- a/dev/defs/cunbdb
+++ b/dev/defs/cunbdb
@@ -92,6 +92,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m-q
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cungbr b/dev/defs/cungbr
index 6426185..b1e4033 100644
--- a/dev/defs/cungbr
+++ b/dev/defs/cungbr
@@ -37,6 +37,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunghr b/dev/defs/cunghr
index 01039b4..3ae3fbf 100644
--- a/dev/defs/cunghr
+++ b/dev/defs/cunghr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: ihi-ilo
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunglq b/dev/defs/cunglq
index 881d8de..f5e5347 100644
--- a/dev/defs/cunglq
+++ b/dev/defs/cunglq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cungql b/dev/defs/cungql
index dd4b2f4..c2a115f 100644
--- a/dev/defs/cungql
+++ b/dev/defs/cungql
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cungqr b/dev/defs/cungqr
index 65c098c..0f69133 100644
--- a/dev/defs/cungqr
+++ b/dev/defs/cungqr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cungrq b/dev/defs/cungrq
index 94c32ea..3538514 100644
--- a/dev/defs/cungrq
+++ b/dev/defs/cungrq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cungtr b/dev/defs/cungtr
index 6145201..0ee6e41 100644
--- a/dev/defs/cungtr
+++ b/dev/defs/cungtr
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmbr b/dev/defs/cunmbr
index 03eb01a..5e598c3 100644
--- a/dev/defs/cunmbr
+++ b/dev/defs/cunmbr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmhr b/dev/defs/cunmhr
index 8168424..d0bebde 100644
--- a/dev/defs/cunmhr
+++ b/dev/defs/cunmhr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmlq b/dev/defs/cunmlq
index 8e4f9c6..8e3377a 100644
--- a/dev/defs/cunmlq
+++ b/dev/defs/cunmlq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmql b/dev/defs/cunmql
index 27628bd..f4b46a1 100644
--- a/dev/defs/cunmql
+++ b/dev/defs/cunmql
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmqr b/dev/defs/cunmqr
index 422b96a..fc420fc 100644
--- a/dev/defs/cunmqr
+++ b/dev/defs/cunmqr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmrq b/dev/defs/cunmrq
index c017817..1f2256a 100644
--- a/dev/defs/cunmrq
+++ b/dev/defs/cunmrq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmrz b/dev/defs/cunmrz
index 7df5add..bd3c87b 100644
--- a/dev/defs/cunmrz
+++ b/dev/defs/cunmrz
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/cunmtr b/dev/defs/cunmtr
index 6b1c6c8..31ecab2 100644
--- a/dev/defs/cunmtr
+++ b/dev/defs/cunmtr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dbbcsd b/dev/defs/dbbcsd
index 9e539cf..2e1a2aa 100644
--- a/dev/defs/dbbcsd
+++ b/dev/defs/dbbcsd
@@ -121,6 +121,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*q
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgbequb b/dev/defs/dgbequb
index af9acf2..051dad8 100644
--- a/dev/defs/dgbequb
+++ b/dev/defs/dgbequb
@@ -47,7 +47,7 @@
:type: integer
:intent: output
:substitutions:
- ldab: m
+ m: ldab
:fortran_help: " SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgbsvx b/dev/defs/dgbsvx
index 212f154..d19d712 100644
--- a/dev/defs/dgbsvx
+++ b/dev/defs/dgbsvx
@@ -36,6 +36,7 @@
:dims:
- ldafb
- n
+ :option: true
- ldafb:
:type: integer
:intent: input
@@ -44,19 +45,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: doublereal
:intent: input/output
@@ -102,7 +107,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldafb: 2*kl+ku+1
:fortran_help: " SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgebrd b/dev/defs/dgebrd
index 9765822..f4b85b1 100644
--- a/dev/defs/dgebrd
+++ b/dev/defs/dgebrd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgeequb b/dev/defs/dgeequb
index 2f8dece..07c0b46 100644
--- a/dev/defs/dgeequb
+++ b/dev/defs/dgeequb
@@ -41,7 +41,7 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
:fortran_help: " SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgees b/dev/defs/dgees
index c9c82e9..0534624 100644
--- a/dev/defs/dgees
+++ b/dev/defs/dgees
@@ -56,6 +56,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/dgeesx b/dev/defs/dgeesx
index a24b178..c1c25fe 100644
--- a/dev/defs/dgeesx
+++ b/dev/defs/dgeesx
@@ -65,6 +65,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n+n*n/2 : 3*n"
- iwork:
:type: integer
:intent: output
diff --git a/dev/defs/dgeev b/dev/defs/dgeev
index b06734d..48b27df 100644
--- a/dev/defs/dgeev
+++ b/dev/defs/dgeev
@@ -57,6 +57,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 4*n : 3*n"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgeevx b/dev/defs/dgeevx
index 17b2079..fc42a60 100644
--- a/dev/defs/dgeevx
+++ b/dev/defs/dgeevx
@@ -87,6 +87,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 3*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*(n+6) : 0"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dgegs b/dev/defs/dgegs
index 3d22c50..9b6a7eb 100644
--- a/dev/defs/dgegs
+++ b/dev/defs/dgegs
@@ -71,6 +71,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 4*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgegv b/dev/defs/dgegv
index 6205795..df1ffe0 100644
--- a/dev/defs/dgegv
+++ b/dev/defs/dgegv
@@ -71,6 +71,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgehrd b/dev/defs/dgehrd
index 5d3d32f..b982f2c 100644
--- a/dev/defs/dgehrd
+++ b/dev/defs/dgehrd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgejsv b/dev/defs/dgejsv
index 667955e..dc40525 100644
--- a/dev/defs/dgejsv
+++ b/dev/defs/dgejsv
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobu,\"N\")&&lsame_(&jobv,\"N\")) ? MAX(MAX(2*m+n,4*n+n*n),7) : lsame_(&jobv,\"V\") ? MAX(2*n+m,7) : ((lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\"))&&lsame_(&jobv,\"V\")) ? MAX(MAX(6*n+2*n*n,m+3*n+n*n),7) : MAX(2*n+m,7)"
- iwork:
:type: integer
:intent: output
diff --git a/dev/defs/dgelqf b/dev/defs/dgelqf
index e4cf210..fa43005 100644
--- a/dev/defs/dgelqf
+++ b/dev/defs/dgelqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgels b/dev/defs/dgels
index 964cedf..ea2536e 100644
--- a/dev/defs/dgels
+++ b/dev/defs/dgels
@@ -28,7 +28,10 @@
:type: doublereal
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -41,11 +44,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n) + MAX(MIN(m,n),nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgelsd b/dev/defs/dgelsd
index 6337973..05aa9b3 100644
--- a/dev/defs/dgelsd
+++ b/dev/defs/dgelsd
@@ -25,7 +25,10 @@
:type: doublereal
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1)"
- iwork:
:type: integer
:intent: workspace
@@ -58,6 +63,8 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
+ ldb: MAX(m,n)
c__9: "9"
c__0: "0"
liwork: 3*(MIN(m,n))*nlvl+11*(MIN(m,n))
diff --git a/dev/defs/dgelss b/dev/defs/dgelss
index adfd6bb..94c47f0 100644
--- a/dev/defs/dgelss
+++ b/dev/defs/dgelss
@@ -25,7 +25,10 @@
:type: doublereal
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,11 +52,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgelsy b/dev/defs/dgelsy
index 380d55b..fc9608d 100644
--- a/dev/defs/dgelsy
+++ b/dev/defs/dgelsy
@@ -25,7 +25,10 @@
:type: doublereal
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,11 +52,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgeqlf b/dev/defs/dgeqlf
index 7ed7c71..d92d2ac 100644
--- a/dev/defs/dgeqlf
+++ b/dev/defs/dgeqlf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgeqp3 b/dev/defs/dgeqp3
index 436bc73..f24e16c 100644
--- a/dev/defs/dgeqp3
+++ b/dev/defs/dgeqp3
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n+1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgeqrf b/dev/defs/dgeqrf
index ff5ab7e..85a6e15 100644
--- a/dev/defs/dgeqrf
+++ b/dev/defs/dgeqrf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgeqrfp b/dev/defs/dgeqrfp
index ec7f44a..559e170 100644
--- a/dev/defs/dgeqrfp
+++ b/dev/defs/dgeqrfp
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgerqf b/dev/defs/dgerqf
index 3a3cb22..28720ba 100644
--- a/dev/defs/dgerqf
+++ b/dev/defs/dgerqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgesdd b/dev/defs/dgesdd
index cd62eab..cc0cfc6 100644
--- a/dev/defs/dgesdd
+++ b/dev/defs/dgesdd
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"N\") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,\"O\") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0"
- iwork:
:type: integer
:intent: workspace
@@ -61,9 +63,10 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0"
- ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m == n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
- ldu: "((lsame_(&jobz,\"S\")) || ((('a') || (((lsame_(&jobz,\"O\")) && (m < n)))))) ? m : 1"
+ ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
+ ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1"
:fortran_help: " SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgesvd b/dev/defs/dgesvd
index 899ded4..d8a9494 100644
--- a/dev/defs/dgesvd
+++ b/dev/defs/dgesvd
@@ -21,6 +21,9 @@
:dims:
- lda
- n
+ :outdims:
+ - lda
+ - MIN(m,n)
- lda:
:type: integer
:intent: input
@@ -55,10 +58,13 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n))
- info:
:type: integer
:intent: output
:substitutions:
+ m: lda
ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1"
ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1"
:fortran_help: " SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n\
diff --git a/dev/defs/dgesvj b/dev/defs/dgesvj
index d9cc127..10a4f90 100644
--- a/dev/defs/dgesvj
+++ b/dev/defs/dgesvj
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(6,m+n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgesvx b/dev/defs/dgesvx
index 2927b90..30d47d4 100644
--- a/dev/defs/dgesvx
+++ b/dev/defs/dgesvx
@@ -30,6 +30,7 @@
:dims:
- ldaf
- n
+ :option: true
- ldaf:
:type: integer
:intent: input
@@ -38,19 +39,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: doublereal
:intent: input/output
@@ -96,7 +101,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldaf: n
:fortran_help: " SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dgetri b/dev/defs/dgetri
index 98d1811..1d7e74e 100644
--- a/dev/defs/dgetri
+++ b/dev/defs/dgetri
@@ -28,6 +28,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgges b/dev/defs/dgges
index 9ec3ab6..59ba7cc 100644
--- a/dev/defs/dgges
+++ b/dev/defs/dgges
@@ -82,6 +82,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(8*n,6*n+16)
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/dggesx b/dev/defs/dggesx
index fd66a95..be457a6 100644
--- a/dev/defs/dggesx
+++ b/dev/defs/dggesx
@@ -95,6 +95,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16)"
- iwork:
:type: integer
:intent: workspace
@@ -103,6 +105,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+6"
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/dggev b/dev/defs/dggev
index 51f4b89..ba029a3 100644
--- a/dev/defs/dggev
+++ b/dev/defs/dggev
@@ -71,6 +71,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(1,8*n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dggevx b/dev/defs/dggevx
index 0abf7ae..894f7fd 100644
--- a/dev/defs/dggevx
+++ b/dev/defs/dggevx
@@ -109,6 +109,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&balanc,\"S\")||lsame_(&balanc,\"B\")||lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 6*n : lsame_(&sense,\"E\") ? 10*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+8*n+16 : 2*n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dggglm b/dev/defs/dggglm
index 857080a..2f3f174 100644
--- a/dev/defs/dggglm
+++ b/dev/defs/dggglm
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgglse b/dev/defs/dgglse
index dec6703..db0f99a 100644
--- a/dev/defs/dgglse
+++ b/dev/defs/dgglse
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dggqrf b/dev/defs/dggqrf
index c0199ee..159c24c 100644
--- a/dev/defs/dggqrf
+++ b/dev/defs/dggqrf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dggrqf b/dev/defs/dggrqf
index 3eb3f29..af87c84 100644
--- a/dev/defs/dggrqf
+++ b/dev/defs/dggrqf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dggsvd b/dev/defs/dggsvd
index 429fb6f..930f3d8 100644
--- a/dev/defs/dggsvd
+++ b/dev/defs/dggsvd
@@ -97,9 +97,9 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
- ldb: p
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
:fortran_help: " SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n\
diff --git a/dev/defs/dggsvp b/dev/defs/dggsvp
index 626807f..bdb29a7 100644
--- a/dev/defs/dggsvp
+++ b/dev/defs/dggsvp
@@ -98,7 +98,7 @@
:intent: output
:substitutions:
m: lda
- ldb: p
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
diff --git a/dev/defs/dgsvj0 b/dev/defs/dgsvj0
index 8af847c..159aae2 100644
--- a/dev/defs/dgsvj0
+++ b/dev/defs/dgsvj0
@@ -63,6 +63,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dgsvj1 b/dev/defs/dgsvj1
index 2020c8d..5bc3118 100644
--- a/dev/defs/dgsvj1
+++ b/dev/defs/dgsvj1
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dhgeqz b/dev/defs/dhgeqz
index 25b5a7b..63e5647 100644
--- a/dev/defs/dhgeqz
+++ b/dev/defs/dhgeqz
@@ -80,6 +80,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dhseqr b/dev/defs/dhseqr
index 35721c0..6c19b2d 100644
--- a/dev/defs/dhseqr
+++ b/dev/defs/dhseqr
@@ -54,6 +54,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dla_gbamv b/dev/defs/dla_gbamv
index a7d035d..722c32b 100644
--- a/dev/defs/dla_gbamv
+++ b/dev/defs/dla_gbamv
@@ -33,7 +33,7 @@
:type: doublereal
:intent: input
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
- incx:
:type: integer
:intent: input
@@ -44,12 +44,12 @@
:type: doublereal
:intent: input/output
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
- incy:
:type: integer
:intent: input
:substitutions:
- lda: max( 1, m )
+ lda: MAX( 1, m )
:fortran_help: " SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dla_gbrfsx_extended b/dev/defs/dla_gbrfsx_extended
index a5acde9..c6b760e 100644
--- a/dev/defs/dla_gbrfsx_extended
+++ b/dev/defs/dla_gbrfsx_extended
@@ -34,7 +34,7 @@
:type: doublereal
:intent: input
:dims:
- - ldab
+ - ldafb
- n
- ldafb:
:type: integer
@@ -129,7 +129,7 @@
:type: integer
:intent: output
:substitutions:
- ldab: n
+ n: ldab
ldafb: n
n_norms: "3"
:fortran_help: " SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\
diff --git a/dev/defs/dla_geamv b/dev/defs/dla_geamv
index a84eddd..2c7a35a 100644
--- a/dev/defs/dla_geamv
+++ b/dev/defs/dla_geamv
@@ -28,7 +28,7 @@
:type: doublereal
:intent: input
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
- incx:
:type: integer
:intent: input
@@ -39,7 +39,7 @@
:type: doublereal
:intent: input/output
:dims:
- - "lsame_(&trans,\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)"
+ - "trans == ilatrans_(\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)"
- incy:
:type: integer
:intent: input
diff --git a/dev/defs/dlaqr0 b/dev/defs/dlaqr0
index 714371a..0d88d78 100644
--- a/dev/defs/dlaqr0
+++ b/dev/defs/dlaqr0
@@ -60,6 +60,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dlaqr2 b/dev/defs/dlaqr2
index c9f72cb..6dd390f 100644
--- a/dev/defs/dlaqr2
+++ b/dev/defs/dlaqr2
@@ -102,6 +102,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/dlaqr3 b/dev/defs/dlaqr3
index 42cc484..bc18fd4 100644
--- a/dev/defs/dlaqr3
+++ b/dev/defs/dlaqr3
@@ -102,6 +102,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/dlaqr4 b/dev/defs/dlaqr4
index 3bf14a1..0d97b99 100644
--- a/dev/defs/dlaqr4
+++ b/dev/defs/dlaqr4
@@ -60,6 +60,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dlarfb b/dev/defs/dlarfb
index 65623a5..96d89e4 100644
--- a/dev/defs/dlarfb
+++ b/dev/defs/dlarfb
@@ -61,7 +61,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dlarzb b/dev/defs/dlarzb
index cd1e261..2de9e82 100644
--- a/dev/defs/dlarzb
+++ b/dev/defs/dlarzb
@@ -64,7 +64,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dorbdb b/dev/defs/dorbdb
index 6c5b7ce..585b46f 100644
--- a/dev/defs/dorbdb
+++ b/dev/defs/dorbdb
@@ -92,11 +92,13 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m-q
- info:
:type: integer
:intent: output
:substitutions:
- ldx11: p
+ p: ldx11
ldx12: p
ldx21: p
ldx22: p
diff --git a/dev/defs/dorcsd b/dev/defs/dorcsd
index 8a16d77..b784757 100644
--- a/dev/defs/dorcsd
+++ b/dev/defs/dorcsd
@@ -124,7 +124,7 @@
ldv1t: "lsame_(&jobv1t,\"Y\") ? MAX(1,q) : 0"
ldu1: "lsame_(&jobu1,\"Y\") ? MAX(1,p) : 0"
ldu2: "lsame_(&jobu2,\"Y\") ? MAX(1,m-p) : 0"
- ldx11: p
+ p: ldx11
ldx12: p
ldx21: p
ldx22: p
diff --git a/dev/defs/dorgbr b/dev/defs/dorgbr
index 26cf11e..624e5ed 100644
--- a/dev/defs/dorgbr
+++ b/dev/defs/dorgbr
@@ -37,6 +37,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dorghr b/dev/defs/dorghr
index fbd8dca..114ff23 100644
--- a/dev/defs/dorghr
+++ b/dev/defs/dorghr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: ihi-ilo
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dorglq b/dev/defs/dorglq
index aa9f195..d53e58e 100644
--- a/dev/defs/dorglq
+++ b/dev/defs/dorglq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dorgql b/dev/defs/dorgql
index 17b5edc..b749ee1 100644
--- a/dev/defs/dorgql
+++ b/dev/defs/dorgql
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dorgqr b/dev/defs/dorgqr
index 09c59a3..0fbb6e2 100644
--- a/dev/defs/dorgqr
+++ b/dev/defs/dorgqr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dorgrq b/dev/defs/dorgrq
index 4169469..700d8f2 100644
--- a/dev/defs/dorgrq
+++ b/dev/defs/dorgrq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dorgtr b/dev/defs/dorgtr
index 46edbae..b5f6639 100644
--- a/dev/defs/dorgtr
+++ b/dev/defs/dorgtr
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormbr b/dev/defs/dormbr
index f1440b4..3162225 100644
--- a/dev/defs/dormbr
+++ b/dev/defs/dormbr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormhr b/dev/defs/dormhr
index 130ea8b..fba5550 100644
--- a/dev/defs/dormhr
+++ b/dev/defs/dormhr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormlq b/dev/defs/dormlq
index 61d123a..cbcb34f 100644
--- a/dev/defs/dormlq
+++ b/dev/defs/dormlq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormql b/dev/defs/dormql
index de4af78..4dd9921 100644
--- a/dev/defs/dormql
+++ b/dev/defs/dormql
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormqr b/dev/defs/dormqr
index 229db06..b924785 100644
--- a/dev/defs/dormqr
+++ b/dev/defs/dormqr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormrq b/dev/defs/dormrq
index add9906..7f63d52 100644
--- a/dev/defs/dormrq
+++ b/dev/defs/dormrq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormrz b/dev/defs/dormrz
index 5fce41b..91e0c34 100644
--- a/dev/defs/dormrz
+++ b/dev/defs/dormrz
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dormtr b/dev/defs/dormtr
index a5c0777..35ddd0e 100644
--- a/dev/defs/dormtr
+++ b/dev/defs/dormtr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsbevd b/dev/defs/dsbevd
index 88dc923..22afccd 100644
--- a/dev/defs/dsbevd
+++ b/dev/defs/dsbevd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=0 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -54,6 +56,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsbgvd b/dev/defs/dsbgvd
index 8358c21..930a5e4 100644
--- a/dev/defs/dsbgvd
+++ b/dev/defs/dsbgvd
@@ -58,6 +58,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 3*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -66,6 +68,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsbgvx b/dev/defs/dsbgvx
index eba0136..5565c88 100644
--- a/dev/defs/dsbgvx
+++ b/dev/defs/dsbgvx
@@ -101,7 +101,7 @@
:substitutions:
ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1"
m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0"
- ldq: "1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0"
+ ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0"
:fortran_help: " SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/dspevd b/dev/defs/dspevd
index d5740cc..df8f521 100644
--- a/dev/defs/dspevd
+++ b/dev/defs/dspevd
@@ -39,6 +39,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+n*n : 2"
- iwork:
:type: integer
:intent: output
@@ -47,6 +49,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dspgvd b/dev/defs/dspgvd
index 6e2bb8e..ef65c71 100644
--- a/dev/defs/dspgvd
+++ b/dev/defs/dspgvd
@@ -47,6 +47,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -55,6 +57,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dstedc b/dev/defs/dstedc
index 4b4652c..fb8e28b 100644
--- a/dev/defs/dstedc
+++ b/dev/defs/dstedc
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -44,6 +46,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dstegr b/dev/defs/dstegr
index 83d49b2..9b76a1a 100644
--- a/dev/defs/dstegr
+++ b/dev/defs/dstegr
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -75,6 +77,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dstemr b/dev/defs/dstemr
index 52af6b6..e688645 100644
--- a/dev/defs/dstemr
+++ b/dev/defs/dstemr
@@ -70,6 +70,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -78,6 +80,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dstevd b/dev/defs/dstevd
index 96c2819..b038a57 100644
--- a/dev/defs/dstevd
+++ b/dev/defs/dstevd
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : (lsame_(&jobz,\"V\")&&n>1) ? 1+4*n+n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -44,6 +46,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : (lsame_(&jobz,\"V\")&&n>1) ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dstevr b/dev/defs/dstevr
index 963a5b8..772fddd 100644
--- a/dev/defs/dstevr
+++ b/dev/defs/dstevr
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 20*n
- iwork:
:type: integer
:intent: output
@@ -75,6 +77,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: 10*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsyev b/dev/defs/dsyev
index 7ff1522..79df5e8 100644
--- a/dev/defs/dsyev
+++ b/dev/defs/dsyev
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsyevd b/dev/defs/dsyevd
index edb9af3..7a9c39f 100644
--- a/dev/defs/dsyevd
+++ b/dev/defs/dsyevd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -42,6 +44,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsyevr b/dev/defs/dsyevr
index 9d3dbc5..2d85b2f 100644
--- a/dev/defs/dsyevr
+++ b/dev/defs/dsyevr
@@ -69,6 +69,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 26*n
- iwork:
:type: integer
:intent: output
@@ -77,6 +79,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: 10*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsyevx b/dev/defs/dsyevx
index 6f8d8b7..a0e45ee 100644
--- a/dev/defs/dsyevx
+++ b/dev/defs/dsyevx
@@ -64,6 +64,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : 8*n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dsygv b/dev/defs/dsygv
index b3509c3..a03dc9c 100644
--- a/dev/defs/dsygv
+++ b/dev/defs/dsygv
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsygvd b/dev/defs/dsygvd
index 9d858d4..bf38ecb 100644
--- a/dev/defs/dsygvd
+++ b/dev/defs/dsygvd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 1"
- iwork:
:type: integer
:intent: output
@@ -54,6 +56,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsygvx b/dev/defs/dsygvx
index 253b009..166d97a 100644
--- a/dev/defs/dsygvx
+++ b/dev/defs/dsygvx
@@ -76,6 +76,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*n
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dsysv b/dev/defs/dsysv
index fc34cc9..535f917 100644
--- a/dev/defs/dsysv
+++ b/dev/defs/dsysv
@@ -43,6 +43,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dsysvx b/dev/defs/dsysvx
index 03eadf6..61ec5a4 100644
--- a/dev/defs/dsysvx
+++ b/dev/defs/dsysvx
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dsytri2 b/dev/defs/dsytri2
index c89bd6e..1791ea6 100644
--- a/dev/defs/dsytri2
+++ b/dev/defs/dsytri2
@@ -27,10 +27,12 @@
:type: doublereal
:intent: workspace
:dims:
- - (n+nb+1)*(nb+3)
+ - lwork
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: (n+nb+1)*(nb+3)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dtgex2 b/dev/defs/dtgex2
index 804e613..117e652 100644
--- a/dev/defs/dtgex2
+++ b/dev/defs/dtgex2
@@ -65,6 +65,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(n*(n2+n1), (n2+n1)*(n2+n1)*2)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dtgexc b/dev/defs/dtgexc
index 780845f..7df7c27 100644
--- a/dev/defs/dtgexc
+++ b/dev/defs/dtgexc
@@ -62,6 +62,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : 4*n+16"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dtgsen b/dev/defs/dtgsen
index 6cd15a4..541e7ab 100644
--- a/dev/defs/dtgsen
+++ b/dev/defs/dtgsen
@@ -93,14 +93,18 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0"
- iwork:
:type: integer
:intent: output
:dims:
- - "ijob==0 ? 0 : MAX(1,liwork)"
+ - MAX(1,liwork)
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/dtgsna b/dev/defs/dtgsna
index c4fe378..aa856f1 100644
--- a/dev/defs/dtgsna
+++ b/dev/defs/dtgsna
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dtgsyl b/dev/defs/dtgsyl
index 36ff77d..f6d30f4 100644
--- a/dev/defs/dtgsyl
+++ b/dev/defs/dtgsyl
@@ -83,6 +83,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dtrsen b/dev/defs/dtrsen
index c373559..cd3997f 100644
--- a/dev/defs/dtrsen
+++ b/dev/defs/dtrsen
@@ -62,6 +62,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/dtzrzf b/dev/defs/dtzrzf
index 5b12e08..b08e558 100644
--- a/dev/defs/dtzrzf
+++ b/dev/defs/dtzrzf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sbbcsd b/dev/defs/sbbcsd
index 909938d..e2c07f1 100644
--- a/dev/defs/sbbcsd
+++ b/dev/defs/sbbcsd
@@ -121,6 +121,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*q
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgbequb b/dev/defs/sgbequb
index a90f4a9..fe7166b 100644
--- a/dev/defs/sgbequb
+++ b/dev/defs/sgbequb
@@ -47,7 +47,7 @@
:type: integer
:intent: output
:substitutions:
- ldab: m
+ m: ldab
:fortran_help: " SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgbsvx b/dev/defs/sgbsvx
index 78bb263..b6cf1fd 100644
--- a/dev/defs/sgbsvx
+++ b/dev/defs/sgbsvx
@@ -36,6 +36,7 @@
:dims:
- ldafb
- n
+ :option: true
- ldafb:
:type: integer
:intent: input
@@ -44,19 +45,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: real
:intent: input/output
@@ -102,7 +107,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldafb: 2*kl+ku+1
:fortran_help: " SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgebrd b/dev/defs/sgebrd
index c38201d..2393011 100644
--- a/dev/defs/sgebrd
+++ b/dev/defs/sgebrd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgeequb b/dev/defs/sgeequb
index 336d29d..0322c91 100644
--- a/dev/defs/sgeequb
+++ b/dev/defs/sgeequb
@@ -41,7 +41,7 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
:fortran_help: " SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgees b/dev/defs/sgees
index d4c3e6e..a6cc965 100644
--- a/dev/defs/sgees
+++ b/dev/defs/sgees
@@ -56,6 +56,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/sgeesx b/dev/defs/sgeesx
index 3e13772..ff02f64 100644
--- a/dev/defs/sgeesx
+++ b/dev/defs/sgeesx
@@ -65,6 +65,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n+n*n/2 : 3*n"
- iwork:
:type: integer
:intent: output
diff --git a/dev/defs/sgeev b/dev/defs/sgeev
index eac9876..acc0ecd 100644
--- a/dev/defs/sgeev
+++ b/dev/defs/sgeev
@@ -57,6 +57,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 4*n : 3*n"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgeevx b/dev/defs/sgeevx
index 37eba92..107d2f0 100644
--- a/dev/defs/sgeevx
+++ b/dev/defs/sgeevx
@@ -87,6 +87,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 3*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*(n+6) : 0"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/sgegs b/dev/defs/sgegs
index e4d08df..2dfb29a 100644
--- a/dev/defs/sgegs
+++ b/dev/defs/sgegs
@@ -71,6 +71,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 4*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgegv b/dev/defs/sgegv
index 0d0c265..f42a069 100644
--- a/dev/defs/sgegv
+++ b/dev/defs/sgegv
@@ -71,6 +71,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgehrd b/dev/defs/sgehrd
index 54367be..2b55ea8 100644
--- a/dev/defs/sgehrd
+++ b/dev/defs/sgehrd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgejsv b/dev/defs/sgejsv
index 03aa504..eb0ac53 100644
--- a/dev/defs/sgejsv
+++ b/dev/defs/sgejsv
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobu,\"N\")&&lsame_(&jobv,\"N\")) ? MAX(MAX(2*m+n,4*n+n*n),7) : lsame_(&jobv,\"V\") ? MAX(2*n+m,7) : ((lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\"))&&lsame_(&jobv,\"V\")) ? MAX(MAX(6*n+2*n*n,m+3*n+n*n),7) : MAX(2*n+m,7)"
- iwork:
:type: integer
:intent: output
diff --git a/dev/defs/sgelqf b/dev/defs/sgelqf
index 8a43551..1db76e3 100644
--- a/dev/defs/sgelqf
+++ b/dev/defs/sgelqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgels b/dev/defs/sgels
index fce0376..b008cf1 100644
--- a/dev/defs/sgels
+++ b/dev/defs/sgels
@@ -28,7 +28,10 @@
:type: real
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -41,11 +44,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n) + MAX(MIN(m,n),nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgelsd b/dev/defs/sgelsd
index 4bf46a8..46b6eda 100644
--- a/dev/defs/sgelsd
+++ b/dev/defs/sgelsd
@@ -25,7 +25,10 @@
:type: real
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1)"
- iwork:
:type: integer
:intent: workspace
@@ -58,6 +63,8 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
+ ldb: MAX(m,n)
c__9: "9"
c__0: "0"
liwork: 3*(MIN(m,n))*nlvl+11*(MIN(m,n))
diff --git a/dev/defs/sgelss b/dev/defs/sgelss
index dcc3190..ef0aa24 100644
--- a/dev/defs/sgelss
+++ b/dev/defs/sgelss
@@ -25,7 +25,10 @@
:type: real
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,11 +52,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgelsy b/dev/defs/sgelsy
index 08d746f..2cf4ced 100644
--- a/dev/defs/sgelsy
+++ b/dev/defs/sgelsy
@@ -25,7 +25,10 @@
:type: real
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,11 +52,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgeqlf b/dev/defs/sgeqlf
index 6e58792..174477a 100644
--- a/dev/defs/sgeqlf
+++ b/dev/defs/sgeqlf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgeqp3 b/dev/defs/sgeqp3
index 5b733f9..d643fe8 100644
--- a/dev/defs/sgeqp3
+++ b/dev/defs/sgeqp3
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n+1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgeqrf b/dev/defs/sgeqrf
index 75f5215..18c0846 100644
--- a/dev/defs/sgeqrf
+++ b/dev/defs/sgeqrf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgeqrfp b/dev/defs/sgeqrfp
index 5cd1598..443ad9d 100644
--- a/dev/defs/sgeqrfp
+++ b/dev/defs/sgeqrfp
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgerqf b/dev/defs/sgerqf
index 0d86e18..7548e02 100644
--- a/dev/defs/sgerqf
+++ b/dev/defs/sgerqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgesdd b/dev/defs/sgesdd
index 9085551..bf4eef2 100644
--- a/dev/defs/sgesdd
+++ b/dev/defs/sgesdd
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"N\") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,\"O\") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0"
- iwork:
:type: integer
:intent: workspace
@@ -61,9 +63,10 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0"
- ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m == n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
- ldu: "((lsame_(&jobz,\"S\")) || ((('a') || (((lsame_(&jobz,\"O\")) && (m < n)))))) ? m : 1"
+ ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
+ ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1"
:fortran_help: " SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgesvd b/dev/defs/sgesvd
index b14dbdb..60e09cf 100644
--- a/dev/defs/sgesvd
+++ b/dev/defs/sgesvd
@@ -21,6 +21,9 @@
:dims:
- lda
- n
+ :outdims:
+ - lda
+ - MIN(m,n)
- lda:
:type: integer
:intent: input
@@ -55,10 +58,13 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n))
- info:
:type: integer
:intent: output
:substitutions:
+ m: lda
ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1"
ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1"
:fortran_help: " SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n\
diff --git a/dev/defs/sgesvj b/dev/defs/sgesvj
index b32fdba..17671ff 100644
--- a/dev/defs/sgesvj
+++ b/dev/defs/sgesvj
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(6,m+n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgesvx b/dev/defs/sgesvx
index 9972a6d..ea9454e 100644
--- a/dev/defs/sgesvx
+++ b/dev/defs/sgesvx
@@ -30,6 +30,7 @@
:dims:
- ldaf
- n
+ :option: true
- ldaf:
:type: integer
:intent: input
@@ -38,19 +39,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: real
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: real
:intent: input/output
@@ -96,7 +101,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldaf: n
:fortran_help: " SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sgetri b/dev/defs/sgetri
index 94333c0..e7da3e2 100644
--- a/dev/defs/sgetri
+++ b/dev/defs/sgetri
@@ -28,6 +28,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sggbal b/dev/defs/sggbal
index 42f34c4..1e2e8c4 100644
--- a/dev/defs/sggbal
+++ b/dev/defs/sggbal
@@ -46,7 +46,8 @@
- work:
:type: real
:intent: workspace
- :dims: "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0"
+ :dims:
+ - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgges b/dev/defs/sgges
index feeaf44..9643420 100644
--- a/dev/defs/sgges
+++ b/dev/defs/sgges
@@ -82,6 +82,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(8*n,6*n+16)
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/sggesx b/dev/defs/sggesx
index cb5e0a2..123b916 100644
--- a/dev/defs/sggesx
+++ b/dev/defs/sggesx
@@ -95,6 +95,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16)"
- iwork:
:type: integer
:intent: workspace
@@ -103,6 +105,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+6"
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/sggev b/dev/defs/sggev
index 2035818..fd455c9 100644
--- a/dev/defs/sggev
+++ b/dev/defs/sggev
@@ -71,6 +71,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(1,8*n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sggevx b/dev/defs/sggevx
index 7994910..9b06839 100644
--- a/dev/defs/sggevx
+++ b/dev/defs/sggevx
@@ -109,6 +109,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&balanc,\"S\")||lsame_(&balanc,\"B\")||lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 6*n : lsame_(&sense,\"E\") ? 10*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+8*n+16 : 2*n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/sggglm b/dev/defs/sggglm
index fef5d1b..b5be58c 100644
--- a/dev/defs/sggglm
+++ b/dev/defs/sggglm
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgglse b/dev/defs/sgglse
index d776e50..2b9fd40 100644
--- a/dev/defs/sgglse
+++ b/dev/defs/sgglse
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sggqrf b/dev/defs/sggqrf
index ca7f422..2ce80ee 100644
--- a/dev/defs/sggqrf
+++ b/dev/defs/sggqrf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sggrqf b/dev/defs/sggrqf
index c6932f1..3cddf1e 100644
--- a/dev/defs/sggrqf
+++ b/dev/defs/sggrqf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sggsvd b/dev/defs/sggsvd
index f5e5ae4..8af7704 100644
--- a/dev/defs/sggsvd
+++ b/dev/defs/sggsvd
@@ -97,9 +97,9 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
- ldb: p
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
:fortran_help: " SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n\
diff --git a/dev/defs/sggsvp b/dev/defs/sggsvp
index 27dabe2..d2fd908 100644
--- a/dev/defs/sggsvp
+++ b/dev/defs/sggsvp
@@ -97,8 +97,8 @@
:type: integer
:intent: output
:substitutions:
- lda: m
- ldb: p
+ m: lda
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
diff --git a/dev/defs/sgsvj0 b/dev/defs/sgsvj0
index 1626fbe..e219026 100644
--- a/dev/defs/sgsvj0
+++ b/dev/defs/sgsvj0
@@ -63,6 +63,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sgsvj1 b/dev/defs/sgsvj1
index a646e76..10dd130 100644
--- a/dev/defs/sgsvj1
+++ b/dev/defs/sgsvj1
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/shgeqz b/dev/defs/shgeqz
index 1f37e01..8be9452 100644
--- a/dev/defs/shgeqz
+++ b/dev/defs/shgeqz
@@ -80,6 +80,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/shseqr b/dev/defs/shseqr
index e8a0cc4..4979e25 100644
--- a/dev/defs/shseqr
+++ b/dev/defs/shseqr
@@ -54,6 +54,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sla_gbamv b/dev/defs/sla_gbamv
index b7f235c..d04b1d5 100644
--- a/dev/defs/sla_gbamv
+++ b/dev/defs/sla_gbamv
@@ -33,7 +33,7 @@
:type: real
:intent: input
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
- incx:
:type: integer
:intent: input
@@ -44,7 +44,7 @@
:type: real
:intent: input/output
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
- incy:
:type: integer
:intent: input
diff --git a/dev/defs/sla_gbrfsx_extended b/dev/defs/sla_gbrfsx_extended
index 902f2ab..a749137 100644
--- a/dev/defs/sla_gbrfsx_extended
+++ b/dev/defs/sla_gbrfsx_extended
@@ -34,7 +34,7 @@
:type: real
:intent: input
:dims:
- - ldab
+ - ldafb
- n
- ldafb:
:type: integer
@@ -129,7 +129,7 @@
:type: integer
:intent: output
:substitutions:
- ldab: n
+ n: ldab
ldafb: n
:fortran_help: " SUBROUTINE SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\
* Purpose\n\
diff --git a/dev/defs/sla_geamv b/dev/defs/sla_geamv
index c520701..92b2dda 100644
--- a/dev/defs/sla_geamv
+++ b/dev/defs/sla_geamv
@@ -28,7 +28,7 @@
:type: real
:intent: input
:dims:
- - "lsame_(&trans,\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)"
+ - "trans == ilatrans_(\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)"
- incx:
:type: integer
:intent: input
@@ -39,7 +39,7 @@
:type: real
:intent: input/output
:dims:
- - "lsame_(&trans,\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)"
+ - "trans == ilatrans_(\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)"
- incy:
:type: integer
:intent: input
diff --git a/dev/defs/slahrd b/dev/defs/slahrd
index ef4e991..f6b2035 100644
--- a/dev/defs/slahrd
+++ b/dev/defs/slahrd
@@ -45,6 +45,7 @@
:type: integer
:intent: input
:substitutions:
+ lda: n
ldy: n
ldt: nb
:fortran_help: " SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\
diff --git a/dev/defs/slaqr0 b/dev/defs/slaqr0
index 24bdb28..524c469 100644
--- a/dev/defs/slaqr0
+++ b/dev/defs/slaqr0
@@ -60,6 +60,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/slaqr2 b/dev/defs/slaqr2
index 1d197be..21bec7b 100644
--- a/dev/defs/slaqr2
+++ b/dev/defs/slaqr2
@@ -102,6 +102,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/slaqr3 b/dev/defs/slaqr3
index b430772..ebee412 100644
--- a/dev/defs/slaqr3
+++ b/dev/defs/slaqr3
@@ -102,6 +102,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/slaqr4 b/dev/defs/slaqr4
index 6ad39b8..d34ef43 100644
--- a/dev/defs/slaqr4
+++ b/dev/defs/slaqr4
@@ -60,6 +60,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/slarfb b/dev/defs/slarfb
index 82cac26..064c2e6 100644
--- a/dev/defs/slarfb
+++ b/dev/defs/slarfb
@@ -61,7 +61,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/slarzb b/dev/defs/slarzb
index 3cb9c2e..d3ec47f 100644
--- a/dev/defs/slarzb
+++ b/dev/defs/slarzb
@@ -64,7 +64,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sorbdb b/dev/defs/sorbdb
index d7e4171..b0d49a9 100644
--- a/dev/defs/sorbdb
+++ b/dev/defs/sorbdb
@@ -92,11 +92,13 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m-q
- info:
:type: integer
:intent: output
:substitutions:
- ldx11: p
+ p: ldx11
ldx12: p
ldx21: p
ldx22: p
diff --git a/dev/defs/sorcsd b/dev/defs/sorcsd
index ff795ee..913a868 100644
--- a/dev/defs/sorcsd
+++ b/dev/defs/sorcsd
@@ -124,7 +124,7 @@
ldv1t: "lsame_(&jobv1t,\"Y\") ? MAX(1,q) : 0"
ldu1: "lsame_(&jobu1,\"Y\") ? MAX(1,p) : 0"
ldu2: "lsame_(&jobu2,\"Y\") ? MAX(1,m-p) : 0"
- ldx11: p
+ p: ldx11
ldx12: p
ldx21: p
ldx22: p
diff --git a/dev/defs/sorgbr b/dev/defs/sorgbr
index 75c1095..c42b639 100644
--- a/dev/defs/sorgbr
+++ b/dev/defs/sorgbr
@@ -37,6 +37,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sorghr b/dev/defs/sorghr
index fef628d..a461087 100644
--- a/dev/defs/sorghr
+++ b/dev/defs/sorghr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: ihi-ilo
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sorglq b/dev/defs/sorglq
index bd0610a..22bf9b3 100644
--- a/dev/defs/sorglq
+++ b/dev/defs/sorglq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sorgql b/dev/defs/sorgql
index f260fc4..fecaeca 100644
--- a/dev/defs/sorgql
+++ b/dev/defs/sorgql
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sorgqr b/dev/defs/sorgqr
index 84ec758..0326337 100644
--- a/dev/defs/sorgqr
+++ b/dev/defs/sorgqr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sorgrq b/dev/defs/sorgrq
index 407ba8a..4d1c593 100644
--- a/dev/defs/sorgrq
+++ b/dev/defs/sorgrq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sorgtr b/dev/defs/sorgtr
index 09f0037..2e55b6b 100644
--- a/dev/defs/sorgtr
+++ b/dev/defs/sorgtr
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormbr b/dev/defs/sormbr
index 36cb38e..c4bf110 100644
--- a/dev/defs/sormbr
+++ b/dev/defs/sormbr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormhr b/dev/defs/sormhr
index a304784..f6dbbc8 100644
--- a/dev/defs/sormhr
+++ b/dev/defs/sormhr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormlq b/dev/defs/sormlq
index b270b22..105ce31 100644
--- a/dev/defs/sormlq
+++ b/dev/defs/sormlq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormql b/dev/defs/sormql
index 66f8889..959645a 100644
--- a/dev/defs/sormql
+++ b/dev/defs/sormql
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormqr b/dev/defs/sormqr
index 70d9da5..ac8ad23 100644
--- a/dev/defs/sormqr
+++ b/dev/defs/sormqr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormrq b/dev/defs/sormrq
index f0c1c80..ba58b58 100644
--- a/dev/defs/sormrq
+++ b/dev/defs/sormrq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormrz b/dev/defs/sormrz
index bc037c3..a4ad6a6 100644
--- a/dev/defs/sormrz
+++ b/dev/defs/sormrz
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sormtr b/dev/defs/sormtr
index 5506c64..1e559ce 100644
--- a/dev/defs/sormtr
+++ b/dev/defs/sormtr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssbevd b/dev/defs/ssbevd
index f0a4408..bb7bece 100644
--- a/dev/defs/ssbevd
+++ b/dev/defs/ssbevd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=0 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -54,6 +56,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssbgvd b/dev/defs/ssbgvd
index 441af94..afc089c 100644
--- a/dev/defs/ssbgvd
+++ b/dev/defs/ssbgvd
@@ -58,6 +58,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 3*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -66,6 +68,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssbgvx b/dev/defs/ssbgvx
index 0d63ba0..85631d6 100644
--- a/dev/defs/ssbgvx
+++ b/dev/defs/ssbgvx
@@ -101,7 +101,7 @@
:substitutions:
ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1"
m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0"
- ldq: "1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0"
+ ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0"
:fortran_help: " SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/sspevd b/dev/defs/sspevd
index 9dda123..b2f87ed 100644
--- a/dev/defs/sspevd
+++ b/dev/defs/sspevd
@@ -39,6 +39,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+n*n : 2"
- iwork:
:type: integer
:intent: output
@@ -47,6 +49,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sspgvd b/dev/defs/sspgvd
index 1bff19c..59eb62d 100644
--- a/dev/defs/sspgvd
+++ b/dev/defs/sspgvd
@@ -47,6 +47,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -55,6 +57,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sstedc b/dev/defs/sstedc
index a01ade4..a93cfe6 100644
--- a/dev/defs/sstedc
+++ b/dev/defs/sstedc
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -44,6 +46,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sstegr b/dev/defs/sstegr
index dad4395..8513aea 100644
--- a/dev/defs/sstegr
+++ b/dev/defs/sstegr
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -75,6 +77,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sstemr b/dev/defs/sstemr
index dff8c18..a9ba463 100644
--- a/dev/defs/sstemr
+++ b/dev/defs/sstemr
@@ -70,6 +70,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -78,6 +80,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sstevd b/dev/defs/sstevd
index 718842a..0361803 100644
--- a/dev/defs/sstevd
+++ b/dev/defs/sstevd
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 1+4*n+n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -44,6 +46,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/sstevr b/dev/defs/sstevr
index 83f2bd3..2f99f42 100644
--- a/dev/defs/sstevr
+++ b/dev/defs/sstevr
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 20*n
- iwork:
:type: integer
:intent: output
@@ -75,6 +77,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: 10*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssyev b/dev/defs/ssyev
index 0d45d93..5acba8f 100644
--- a/dev/defs/ssyev
+++ b/dev/defs/ssyev
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssyevd b/dev/defs/ssyevd
index f796302..d790dde 100644
--- a/dev/defs/ssyevd
+++ b/dev/defs/ssyevd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -42,6 +44,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssyevr b/dev/defs/ssyevr
index d85090b..345d359 100644
--- a/dev/defs/ssyevr
+++ b/dev/defs/ssyevr
@@ -69,6 +69,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 26*n
- iwork:
:type: integer
:intent: output
@@ -77,6 +79,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: 10*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssyevx b/dev/defs/ssyevx
index 74475fa..a285179 100644
--- a/dev/defs/ssyevx
+++ b/dev/defs/ssyevx
@@ -64,6 +64,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : 8*n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/ssygv b/dev/defs/ssygv
index 4634d6a..313beb8 100644
--- a/dev/defs/ssygv
+++ b/dev/defs/ssygv
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssygvd b/dev/defs/ssygvd
index e5054ad..2b2d7c5 100644
--- a/dev/defs/ssygvd
+++ b/dev/defs/ssygvd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 1"
- iwork:
:type: integer
:intent: output
@@ -54,6 +56,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssygvx b/dev/defs/ssygvx
index 541f96f..d788710 100644
--- a/dev/defs/ssygvx
+++ b/dev/defs/ssygvx
@@ -76,6 +76,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*n
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/ssysv b/dev/defs/ssysv
index f3d99a8..aa2598f 100644
--- a/dev/defs/ssysv
+++ b/dev/defs/ssysv
@@ -43,6 +43,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ssysvx b/dev/defs/ssysvx
index 4e43f31..faa5504 100644
--- a/dev/defs/ssysvx
+++ b/dev/defs/ssysvx
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/ssytri2 b/dev/defs/ssytri2
index becd796..6e00777 100644
--- a/dev/defs/ssytri2
+++ b/dev/defs/ssytri2
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: (n+nb+1)*(nb+3)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/stgex2 b/dev/defs/stgex2
index 2e4e3cf..187e3d8 100644
--- a/dev/defs/stgex2
+++ b/dev/defs/stgex2
@@ -65,6 +65,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(n*(n2+n1), (n2+n1)*(n2+n1)*2)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/stgexc b/dev/defs/stgexc
index f54062b..ec992b2 100644
--- a/dev/defs/stgexc
+++ b/dev/defs/stgexc
@@ -62,6 +62,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : 4*n+16"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/stgsen b/dev/defs/stgsen
index 27b8f40..0eafbe0 100644
--- a/dev/defs/stgsen
+++ b/dev/defs/stgsen
@@ -93,14 +93,18 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0"
- iwork:
:type: integer
:intent: output
:dims:
- - "ijob==0 ? 0 : MAX(1,liwork)"
+ - MAX(1,liwork)
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/stgsna b/dev/defs/stgsna
index 8ce2399..e74bb49 100644
--- a/dev/defs/stgsna
+++ b/dev/defs/stgsna
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/stgsyl b/dev/defs/stgsyl
index 5c28496..0ebd931 100644
--- a/dev/defs/stgsyl
+++ b/dev/defs/stgsyl
@@ -83,6 +83,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/strsen b/dev/defs/strsen
index f44ca80..0ec88a3 100644
--- a/dev/defs/strsen
+++ b/dev/defs/strsen
@@ -62,6 +62,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/stzrzf b/dev/defs/stzrzf
index 0abbb5a..0446b01 100644
--- a/dev/defs/stzrzf
+++ b/dev/defs/stzrzf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zbbcsd b/dev/defs/zbbcsd
index 036dd31..2768a0c 100644
--- a/dev/defs/zbbcsd
+++ b/dev/defs/zbbcsd
@@ -121,6 +121,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: 8*q
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgbequb b/dev/defs/zgbequb
index 91b4c76..4b295f9 100644
--- a/dev/defs/zgbequb
+++ b/dev/defs/zgbequb
@@ -47,7 +47,7 @@
:type: integer
:intent: output
:substitutions:
- ldab: m
+ m: ldab
:fortran_help: " SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgbsvx b/dev/defs/zgbsvx
index 5f28155..6991e22 100644
--- a/dev/defs/zgbsvx
+++ b/dev/defs/zgbsvx
@@ -36,6 +36,7 @@
:dims:
- ldafb
- n
+ :option: true
- ldafb:
:type: integer
:intent: input
@@ -44,19 +45,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: doublecomplex
:intent: input/output
@@ -102,7 +107,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldafb: 2*kl+ku+1
:fortran_help: " SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgebrd b/dev/defs/zgebrd
index fdd5809..fd4781b 100644
--- a/dev/defs/zgebrd
+++ b/dev/defs/zgebrd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgeequb b/dev/defs/zgeequb
index 4dc8da7..76c843a 100644
--- a/dev/defs/zgeequb
+++ b/dev/defs/zgeequb
@@ -41,7 +41,7 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
:fortran_help: " SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgees b/dev/defs/zgees
index 6e1149b..661bb3d 100644
--- a/dev/defs/zgees
+++ b/dev/defs/zgees
@@ -51,6 +51,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zgeesx b/dev/defs/zgeesx
index 83d0719..b2197e1 100644
--- a/dev/defs/zgeesx
+++ b/dev/defs/zgeesx
@@ -60,6 +60,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n/2 : 2*n"
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zgeev b/dev/defs/zgeev
index 9d38db7..e04236b 100644
--- a/dev/defs/zgeev
+++ b/dev/defs/zgeev
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zgeevx b/dev/defs/zgeevx
index 2a1e13d..07b9894 100644
--- a/dev/defs/zgeevx
+++ b/dev/defs/zgeevx
@@ -82,6 +82,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n+2*n : 0"
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zgegs b/dev/defs/zgegs
index 3c84b51..829aa73 100644
--- a/dev/defs/zgegs
+++ b/dev/defs/zgegs
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zgegv b/dev/defs/zgegv
index b5f481e..a1730c4 100644
--- a/dev/defs/zgegv
+++ b/dev/defs/zgegv
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: output
diff --git a/dev/defs/zgehrd b/dev/defs/zgehrd
index 2dc3266..00256cb 100644
--- a/dev/defs/zgehrd
+++ b/dev/defs/zgehrd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgelqf b/dev/defs/zgelqf
index 60c04e4..311b655 100644
--- a/dev/defs/zgelqf
+++ b/dev/defs/zgelqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgels b/dev/defs/zgels
index 87c4f71..305981a 100644
--- a/dev/defs/zgels
+++ b/dev/defs/zgels
@@ -28,7 +28,10 @@
:type: doublecomplex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -41,11 +44,14 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n) + MAX(MIN(m,n),nrhs)
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgelsd b/dev/defs/zgelsd
index e0e2bd1..b2bd1fe 100644
--- a/dev/defs/zgelsd
+++ b/dev/defs/zgelsd
@@ -25,7 +25,10 @@
:type: doublecomplex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "m>=n ? 2*n+n*nrhs : 2*m+m*nrhs"
- rwork:
:type: doublereal
:intent: workspace
@@ -63,6 +68,8 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
+ ldb: MAX(m,n)
c__9: "9"
c__0: "0"
liwork: MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)))
diff --git a/dev/defs/zgelss b/dev/defs/zgelss
index df036ad..220f1a3 100644
--- a/dev/defs/zgelss
+++ b/dev/defs/zgelss
@@ -25,7 +25,10 @@
:type: doublecomplex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs)
- rwork:
:type: doublereal
:intent: workspace
@@ -57,8 +62,9 @@
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m, n)
:fortran_help: " SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgelsy b/dev/defs/zgelsy
index 1d4c440..fda3597 100644
--- a/dev/defs/zgelsy
+++ b/dev/defs/zgelsy
@@ -25,7 +25,10 @@
:type: doublecomplex
:intent: input/output
:dims:
- - ldb
+ - m
+ - nrhs
+ :outdims:
+ - n
- nrhs
- ldb:
:type: integer
@@ -49,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs)
- rwork:
:type: doublereal
:intent: workspace
@@ -57,8 +62,9 @@
- info:
:type: integer
:intent: output
-:substitutions: {}
-
+:substitutions:
+ m: lda
+ ldb: MAX(m,n)
:fortran_help: " SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgeqlf b/dev/defs/zgeqlf
index ec619ef..85230dc 100644
--- a/dev/defs/zgeqlf
+++ b/dev/defs/zgeqlf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgeqp3 b/dev/defs/zgeqp3
index 8ba73e9..5fb1a3d 100644
--- a/dev/defs/zgeqp3
+++ b/dev/defs/zgeqp3
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n+1
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zgeqrf b/dev/defs/zgeqrf
index 360e44a..fa5880b 100644
--- a/dev/defs/zgeqrf
+++ b/dev/defs/zgeqrf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgeqrfp b/dev/defs/zgeqrfp
index 0fb9b00..ddca730 100644
--- a/dev/defs/zgeqrfp
+++ b/dev/defs/zgeqrfp
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgerqf b/dev/defs/zgerqf
index e7d1886..9a1bf56 100644
--- a/dev/defs/zgerqf
+++ b/dev/defs/zgerqf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgesdd b/dev/defs/zgesdd
index 11e26ef..fb0ce7a 100644
--- a/dev/defs/zgesdd
+++ b/dev/defs/zgesdd
@@ -52,11 +52,13 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"N\") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,\"O\") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0"
- rwork:
:type: doublereal
:intent: workspace
:dims:
- - "MAX(1, lsame_(&jobz,\"N\") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1))"
+ - "MAX(1, (lsame_(&jobz,\"N\") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))"
- iwork:
:type: integer
:intent: workspace
@@ -66,9 +68,10 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0"
- ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m == n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
- ldu: "((lsame_(&jobz,\"S\")) || ((('a') || (((lsame_(&jobz,\"O\")) && (m < n)))))) ? m : 1"
+ ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1"
+ ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1"
:fortran_help: " SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgesvd b/dev/defs/zgesvd
index f0ed2cd..9c79ebc 100644
--- a/dev/defs/zgesvd
+++ b/dev/defs/zgesvd
@@ -21,6 +21,9 @@
:dims:
- lda
- n
+ :outdims:
+ - lda
+ - MIN(m,n)
- lda:
:type: integer
:intent: input
@@ -55,6 +58,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(1, 2*MIN(m,n)+MAX(m,n))
- rwork:
:type: doublereal
:intent: workspace
@@ -64,6 +69,7 @@
:type: integer
:intent: output
:substitutions:
+ m: lda
ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1"
ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1"
:fortran_help: " SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n\
diff --git a/dev/defs/zgesvx b/dev/defs/zgesvx
index 02f8ccc..ab21451 100644
--- a/dev/defs/zgesvx
+++ b/dev/defs/zgesvx
@@ -30,6 +30,7 @@
:dims:
- ldaf
- n
+ :option: true
- ldaf:
:type: integer
:intent: input
@@ -38,19 +39,23 @@
:intent: input/output
:dims:
- n
+ :option: true
- equed:
:type: char
:intent: input/output
+ :option: true
- r:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- c:
:type: doublereal
:intent: input/output
:dims:
- n
+ :option: true
- b:
:type: doublecomplex
:intent: input/output
@@ -96,7 +101,8 @@
:type: integer
:intent: output
:substitutions:
- ldx: MAX(1,n)
+ ldx: n
+ ldaf: n
:fortran_help: " SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zgetri b/dev/defs/zgetri
index 848f5ac..bdf668b 100644
--- a/dev/defs/zgetri
+++ b/dev/defs/zgetri
@@ -28,6 +28,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zggbal b/dev/defs/zggbal
index 0186afc..1020e07 100644
--- a/dev/defs/zggbal
+++ b/dev/defs/zggbal
@@ -46,7 +46,8 @@
- work:
:type: doublereal
:intent: workspace
- :dims: "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0"
+ :dims:
+ - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgges b/dev/defs/zgges
index 09c644e..2535065 100644
--- a/dev/defs/zgges
+++ b/dev/defs/zgges
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zggesx b/dev/defs/zggesx
index 0fd9723..10d5c66 100644
--- a/dev/defs/zggesx
+++ b/dev/defs/zggesx
@@ -90,6 +90,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(2*n,n*n/2) : 2*n"
- rwork:
:type: doublereal
:intent: workspace
@@ -103,6 +105,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+2"
- bwork:
:type: logical
:intent: workspace
diff --git a/dev/defs/zggev b/dev/defs/zggev
index 995f679..b9e18fb 100644
--- a/dev/defs/zggev
+++ b/dev/defs/zggev
@@ -66,6 +66,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(1,2*n)
- rwork:
:type: doublereal
:intent: output
diff --git a/dev/defs/zggevx b/dev/defs/zggevx
index 6d1ac0e..12efbff 100644
--- a/dev/defs/zggevx
+++ b/dev/defs/zggevx
@@ -104,6 +104,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&sense,\"E\") ? 4*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+2*n : 2*n"
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zggglm b/dev/defs/zggglm
index 6f45ea0..511a839 100644
--- a/dev/defs/zggglm
+++ b/dev/defs/zggglm
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zgglse b/dev/defs/zgglse
index 338e1a3..5fd3901 100644
--- a/dev/defs/zgglse
+++ b/dev/defs/zgglse
@@ -53,6 +53,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m+n+p
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zggqrf b/dev/defs/zggqrf
index e789bb9..4837ab5 100644
--- a/dev/defs/zggqrf
+++ b/dev/defs/zggqrf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zggrqf b/dev/defs/zggrqf
index 402fbf7..f8bb064 100644
--- a/dev/defs/zggrqf
+++ b/dev/defs/zggrqf
@@ -48,6 +48,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MAX(MAX(n,m),p)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zggsvd b/dev/defs/zggsvd
index cee7224..9584259 100644
--- a/dev/defs/zggsvd
+++ b/dev/defs/zggsvd
@@ -102,9 +102,9 @@
:type: integer
:intent: output
:substitutions:
- lda: m
+ m: lda
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
- ldb: p
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
:fortran_help: " SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n\
diff --git a/dev/defs/zggsvp b/dev/defs/zggsvp
index 315eaf2..b5d83e6 100644
--- a/dev/defs/zggsvp
+++ b/dev/defs/zggsvp
@@ -104,7 +104,7 @@
:intent: output
:substitutions:
m: lda
- ldb: p
+ p: ldb
ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1"
ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1"
ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1"
diff --git a/dev/defs/zhbevd b/dev/defs/zhbevd
index 2732592..064d9a7 100644
--- a/dev/defs/zhbevd
+++ b/dev/defs/zhbevd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0"
- rwork:
:type: doublereal
:intent: output
@@ -54,6 +56,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -62,6 +66,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zhbgvd b/dev/defs/zhbgvd
index 928caf1..1d60215 100644
--- a/dev/defs/zhbgvd
+++ b/dev/defs/zhbgvd
@@ -58,6 +58,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0"
- rwork:
:type: doublereal
:intent: output
@@ -66,6 +68,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -74,6 +78,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zhbgvx b/dev/defs/zhbgvx
index 338a281..d9428bb 100644
--- a/dev/defs/zhbgvx
+++ b/dev/defs/zhbgvx
@@ -105,7 +105,7 @@
:intent: output
:substitutions:
ldz: "lsame_(&jobz,\"V\") ? n : 1"
- ldq: "1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0"
+ ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0"
:fortran_help: " SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zheev b/dev/defs/zheev
index 2007032..a525cae 100644
--- a/dev/defs/zheev
+++ b/dev/defs/zheev
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n-1
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zheevd b/dev/defs/zheevd
index 4b16b90..93936be 100644
--- a/dev/defs/zheevd
+++ b/dev/defs/zheevd
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0"
- rwork:
:type: doublereal
:intent: output
@@ -42,6 +44,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -50,6 +54,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zheevr b/dev/defs/zheevr
index 2bd179b..ca56829 100644
--- a/dev/defs/zheevr
+++ b/dev/defs/zheevr
@@ -69,6 +69,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: output
@@ -77,6 +79,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: 24*n
- iwork:
:type: integer
:intent: output
@@ -85,6 +89,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: 10*n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zheevx b/dev/defs/zheevx
index 82fe649..7cca498 100644
--- a/dev/defs/zheevx
+++ b/dev/defs/zheevx
@@ -64,6 +64,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : 2*n"
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zhegv b/dev/defs/zhegv
index 62b3f82..b35991a 100644
--- a/dev/defs/zhegv
+++ b/dev/defs/zhegv
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n-1
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zhegvd b/dev/defs/zhegvd
index 5256ba7..be42364 100644
--- a/dev/defs/zhegvd
+++ b/dev/defs/zhegvd
@@ -46,6 +46,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0"
- rwork:
:type: doublereal
:intent: output
@@ -54,6 +56,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -62,6 +66,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zhegvx b/dev/defs/zhegvx
index e527664..849f9b1 100644
--- a/dev/defs/zhegvx
+++ b/dev/defs/zhegvx
@@ -76,6 +76,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zhesvx b/dev/defs/zhesvx
index f888727..3bc62bb 100644
--- a/dev/defs/zhesvx
+++ b/dev/defs/zhesvx
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zhfrk b/dev/defs/zhfrk
index c262ee0..2115eb7 100644
--- a/dev/defs/zhfrk
+++ b/dev/defs/zhfrk
@@ -37,9 +37,12 @@
:type: doublecomplex
:intent: input/output
:dims:
- - n*(n+1)/2
-:substitutions: {}
-
+ - ldc
+:substitutions:
+ lda: "lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)"
+ n: ((int)sqrtf(ldc*8+1.0f)-1)/2
+:extras:
+ ldc: integer
:fortran_help: " SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zhgeqz b/dev/defs/zhgeqz
index ca87f89..2eb3759 100644
--- a/dev/defs/zhgeqz
+++ b/dev/defs/zhgeqz
@@ -75,6 +75,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zhpevd b/dev/defs/zhpevd
index 12f46d0..ea5c34a 100644
--- a/dev/defs/zhpevd
+++ b/dev/defs/zhpevd
@@ -39,6 +39,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0"
- rwork:
:type: doublereal
:intent: output
@@ -47,6 +49,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -55,6 +59,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zhpgvd b/dev/defs/zhpgvd
index 59274d5..3d7192f 100644
--- a/dev/defs/zhpgvd
+++ b/dev/defs/zhpgvd
@@ -47,6 +47,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0"
- rwork:
:type: doublereal
:intent: workspace
@@ -55,6 +57,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -63,6 +67,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zhseqr b/dev/defs/zhseqr
index 2c4a51c..dca1d0d 100644
--- a/dev/defs/zhseqr
+++ b/dev/defs/zhseqr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zla_gbamv b/dev/defs/zla_gbamv
index e471aca..e98e7df 100644
--- a/dev/defs/zla_gbamv
+++ b/dev/defs/zla_gbamv
@@ -34,7 +34,7 @@
:type: doublereal
:intent: input
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )"
- incx:
:type: integer
:intent: input
@@ -45,7 +45,7 @@
:type: doublereal
:intent: input/output
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
- incy:
:type: integer
:intent: input
diff --git a/dev/defs/zla_gbrfsx_extended b/dev/defs/zla_gbrfsx_extended
index 2ee5a3b..b65f934 100644
--- a/dev/defs/zla_gbrfsx_extended
+++ b/dev/defs/zla_gbrfsx_extended
@@ -129,8 +129,8 @@
:type: integer
:intent: output
:substitutions:
- ldafb: ldafb = MAX(1,n)
- ldab: ldab = MAX(1,n)
+ n: ldab
+ ldafb: MAX(1,n)
:fortran_help: " SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zla_geamv b/dev/defs/zla_geamv
index 7e1610b..db53332 100644
--- a/dev/defs/zla_geamv
+++ b/dev/defs/zla_geamv
@@ -28,7 +28,7 @@
:type: doublereal
:intent: input
:dims:
- - "lsame_(&trans,\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)"
+ - "trans == ilatrans_(\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)"
- incx:
:type: integer
:intent: input
@@ -39,7 +39,7 @@
:type: doublereal
:intent: input/output
:dims:
- - "((lsame_(&trans,\"N\")) || (lsame_(&trans,\"n\"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
+ - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )"
- incy:
:type: integer
:intent: input
diff --git a/dev/defs/zlaqr0 b/dev/defs/zlaqr0
index 9a0cacc..3247f21 100644
--- a/dev/defs/zlaqr0
+++ b/dev/defs/zlaqr0
@@ -55,6 +55,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zlaqr2 b/dev/defs/zlaqr2
index fece0e0..cd5fb1a 100644
--- a/dev/defs/zlaqr2
+++ b/dev/defs/zlaqr2
@@ -97,6 +97,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/zlaqr3 b/dev/defs/zlaqr3
index 6c042ce..70f1761 100644
--- a/dev/defs/zlaqr3
+++ b/dev/defs/zlaqr3
@@ -97,6 +97,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 2*nw
:substitutions:
ldwv: nw
ldt: nw
diff --git a/dev/defs/zlaqr4 b/dev/defs/zlaqr4
index b8e9119..b5fe42c 100644
--- a/dev/defs/zlaqr4
+++ b/dev/defs/zlaqr4
@@ -55,6 +55,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zlarfb b/dev/defs/zlarfb
index ec746d1..af36d37 100644
--- a/dev/defs/zlarfb
+++ b/dev/defs/zlarfb
@@ -61,7 +61,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zlarzb b/dev/defs/zlarzb
index fe75148..89f8064 100644
--- a/dev/defs/zlarzb
+++ b/dev/defs/zlarzb
@@ -64,7 +64,7 @@
:type: integer
:intent: input
:substitutions:
- ldwork: "max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0"
+ ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0"
:fortran_help: " SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\
* Purpose\n\
* =======\n\
diff --git a/dev/defs/zstedc b/dev/defs/zstedc
index b1ac38c..965e22c 100644
--- a/dev/defs/zstedc
+++ b/dev/defs/zstedc
@@ -36,6 +36,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||lsame_(&compz,\"I\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? n*n : 0"
- rwork:
:type: doublereal
:intent: output
@@ -44,6 +46,8 @@
- lrwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0"
- iwork:
:type: integer
:intent: output
@@ -52,6 +56,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zstegr b/dev/defs/zstegr
index 14f03d6..8cf0a7a 100644
--- a/dev/defs/zstegr
+++ b/dev/defs/zstegr
@@ -67,6 +67,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -75,6 +77,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zstemr b/dev/defs/zstemr
index 1e76071..d5ac0f9 100644
--- a/dev/defs/zstemr
+++ b/dev/defs/zstemr
@@ -70,6 +70,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0"
- iwork:
:type: integer
:intent: output
@@ -78,6 +80,8 @@
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zsysv b/dev/defs/zsysv
index 0135a46..c547f20 100644
--- a/dev/defs/zsysv
+++ b/dev/defs/zsysv
@@ -43,6 +43,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zsysvx b/dev/defs/zsysvx
index 82f87ee..55f490a 100644
--- a/dev/defs/zsysvx
+++ b/dev/defs/zsysvx
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: 3*n
- rwork:
:type: doublereal
:intent: workspace
diff --git a/dev/defs/zsytri2 b/dev/defs/zsytri2
index d6daa70..b0d9db6 100644
--- a/dev/defs/zsytri2
+++ b/dev/defs/zsytri2
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: (n+nb+1)*(nb+3)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ztgsen b/dev/defs/ztgsen
index f40af7d..c4672b0 100644
--- a/dev/defs/ztgsen
+++ b/dev/defs/ztgsen
@@ -84,18 +84,22 @@
:type: doublecomplex
:intent: output
:dims:
- - "ijob==0 ? 0 : MAX(1,lwork)"
+ - MAX(1,lwork)
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0"
- iwork:
:type: integer
:intent: output
:dims:
- - "ijob==0 ? 0 : MAX(1,liwork)"
+ - MAX(1,liwork)
- liwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ztgsna b/dev/defs/ztgsna
index 04879d8..a96378b 100644
--- a/dev/defs/ztgsna
+++ b/dev/defs/ztgsna
@@ -77,6 +77,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/ztgsyl b/dev/defs/ztgsyl
index 4421095..4d7e8f7 100644
--- a/dev/defs/ztgsyl
+++ b/dev/defs/ztgsyl
@@ -83,6 +83,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1"
- iwork:
:type: integer
:intent: workspace
diff --git a/dev/defs/ztrsen b/dev/defs/ztrsen
index 0ccdff3..6be524e 100644
--- a/dev/defs/ztrsen
+++ b/dev/defs/ztrsen
@@ -57,6 +57,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/ztzrzf b/dev/defs/ztzrzf
index d947a7d..dbb48c3 100644
--- a/dev/defs/ztzrzf
+++ b/dev/defs/ztzrzf
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunbdb b/dev/defs/zunbdb
index ba81ebd..ec800c6 100644
--- a/dev/defs/zunbdb
+++ b/dev/defs/zunbdb
@@ -92,11 +92,13 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m-q
- info:
:type: integer
:intent: output
:substitutions:
- ldx11: p
+ p: ldx11
ldx12: p
ldx21: p
ldx22: p
diff --git a/dev/defs/zungbr b/dev/defs/zungbr
index 49b3c00..63833d0 100644
--- a/dev/defs/zungbr
+++ b/dev/defs/zungbr
@@ -37,6 +37,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: MIN(m,n)
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunghr b/dev/defs/zunghr
index 7f7d5de..08b6c6e 100644
--- a/dev/defs/zunghr
+++ b/dev/defs/zunghr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: ihi-ilo
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunglq b/dev/defs/zunglq
index a69a481..11157a2 100644
--- a/dev/defs/zunglq
+++ b/dev/defs/zunglq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zungql b/dev/defs/zungql
index 7e849f1..fded546 100644
--- a/dev/defs/zungql
+++ b/dev/defs/zungql
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zungqr b/dev/defs/zungqr
index c45a3d1..6605858 100644
--- a/dev/defs/zungqr
+++ b/dev/defs/zungqr
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zungrq b/dev/defs/zungrq
index 4d03205..f9e9542 100644
--- a/dev/defs/zungrq
+++ b/dev/defs/zungrq
@@ -34,6 +34,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: m
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zungtr b/dev/defs/zungtr
index d589363..3e84a55 100644
--- a/dev/defs/zungtr
+++ b/dev/defs/zungtr
@@ -31,6 +31,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: n-1
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmbr b/dev/defs/zunmbr
index cab1b33..9800c67 100644
--- a/dev/defs/zunmbr
+++ b/dev/defs/zunmbr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmhr b/dev/defs/zunmhr
index 1a3235b..37ed758 100644
--- a/dev/defs/zunmhr
+++ b/dev/defs/zunmhr
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmlq b/dev/defs/zunmlq
index 6a5a4bf..2c26d36 100644
--- a/dev/defs/zunmlq
+++ b/dev/defs/zunmlq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmql b/dev/defs/zunmql
index e74b7f8..c906a39 100644
--- a/dev/defs/zunmql
+++ b/dev/defs/zunmql
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmqr b/dev/defs/zunmqr
index d6bf577..b509f31 100644
--- a/dev/defs/zunmqr
+++ b/dev/defs/zunmqr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmrq b/dev/defs/zunmrq
index a4abc9f..705739e 100644
--- a/dev/defs/zunmrq
+++ b/dev/defs/zunmrq
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmrz b/dev/defs/zunmrz
index 6ea9d49..7aa003c 100644
--- a/dev/defs/zunmrz
+++ b/dev/defs/zunmrz
@@ -52,6 +52,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/defs/zunmtr b/dev/defs/zunmtr
index d4e22e0..9ef5191 100644
--- a/dev/defs/zunmtr
+++ b/dev/defs/zunmtr
@@ -49,6 +49,8 @@
- lwork:
:type: integer
:intent: input
+ :option: true
+ :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0"
- info:
:type: integer
:intent: output
diff --git a/dev/make_csrc.rb b/dev/make_csrc.rb
index 0e65c46..4b698e2 100644
--- a/dev/make_csrc.rb
+++ b/dev/make_csrc.rb
@@ -4,7 +4,7 @@ require "yaml"
require "pp"
require "common"
-RBPREFIX = "rb_"
+RBPREFIX = "rblapack_"
NATYPES = {
"integer" => "NA_LINT",
@@ -16,19 +16,23 @@ NATYPES = {
}
+TOPDIR = File.join(File.dirname(__FILE__), "..")
-def get_cobj(name, type, sub_name)
+
+
+def get_cobj(name, type, sub_name, indent=2)
+ indent = " "*indent
case type
when "integer"
- return " #{name} = NUM2INT(#{RBPREFIX}#{name});\n"
+ return "#{indent}#{name} = NUM2INT(#{RBPREFIX}#{name});\n"
when "real"
- return " #{name} = (real)NUM2DBL(#{RBPREFIX}#{name});\n"
+ return "#{indent}#{name} = (real)NUM2DBL(#{RBPREFIX}#{name});\n"
when "doublereal"
- return " #{name} = NUM2DBL(#{RBPREFIX}#{name});\n"
+ return "#{indent}#{name} = NUM2DBL(#{RBPREFIX}#{name});\n"
when "complex"
code =<<"EOF"
- #{name}.r = (real)NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("real"), 0));
- #{name}.i = (real)NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("imag"), 0));
+#{indent}#{name}.r = (real)NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("real"), 0));
+#{indent}#{name}.i = (real)NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("imag"), 0));
EOF
return code
when "doublecomplex"
@@ -73,33 +77,41 @@ def get_robj(name, type, flag=false)
end
-def get_input(name, type, dims, i, varset, sub_name, subst)
+def get_input(name, type, dims, i, varset, sub_name, subst, indent=2)
if dims.nil?
- return get_cobj(name, type, sub_name)
+ return get_cobj(name, type, sub_name, indent)
else
+ indent = " "*indent
if type == "char"
- return " #{name} = StringValueCStr(#{RBPREFIX}#{name});\n"
+ return "#{indent}#{name} = StringValueCStr(#{RBPREFIX}#{name});\n"
+ end
+ if i.kind_of?(Integer)
+ arg = "#{i+1}th argument"
+ else
+ arg = "option"
end
code =<<"EOF"
- if (!NA_IsNArray(#{RBPREFIX}#{name}))
- rb_raise(rb_eArgError, "#{name} (#{i+1}th argument) must be NArray");
- if (NA_RANK(#{RBPREFIX}#{name}) != #{dims.length})
- rb_raise(rb_eArgError, "rank of #{name} (#{i+1}th argument) must be %d", #{dims.length});
-EOF
- ndim = dims.length
- ndim.times do |jj|
- j = ndim - jj - 1
- dim = dims[j]
+#{indent}if (!NA_IsNArray(#{RBPREFIX}#{name}))
+#{indent} rb_raise(rb_eArgError, "#{name} (#{arg}) must be NArray");
+#{indent}if (NA_RANK(#{RBPREFIX}#{name}) != #{dims.length})
+#{indent} rb_raise(rb_eArgError, "rank of #{name} (#{arg}) must be %d", #{dims.length});
+EOF
+# ndim = dims.length
+# ndim.times do |jj|
+# j = ndim - jj - 1
+# dim = dims[j]
+ dims.each_with_index do |dim, j|
raise "bug: NA_SHAPE? cannot use {#{dim} in #{name}: #{sub_name}" if j>2
if varset.include?(dim)
+ dimo = subst[dim] || dim
code << <<"EOF"
- if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != #{dim})
- rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be #{dim}");
+#{indent}if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != #{dim})
+#{indent} rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be #{dimo.gsub(/"/,'\"')}");
EOF
elsif (shape = @shape[dim])
code << <<"EOF"
- if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != #{dim})
- rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be the same as shape #{shape[:index]} of #{shape[:name]}");
+#{indent}if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != #{dim})
+#{indent} rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be the same as shape #{shape[:index]} of #{shape[:name]}");
EOF
elsif /^[a-z][a-z_\d]*$/ !~ dim
get_vars(dim).each{|d|
@@ -108,37 +120,38 @@ EOF
end
}
code << <<"EOF"
- if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != (#{dim}))
- rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be %d", #{dim});
+#{indent}if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != (#{dim}))
+#{indent} rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be %d", #{dim});
EOF
else
- code << " #{dim} = NA_SHAPE#{j}(#{RBPREFIX}#{name});\n"
+ code << "#{indent}#{dim} = NA_SHAPE#{j}(#{RBPREFIX}#{name});\n"
@shape[dim] = {:name => name, :index => j}
if s = subst[dim]
- code << <<EOF
- if (#{dim} != (#{s}))
- rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be %d", #{s});
-EOF
- if /^[a-z][a-z_\d]*$/ =~ s
- code << " #{s} = #{dim};\n"
+ if /^[a-z][a-z_\d]*$/ =~ s && !varset.include?(s)
+ code << "#{indent}#{s} = #{dim};\n"
varset.push s
+ else
+ code << <<EOF
+#{indent}if (#{dim} != (#{s}))
+#{indent} rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be %d", #{s});
+EOF
end
end
end
end
natype = NATYPES[type] || raise("na type is not deifned (#{type})")
code << <<"EOF"
- if (NA_TYPE(#{RBPREFIX}#{name}) != #{natype})
- #{RBPREFIX}#{name} = na_change_type(#{RBPREFIX}#{name}, #{natype});
- #{name} = NA_PTR_TYPE(#{RBPREFIX}#{name}, #{type}*);
+#{indent}if (NA_TYPE(#{RBPREFIX}#{name}) != #{natype})
+#{indent} #{RBPREFIX}#{name} = na_change_type(#{RBPREFIX}#{name}, #{natype});
+#{indent}#{name} = NA_PTR_TYPE(#{RBPREFIX}#{name}, #{type}*);
EOF
end
end
-def create_code(name)
- def_fname = File.join(File.dirname(__FILE__), "defs", name)
+def create_code(name, flag)
+ def_fname = File.join(TOPDIR, "dev", "defs", name)
hash = nil
begin
File.open(def_fname) do |file|
@@ -176,11 +189,16 @@ def create_code(name)
raise "no args (#{name})"
end
+ unless flag
+ return true, sub_name
+ end
+
inputs = Array.new
outputs = Array.new
inouts = Array.new
workspaces = Array.new
+ options = Array.new
block = nil
arg_names.each{|aname|
arg = args[aname]
@@ -189,11 +207,19 @@ def create_code(name)
end
case arg[:intent]
when "input"
- inputs.push aname
+ if arg[:option]
+ options.push aname
+ else
+ inputs.push aname
+ end
when "output"
outputs.push aname
when "input/output"
- inputs.push aname
+ if arg[:option]
+ options.push aname
+ else
+ inputs.push aname
+ end
inouts.push aname
when "workspace"
workspaces.push aname
@@ -225,6 +251,9 @@ def create_code(name)
inputs.delete(dim)
}
}
+ subst.keys.each do |k|
+ inputs.delete(k)
+ end
if @@debug
p "inputs"
@@ -235,34 +264,42 @@ def create_code(name)
p inouts
p "workspaces"
p workspaces
+ p "options"
+ p options
p "block"
p block
end
code = ""
+ cargs = arg_names.map do |an|
+ arg = args[an]
+ t = arg[:type]
+ t + (t=="L_fp" ? " " : "* ") + an
+ end.join(", ")
case sub_type
when :subroutine
- code << "extern VOID #{sub_name}_(#{arg_names.collect{|an|t = args[an][:type];t+' *'+an}.join(', ')});\n\n"
+ code << "extern VOID #{sub_name}_(#{cargs});\n\n"
when:function
outputs.push "__out__"
args["__out__"] = {:type => func_type}
if /complex/ =~ func_type || func_type == "char"
- code << "extern VOID #{sub_name}_(#{func_type} *__out__, #{arg_names.collect{|an|t = args[an][:type];t+' *'+an}.join(', ')});\n\n"
+ code << "extern VOID #{sub_name}_(#{func_type} *__out__, #{cargs});\n\n"
else
- code << "extern #{func_type} #{sub_name}_(#{arg_names.collect{|an|t = args[an][:type];t+' *'+an}.join(', ')});\n\n"
+ code << "extern #{func_type} #{sub_name}_(#{cargs});\n\n"
end
else
raise "category is invalid: #{sub_type} (#{sub_name})"
end
code << <<"EOF"
+
static VALUE
#{RBPREFIX}#{sub_name}(int argc, VALUE *argv, VALUE self){
EOF
dimdefs = Array.new
- (inputs+outputs).each{|aname|
+ (inputs+options+outputs).each{|aname|
arg = args[aname]
code << <<"EOF"
VALUE #{RBPREFIX}#{aname};
@@ -291,7 +328,7 @@ EOF
code << " #{arg[:type]} #{arg[:dims] ? "*" : ""}#{aname};\n"
}
code << "\n"
- (inputs+outputs+workspaces).each{|aname|
+ (inputs+options+outputs+workspaces).each{|aname|
arg = args[aname]
if dims = arg[:dims]
dims.each{|dim|
@@ -327,44 +364,79 @@ EOF
block_help = ""
end
- help_code = <<"EOF"
+ usage_code = <<"EOF"
USAGE:
- #{(outputs+inouts).join(", ")} = NumRu::Lapack.#{sub_name}( #{inputs.join(", ")})#{block_help}
- or
- NumRu::Lapack.#{sub_name} # print help
+ #{(outputs+inouts).join(", ")} = NumRu::Lapack.#{sub_name}( #{inputs.join(", ")}, [#{(options+["usage","help"]).map{|on| ":"+on+" => "+on}.join(", ")}])#{block_help}
+EOF
+ help_code = <<"EOF"
+#{usage_code}
FORTRAN MANUAL
#{help}
EOF
ilen = inputs.length
code << <<"EOF"
- if (argc == 0) {
- printf("%s\\n", "#{help_code.gsub(/\\/,'\\\\\\').gsub(/\n/,'\n').gsub(/"/,'\"')}");
- return Qnil;
- }
- if (argc != #{ilen})
+ VALUE #{RBPREFIX}options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ #{RBPREFIX}options = argv[argc];
+ if (rb_hash_aref(#{RBPREFIX}options, sHelp) == Qtrue) {
+ printf("%s\\n", "#{help_code.gsub(/\\/,'\\\\\\').gsub(/\n/,'\n').gsub(/"/,'\"')}");
+ return Qnil;
+ }
+ if (rb_hash_aref(#{RBPREFIX}options, sUsage) == Qtrue) {
+ printf("%s\\n", "#{usage_code.gsub(/\\/,'\\\\\\').gsub(/\n/,'\n').gsub(/"/,'\"')}");
+ return Qnil;
+ }
+ } else
+ #{RBPREFIX}options = Qnil;
+ if (argc != #{ilen} && argc != #{ilen+options.length})
rb_raise(rb_eArgError,"wrong number of arguments (%d for #{ilen})", argc);
EOF
inputs.each_with_index{|arg,i|
code << " #{RBPREFIX}#{arg} = argv[#{i}];\n"
}
+ code << " if (argc == #{ilen+options.length}) {\n"
+ options.each_with_index do |arg,i|
+ code << " #{RBPREFIX}#{arg} = argv[#{i+ilen}];\n"
+ end
+ code << " } else if (#{RBPREFIX}options != Qnil) {\n"
+ options.each do |opt|
+ code << " #{RBPREFIX}#{opt} = rb_hash_aref(#{RBPREFIX}options, ID2SYM(rb_intern(\"#{opt}\")));\n"
+ end
+ code << " } else {\n"
+ options.each_with_index do |arg,i|
+ code << " #{RBPREFIX}#{arg} = Qnil;\n"
+ end
+ code << " }\n"
+
code << "\n"
order = Hash.new
- inputs.each_with_index do |arg,i|
+ (inputs+options).each_with_index do |arg,i|
aryd = Array.new
aryp = Array.new
if dim = args[arg][:dims]
dim.each do |d|
vs = get_vars(d)
- if vs.length==1 && vs[0] == d
+ if vs.length==1 && vs[0] == d && !subst.keys.include?(d) && !args[arg][:option]
aryp.push d
else
aryd.push vs
end
end
end
+ if vs = args[arg][:default]
+ begin
+ get_vars(vs).each do |v|
+ aryd.push v
+ end
+ rescue
+ p sub_name
+ raise $!
+ end
+ end
aryd.flatten!
aryp.uniq!
aryd.uniq!
@@ -373,57 +445,71 @@ EOF
subst.each do |k,v|
order[k] = {:depends => get_vars(v).uniq, :type => :subst, :value => v}
end
- order = order.sort do |a0,a1|
- k0, v0 = a0
- k1, v1 = a1
- d0 = v0[:depends]
- d1 = v1[:depends]
- p0 = v0[:provides]
- p1 = v1[:provides]
- if d0.empty? && d1.empty?
- 0
- elsif d0.empty?
- -1
- elsif d1.empty?
- 1
- else
- flag0 = d0.include?(k1)
- flag1 = d1.include?(k0)
- if p0
- p0.each do |p|
- if d1.include?(p)
- flag1 = true
- break
+
+ oks = order.keys
+ new_order = Array.new
+ while oks.any?
+ flag = false
+ oks.each do |k0|
+ df = false
+ v0 = order[k0]
+ catch(:depend) do
+ v0[:depends].each do |d|
+ if oks.include?(d)
+ if (odd = order[d][:depends]).any?
+ odd.each do |od|
+ throw(:depend) unless (pr=v0[:provides]) && pr.include?(od)
+ end
+ else
+ throw(:depend)
+ end
end
- end
- end
- if p1
- p1.each do |p|
- if d0.include?(p)
- flag0 = true
- break
+ oks.each do |k1|
+ throw(:depend) if (pr=order[k1][:provides]) && pr.include?(d)
end
end
+ new_order.push [k0, v0]
+ oks.delete(k0)
+ flag = true
end
- if flag0 && flag1
- pp order
- p [k0, k1]
- pp v0
- pp v1
- raise "depends each other #{name}"
- end
- flag0 ? 1 : flag1 ? -1 : 0
+ end
+ unless flag
+ p "order"
+ pp order
+ raise "depends each others: #{oks.join(", ")} (#{sub_name})"
end
end
+ order = new_order
- pp order if @@debug
+ if @@debug
+ p "order"
+ pp order
+ end
varset = Array.new
@shape = Hash.new
order.each do |name, v|
if v[:type] == :input
arg = args[name]
- code << get_input(name, arg[:type], arg[:dims], v[:order], varset, sub_name, subst)
+ if arg[:option]
+ if arg[:default]
+ code << <<EOF
+ if (#{RBPREFIX}#{name} == Qnil)
+ #{name} = #{arg[:default]};
+ else {
+#{get_input(name, arg[:type], arg[:dims], :option, varset, sub_name, subst, 4).chop}
+ }
+EOF
+ else
+ code << <<EOF
+ if (#{RBPREFIX}#{name} != Qnil) {
+#{get_input(name, arg[:type], arg[:dims], :option, varset, sub_name, subst, 4).chop}
+ }
+EOF
+ end
+ else
+ code << get_input(name, arg[:type], arg[:dims], v[:order], varset, sub_name, subst)
+ end
else
unless varset.include?(name)
code << " #{name} = #{v[:value]};\n"
@@ -460,23 +546,65 @@ EOF
arg = args[name]
type = arg[:type]
if dims = arg[:dims]
+ if outdims = arg[:outdims]
+ if outdims.length != dims.length
+ raise "dimensions for input and output are different: #{dims.join(",")} and #{outdims.join(",")}"
+ end
+ end
code << <<"EOF"
{
int shape[#{dims.length}];
EOF
dims.each_with_index{|dim,k|
- get_vars(dim).each{|d|
+ ds = get_vars(dim)
+ if outdims
+ od = outdims[k]
+ ds += get_vars(od)
+ end
+ ds.each{|d|
unless varset.include?(d) || @shape[d]
raise "undefined #{d} #{name} #{sub_name}"
end
}
- code << " shape[#{k}] = #{dim};\n"
+ d = outdims && dim != od ? "MAX(#{dim}, #{od})" : dim
+ code << " shape[#{k}] = #{d};\n"
}
code << <<"EOF"
#{RBPREFIX}#{name}_out__ = na_make_object(#{NATYPES[type]}, #{dims.length}, shape, cNArray);
}
#{name}_out__ = NA_PTR_TYPE(#{RBPREFIX}#{name}_out__, #{type}*);
- MEMCPY(#{name}_out__, #{name}, #{type}, NA_TOTAL(#{RBPREFIX}#{name}));
+EOF
+ if outdims
+ sh = Array.new
+ ndims = dims.length
+ code << <<EOF
+ {
+ VALUE __shape__[#{ndims+1}];
+EOF
+ ndims.times do |n|
+ d = dims[n]
+ od = outdims[n]
+ if d == od
+ code << " __shape__[#{n}] = Qtrue;\n"
+ else
+ code << " __shape__[#{n}] = #{d} < #{od} ? rb_range_new(#{RBPREFIX}ZERO, INT2NUM(#{d}), Qtrue) : Qtrue;\n"
+ end # if d == od
+ end # ndims.times do
+ code << <<"EOF"
+ __shape__[#{ndims}] = #{RBPREFIX}#{name};
+ na_aset(#{ndims+1}, __shape__, #{RBPREFIX}#{name}_out__);
+ }
+EOF
+ else
+ if arg[:option] && arg[:default].nil?
+ code << " if (#{RBPREFIX}#{name} != Qnil) {\n "
+ end
+ code << " MEMCPY(#{name}_out__, #{name}, #{type}, NA_TOTAL(#{RBPREFIX}#{name}));\n"
+ if arg[:option] && arg[:default].nil?
+ code << " }\n"
+ end
+ end
+ code << <<"EOF"
#{RBPREFIX}#{name} = #{RBPREFIX}#{name}_out__;
#{name} = #{name}_out__;
EOF
@@ -527,9 +655,28 @@ EOF
out.each{|name|
arg = args[name]
- if arg[:dims]
+ if dims = arg[:dims]
if arg[:type] == "char"
code << " #{RBPREFIX}#{name} = rb_str_new2(&#{name});\n"
+ elsif outdims = arg[:outdims]
+ ndims = dims.length
+ code << <<EOF
+ {
+ VALUE __shape__[#{ndims}];
+EOF
+ ndims.times do |n|
+ d = dims[n]
+ od = outdims[n]
+ if d == od
+ code << " __shape__[#{n}] = Qtrue;\n"
+ else
+ code << " __shape__[#{n}] = #{d} < #{od} ? Qtrue : rb_range_new(#{RBPREFIX}ZERO, INT2NUM(#{od}), Qtrue);\n"
+ end # if d == od
+ end # ndims.times do
+ code << <<"EOF"
+ #{RBPREFIX}#{name} = na_aref(#{ndims}, __shape__, #{RBPREFIX}#{name});
+ }
+EOF
end
else
if name == "__out__" && arg[:type].nil?
@@ -557,12 +704,16 @@ EOF
code << <<"EOF"
void
-init_lapack_#{sub_name}(VALUE mLapack){
+init_lapack_#{sub_name}(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ #{RBPREFIX}ZERO = zero;
+
rb_define_module_function(mLapack, \"#{sub_name}\", #{RBPREFIX}#{sub_name}, -1);
}
EOF
- code_all = "#include \"#{RBPREFIX}lapack.h\"\n\n"
+ code_all = "#include \"rb_lapack.h\"\n\n"
if block
arg = args[block]
@@ -589,7 +740,7 @@ EOF
}
code_all << <<EOF
- rb_ret = rb_yield_values(#{anum}, #{ras.join(", ")});
+ #{RBPREFIX}ret = rb_yield_values(#{anum}, #{ras.join(", ")});
EOF
code_all << get_cobj("ret", type, sub_name)
@@ -605,22 +756,28 @@ EOF
return [code_all, sub_name]
end
-def generate_code(fnames)
+def generate_code(fnames, names)
nfnames = fnames.length
sub_names = Array.new
fnames.each_with_index{|fname,i|
print "#{i+1}/#{nfnames}\n" if (i+1)%100==0
name = File.basename(fname)
- code, sub_name = create_code(name)
+ flag = names.nil? || names.include?(name)
+ code, sub_name = create_code(name, flag)
if code
sub_names.push sub_name
- File.open(sub_name+".c","w"){|file|
- file.print code
- }
+ if flag
+ cfname = File.join(TOPDIR, "ext","#{sub_name}.c")
+ if File.exists?(cfname)
+ code_org = File.read(cfname)
+ next if code_org == code
+ end
+ File.open(cfname,"w"){|file| file.print code}
+ end
end
}
- File.open("#{RBPREFIX}lapack.h","w"){|file|
+ File.open(File.join(TOPDIR, "ext", "rb_lapack.h"),"w"){|file|
file.print <<"EOF"
#include <string.h>
#include <math.h>
@@ -628,23 +785,31 @@ def generate_code(fnames)
#include "narray.h"
#include "f2c_minimal.h"
-#define MAX(a,b) (a > b ? a : b)
-#define MIN(a,b) (a < b ? a : b)
-#define LG(n) ((int)ceil(log((double)n)/log(2.0)))
+#define MAX(a,b) ((a) > (b) ? (a) : (b))
+#define MIN(a,b) ((a) < (b) ? (a) : (b))
+#define LG(n) ((int)ceil(log((double)(n))/log(2.0)))
extern logical lsame_(char *ca, char *cb);
+extern integer ilatrans_(char* trans);
+extern integer ilaenv_(integer* ispec, char* name, char* opts, integer* n1, integer* n2, integer* n3, integer* n4);
+
+
+static VALUE sHelp, sUsage;
+static VALUE #{RBPREFIX}ZERO;
+
EOF
}
- File.open("rb_lapack.c","w"){|file|
+ File.open(File.join(TOPDIR,"ext","rb_lapack.c"), "w"){|file|
file.print <<"EOF"
#include "ruby.h"
+#include "rb_lapack.h"
EOF
sub_names.each{|sname|
- file.print "extern void init_lapack_#{sname}(VALUE mLapack);\n"
+ file.print "extern void init_lapack_#{sname}(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE #{RBPREFIX}ZERO);\n"
}
file.print <<"EOF"
@@ -658,9 +823,14 @@ void Init_lapack(){
mNumRu = rb_define_module("NumRu");
mLapack = rb_define_module_under(mNumRu, "Lapack");
+ sHelp = ID2SYM(rb_intern("help"));
+ sUsage = ID2SYM(rb_intern("usage"));
+
+ #{RBPREFIX}ZERO = INT2NUM(0);
+
EOF
sub_names.each{|sname|
- file.print " init_lapack_#{sname}(mLapack);\n"
+ file.print " init_lapack_#{sname}(mLapack, sHelp, sUsage, #{RBPREFIX}ZERO);\n"
}
file.print "}\n"
}
@@ -672,15 +842,20 @@ end
@@debug = ARGV.delete("--debug")
-dname = ARGV[0] || raise("Usage: ruby #$0 path_to_lapack_src")
-if File.directory?(dname)
- reg = File.join(dname, "[a-z]*[a-z0-9]")
- fnames = Dir[reg]
-else
- fnames = [dname]
- @@debug = true
+#dname = ARGV.shift || raise("Usage: ruby #$0 path_to_lapack_src [name0, name1, ..]")
+dname = File.join(TOPDIR, "dev", "defs")
+unless File.directory?(dname)
+ raise "the first argument must be directory"
end
-generate_code(fnames)
+unless ARGV.empty?
+ names = ARGV
+ @@debug = true
+else
+ names = nil
+end
+reg = File.join(dname, "[a-z]*[a-z0-9]")
+fnames = Dir[reg]
+generate_code(fnames, names)
diff --git a/dev/mkdoc.rb b/dev/mkdoc.rb
index de486f5..0b49245 100644
--- a/dev/mkdoc.rb
+++ b/dev/mkdoc.rb
@@ -39,45 +39,24 @@ MatrixTypes = [
]
-def parse_html(fname)
- hash = Hash.new
- name = nil
- File.foreach(fname){|line|
- if /^file <a href=".+">([a-z_\d]+)\.f<\/a>/ =~ line
- name = $1
- elsif name
- if /^for\s+(.*)$/ =~ line
- hash[name] = $1
- elsif /^,\s+(.*)$/ =~ line
- hash[name] ||= ""
- hash[name] << $1
- elsif /^gams/ =~ line
- name = nil
- end
- end
- }
- return hash
-end
-
require "numru/lapack"
include NumRu
prefix = File.dirname(__FILE__)+"/../doc"
-path = ARGV[0] || raise("Usage: ruby #$0 path_to_document_html")
desc = Hash.new
-%w(s d c z ds zc).each{|tn|
- fname = File.join(path, tn+".html")
- desc.update parse_html(fname)
-}
-methods = Lapack.methods
+methods = Lapack.singleton_methods
+dts = Hash.new
DataTypes.each{|cdt, dt|
cdt = cdt.downcase
dmethods = Array.new
methods.each{|m|
dmethods.push m if /^#{cdt}/ =~ m
}
+ dmethods.each do |m|
+ methods.delete m
+ end
mts = Array.new
MatrixTypes.each{|cmt, mt|
cmt = cmt.downcase
@@ -90,6 +69,8 @@ DataTypes.each{|cdt, dt|
ms.sort!
unless ms.empty?
mts.push [cmt,mt]
+ dts[cmt] ||= Array.new
+ dts[cmt].push [cdt, dt]
File.open(File.join(prefix,"#{cdt}#{cmt}.html"),"w"){|file|
file.print <<"EOF"
<HTML>
@@ -103,7 +84,7 @@ DataTypes.each{|cdt, dt|
EOF
ms.each{|m|
file.print <<"EOF"
- <LI><A HREF=\"##{m}\">#{m}</A> : #{desc[m]}</LI>
+ <LI><A HREF=\"##{m}\">#{m}</A></LI>
EOF
}
file.print <<"EOF"
@@ -112,17 +93,17 @@ EOF
EOF
ms.each{|m|
file.print <<"EOF"
- <A NAME="#{m}"></A>
- <H2>#{m}</H2>
- #{desc[m]}
- <PRE>
-EOF
- stdout_org = STDOUT.dup
- STDOUT.flush
- STDOUT.reopen(file)
- Lapack.send(m)
- STDOUT.flush
- STDOUT.reopen(stdout_org)
+ <A NAME="#{m}"></A>
+ <H2>#{m}</H2>
+ <PRE>
+EOF
+ IO.popen("-") do |io|
+ if io # parent
+ file.print io.read
+ else # child
+ Lapack.send(m, :help => true)
+ end
+ end
file.print <<"EOF"
</PRE>
<A HREF="#top">go to the page top</A>
@@ -131,7 +112,8 @@ EOF
}
file.print <<"EOF"
<HR />
- <A HREF="#{cdt}.html">back to matrix types</A>
+ <A HREF="#{cdt}.html">back to matrix types</A><BR>
+ <A HREF="#{cdt}.html">back to data types</A>
</BODY>
</HTML>
EOF
@@ -156,7 +138,7 @@ EOF
file.print <<"EOF"
</UL>
<HR />
- <A HREF="index.html">back to data types</A>
+ <A HREF="index.html">back to index.html</A>
</BODY>
</HTML>
EOF
@@ -164,6 +146,82 @@ EOF
end
}
+MatrixTypes.each do |cmt,mt|
+ cmt = cmt.downcase
+ if dts[cmt]
+ File.open(File.join(prefix,"#{cmt}.html"),"w") do |file|
+ file.print <<"EOF"
+<HTML>
+ <HEAD>
+ <TITLE>#{mt} routines</TITLE>
+ </HEAD>
+ <BODY>
+ <H1>#{mt} routines</H1>
+ <UL>
+EOF
+ dts[cmt].each{|cdt,dt|
+ file.print " <LI><A HREF=\"#{cdt}#{cmt}.html\">#{cdt.upcase}: #{dt}</A></LI>\n"
+ }
+ file.print <<"EOF"
+ </UL>
+ <HR />
+ <A HREF="index.html">back to index.html</A>
+ </BODY>
+</HTML>
+EOF
+ end
+ end
+end
+
+if methods.any?
+ File.open(File.join(prefix,"others.html"),"w") do |file|
+ file.print <<EOF
+<HTML>
+ <HEAD>
+ <TITLE>other routines</TITLE>
+ </HEAD>
+ <BODY>
+ <A NAME="top"></A>
+ <H1>other routines</H1>
+ <UL>
+EOF
+ methods.each do |m|
+ file.print <<EOF
+ <LI><A HREF=\"##{m}\">#{m}</A></LI>
+EOF
+ end
+ file.print <<EOF
+ </UL>
+
+EOF
+ methods.each do |m|
+ file.print <<EOF
+ <A NAME="#{m}"></A>
+ <H2>#{m}</H2>
+ <PRE>
+EOF
+ IO.popen("-") do |io|
+ if io # parent
+ file.print io.read
+ else # child
+ Lapack.send(m, :help => true)
+ end
+ end
+ file.print <<EOF
+ </PRE>
+ <A HREF="#top">go to the page top</A>
+
+EOF
+ end
+ file.print <<"EOF"
+ <HR />
+ <A HREF="index.html">back to index</A>
+ </BODY>
+</HTML>
+EOF
+ end
+end
+
File.open(File.join(prefix,"index.html"),"w"){|file|
file.print <<"EOF"
<HTML>
@@ -179,6 +237,28 @@ EOF
}
file.print <<"EOF"
</UL>
+
+ <H1>Matrix types</H1>
+ <UL>
+EOF
+ MatrixTypes.each do |cmt,mt|
+ if dts[cmt.downcase]
+ file.print " <LI><A HREF=\"#{cmt.downcase}.html\">#{cmt}: #{mt}</A></LI>\n"
+ end
+ end
+ file.print <<"EOF"
+ </UL>
+EOF
+ if methods.any?
+ file.print <<EOF
+
+ <H1>others</H1>
+ <UL>
+ <LI><A HREF=\"others.html\">others</A></LI>
+ </UL>
+EOF
+ end
+ file.print <<"EOF"
</BODY>
</HTML>
EOF
diff --git a/dgbbrd.c b/dgbbrd.c
deleted file mode 100644
index 0ece98e..0000000
--- a/dgbbrd.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbbrd_(char *vect, integer *m, integer *n, integer *ncc, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *d, doublereal *e, doublereal *q, integer *ldq, doublereal *pt, integer *ldpt, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dgbbrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_pt;
- doublereal *pt;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer ldc;
- integer ncc;
- integer ldq;
- integer m;
- integer ldpt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c)\n or\n NumRu::Lapack.dgbbrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBBRD reduces a real general m-by-n band matrix A to upper\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) DOUBLE PRECISION array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- vect = StringValueCStr(rb_vect)[0];
- ku = NUM2INT(rb_ku);
- m = ldab;
- ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
- ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = m;
- rb_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[2];
- shape[0] = ldpt;
- shape[1] = n;
- rb_pt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- pt = NA_PTR_TYPE(rb_pt, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (2*MAX(m,n)));
-
- dgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_q, rb_pt, rb_info, rb_ab, rb_c);
-}
-
-void
-init_lapack_dgbbrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbbrd", rb_dgbbrd, -1);
-}
diff --git a/dgbcon.c b/dgbcon.c
deleted file mode 100644
index 9db9424..0000000
--- a/dgbcon.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbcon_(char *norm, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dgbcon( norm, kl, ku, ab, ipiv, anorm)\n or\n NumRu::Lapack.dgbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBCON estimates the reciprocal of the condition number of a real\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by DGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_anorm = argv[5];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dgbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbcon", rb_dgbcon, -1);
-}
diff --git a/dgbequ.c b/dgbequ.c
deleted file mode 100644
index dce7f35..0000000
--- a/dgbequ.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbequ_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_dgbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequ( m, kl, ku, ab)\n or\n NumRu::Lapack.dgbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MAX(1,m);
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- dgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_dgbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbequ", rb_dgbequ, -1);
-}
diff --git a/dgbequb.c b/dgbequb.c
deleted file mode 100644
index e303d39..0000000
--- a/dgbequb.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbequb_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_dgbequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequb( kl, ku, ab)\n or\n NumRu::Lapack.dgbequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from DGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", m);
- m = ldab;
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- ku = NUM2INT(rb_ku);
- ldab = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- dgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_dgbequb(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbequb", rb_dgbequb, -1);
-}
diff --git a/dgbrfs.c b/dgbrfs.c
deleted file mode 100644
index 609b562..0000000
--- a/dgbrfs.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbrfs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)\n or\n NumRu::Lapack.dgbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dgbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbrfs", rb_dgbrfs, -1);
-}
diff --git a/dgbrfsx.c b/dgbrfsx.c
deleted file mode 100644
index 18cbe37..0000000
--- a/dgbrfsx.c
+++ /dev/null
@@ -1,230 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbrfsx_(char *trans, char *equed, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, doublereal *r, doublereal *c, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgbrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.dgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.dgbrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_r = argv[7];
- rb_c = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
- rb_params = argv[11];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (8th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- ku = NUM2INT(rb_ku);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_r, rb_c, rb_x, rb_params);
-}
-
-void
-init_lapack_dgbrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbrfsx", rb_dgbrfsx, -1);
-}
diff --git a/dgbsv.c b/dgbsv.c
deleted file mode 100644
index 1994ba7..0000000
--- a/dgbsv.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbsv_(integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dgbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.dgbsv( kl, ku, ab, b)\n or\n NumRu::Lapack.dgbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGBSV computes the solution to a real system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL DGBTRF, DGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_dgbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbsv", rb_dgbsv, -1);
-}
diff --git a/dgbsvx.c b/dgbsvx.c
deleted file mode 100644
index 2e0777c..0000000
--- a/dgbsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbsvx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_afb_out__;
- doublereal *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.dgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.dgbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by DGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) DOUBLE PRECISION array, dimension (3*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = 3*n;
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, doublereal*);
- MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
-
- dgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_dgbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbsvx", rb_dgbsvx, -1);
-}
diff --git a/dgbsvxx.c b/dgbsvxx.c
deleted file mode 100644
index 45b8558..0000000
--- a/dgbsvxx.c
+++ /dev/null
@@ -1,270 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbsvxx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgbsvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_afb_out__;
- doublereal *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.dgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.dgbsvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBSVXX uses the LU factorization to compute the solution to a\n* double precision system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In DGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
- rb_params = argv[11];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, doublereal*);
- MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_dgbsvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbsvxx", rb_dgbsvxx, -1);
-}
diff --git a/dgbtf2.c b/dgbtf2.c
deleted file mode 100644
index 4c52e3e..0000000
--- a/dgbtf2.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbtf2_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_dgbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.dgbtf2( m, kl, ku, ab)\n or\n NumRu::Lapack.dgbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGBTF2 computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_dgbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbtf2", rb_dgbtf2, -1);
-}
diff --git a/dgbtrf.c b/dgbtrf.c
deleted file mode 100644
index 1056c43..0000000
--- a/dgbtrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbtrf_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_dgbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.dgbtrf( m, kl, ku, ab)\n or\n NumRu::Lapack.dgbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGBTRF computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_dgbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbtrf", rb_dgbtrf, -1);
-}
diff --git a/dgbtrs.c b/dgbtrs.c
deleted file mode 100644
index ccb670a..0000000
--- a/dgbtrs.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgbtrs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dgbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dgbtrs( trans, kl, ku, ab, ipiv, b)\n or\n NumRu::Lapack.dgbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGBTRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general band matrix A using the LU factorization computed\n* by DGBTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dgbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dgbtrs", rb_dgbtrs, -1);
-}
diff --git a/dgebak.c b/dgebak.c
deleted file mode 100644
index 1470fbc..0000000
--- a/dgebak.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, doublereal *scale, integer *m, doublereal *v, integer *ldv, integer *info);
-
-static VALUE
-rb_dgebak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- doublereal *scale;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- doublereal *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.dgebak( job, side, ilo, ihi, scale, v)\n or\n NumRu::Lapack.dgebak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* DGEBAK forms the right or left eigenvectors of a real general matrix\n* by backward transformation on the computed eigenvectors of the\n* balanced matrix output by DGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to DGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by DGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by DGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by DHSEIN or DTREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_scale = argv[4];
- rb_v = argv[5];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- if (!NA_IsNArray(rb_scale))
- rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
- if (NA_RANK(rb_scale) != 1)
- rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_scale);
- if (NA_TYPE(rb_scale) != NA_DFLOAT)
- rb_scale = na_change_type(rb_scale, NA_DFLOAT);
- scale = NA_PTR_TYPE(rb_scale, doublereal*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- job = StringValueCStr(rb_job)[0];
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- dgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_dgebak(VALUE mLapack){
- rb_define_module_function(mLapack, "dgebak", rb_dgebak, -1);
-}
diff --git a/dgebal.c b/dgebal.c
deleted file mode 100644
index 9be6544..0000000
--- a/dgebal.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgebal_(char *job, integer *n, doublereal *a, integer *lda, integer *ilo, integer *ihi, doublereal *scale, integer *info);
-
-static VALUE
-rb_dgebal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- doublereal *scale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.dgebal( job, a)\n or\n NumRu::Lapack.dgebal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* DGEBAL balances a general real matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine BALANC.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
-
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ilo, rb_ihi, rb_scale, rb_info, rb_a);
-}
-
-void
-init_lapack_dgebal(VALUE mLapack){
- rb_define_module_function(mLapack, "dgebal", rb_dgebal, -1);
-}
diff --git a/dgebd2.c b/dgebd2.c
deleted file mode 100644
index f3b9de1..0000000
--- a/dgebd2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgebd2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *d, doublereal *e, doublereal *tauq, doublereal *taup, doublereal *work, integer *info);
-
-static VALUE
-rb_dgebd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tauq;
- doublereal *tauq;
- VALUE rb_taup;
- doublereal *taup;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.dgebd2( m, a)\n or\n NumRu::Lapack.dgebd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEBD2 reduces a real general m by n matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (MAX(m,n)));
-
- dgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tauq, rb_taup, rb_info, rb_a);
-}
-
-void
-init_lapack_dgebd2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgebd2", rb_dgebd2, -1);
-}
diff --git a/dgebrd.c b/dgebrd.c
deleted file mode 100644
index e971e86..0000000
--- a/dgebrd.c
+++ /dev/null
@@ -1,102 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgebrd_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *d, doublereal *e, doublereal *tauq, doublereal *taup, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgebrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tauq;
- doublereal *tauq;
- VALUE rb_taup;
- doublereal *taup;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.dgebrd( m, a, lwork)\n or\n NumRu::Lapack.dgebrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEBRD reduces a general real M-by-N matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgebrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dgebrd", rb_dgebrd, -1);
-}
diff --git a/dgecon.c b/dgecon.c
deleted file mode 100644
index ef6e207..0000000
--- a/dgecon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgecon_(char *norm, integer *n, doublereal *a, integer *lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgecon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dgecon( norm, a, anorm)\n or\n NumRu::Lapack.dgecon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGECON estimates the reciprocal of the condition number of a general\n* real matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by DGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION array, dimension (4*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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- norm = StringValueCStr(rb_norm)[0];
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dgecon(VALUE mLapack){
- rb_define_module_function(mLapack, "dgecon", rb_dgecon, -1);
-}
diff --git a/dgeequ.c b/dgeequ.c
deleted file mode 100644
index d8318ed..0000000
--- a/dgeequ.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeequ_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_dgeequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequ( a)\n or\n NumRu::Lapack.dgeequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- dgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_dgeequ(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeequ", rb_dgeequ, -1);
-}
diff --git a/dgeequb.c b/dgeequb.c
deleted file mode 100644
index 113b753..0000000
--- a/dgeequb.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeequb_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_dgeequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequb( a)\n or\n NumRu::Lapack.dgeequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from DGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lda = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- dgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_dgeequb(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeequb", rb_dgeequb, -1);
-}
diff --git a/dgees.c b/dgees.c
deleted file mode 100644
index b60bc7d..0000000
--- a/dgees.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(doublereal *arg0, doublereal *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID dgees_(char *jobvs, char *sort, L_fp *select, integer *n, doublereal *a, integer *lda, integer *sdim, doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, integer *lwork, logical *bwork, integer *info);
-
-static VALUE
-rb_dgees(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_vs;
- doublereal *vs;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, wr, wi, vs, work, info, a = NumRu::Lapack.dgees( jobvs, sort, a, lwork){|a,b| ... }\n or\n NumRu::Lapack.dgees # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEES computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n*\n* A matrix is in real Schur form if it is upper quasi-triangular with\n* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n* form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n* conjugate pair of eigenvalues is selected, then both complex\n* eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO is set to N+2 (see INFO below).\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues in the same order\n* that they appear on the diagonal of the output Schur form T.\n* Complex conjugate pairs of eigenvalues will appear\n* consecutively with the eigenvalue having the positive\n* imaginary part first.\n*\n* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,3*N).\n* For good performance, LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the matrix which reduces A\n* to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- lwork = NUM2INT(rb_lwork);
- sort = StringValueCStr(rb_sort)[0];
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- dgees_(&jobvs, &sort, rb_select, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, work, &lwork, bwork, &info);
-
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_sdim, rb_wr, rb_wi, rb_vs, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgees(VALUE mLapack){
- rb_define_module_function(mLapack, "dgees", rb_dgees, -1);
-}
diff --git a/dgeesx.c b/dgeesx.c
deleted file mode 100644
index 0879574..0000000
--- a/dgeesx.c
+++ /dev/null
@@ -1,145 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(doublereal *arg0, doublereal *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID dgeesx_(char *jobvs, char *sort, L_fp *select, char *sense, integer *n, doublereal *a, integer *lda, integer *sdim, doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, doublereal *rconde, doublereal *rcondv, doublereal *work, integer *lwork, integer *iwork, integer *liwork, logical *bwork, integer *info);
-
-static VALUE
-rb_dgeesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_vs;
- doublereal *vs;
- VALUE rb_rconde;
- doublereal rconde;
- VALUE rb_rcondv;
- doublereal rcondv;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.dgeesx( jobvs, sort, sense, a, lwork, liwork){|a,b| ... }\n or\n NumRu::Lapack.dgeesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEESX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A real matrix is in real Schur form if it is upper quasi-triangular\n* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n* the form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n* complex conjugate pair of eigenvalues is selected, then both\n* are. Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO may be set to N+3 (see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the N-by-N matrix A.\n* On exit, A is overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts, respectively,\n* of the computed eigenvalues, in the same order that they\n* appear on the diagonal of the output Schur form T. Complex\n* conjugate pairs of eigenvalues appear consecutively with the\n* eigenvalue having the positive imaginary part first.\n*\n* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) DOUBLE PRECISION\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,3*N).\n* Also, if SENSE = 'E' or 'V' or 'B',\n* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n* selected eigenvalues computed by this routine. Note that\n* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n* 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bounds on the optimal sizes of the\n* arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n* may not be large enough.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates upper bounds on the optimal sizes of\n* the arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_sense = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
- rb_liwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- liwork = NUM2INT(rb_liwork);
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- dgeesx_(&jobvs, &sort, rb_select, &sense, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, &rconde, &rcondv, work, &lwork, iwork, &liwork, bwork, &info);
-
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_rconde = rb_float_new((double)rconde);
- rb_rcondv = rb_float_new((double)rcondv);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_sdim, rb_wr, rb_wi, rb_vs, rb_rconde, rb_rcondv, rb_work, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeesx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeesx", rb_dgeesx, -1);
-}
diff --git a/dgeev.c b/dgeev.c
deleted file mode 100644
index f629670..0000000
--- a/dgeev.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgeev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, vl, vr, work, info, a = NumRu::Lapack.dgeev( jobvl, jobvr, a, lwork)\n or\n NumRu::Lapack.dgeev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEEV computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,3*N), and\n* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good\n* performance, LWORK must generally be larger.\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* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements i+1:N of WR and WI contain eigenvalues which\n* have converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_wr, rb_wi, rb_vl, rb_vr, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeev(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeev", rb_dgeev, -1);
-}
diff --git a/dgeevx.c b/dgeevx.c
deleted file mode 100644
index 7e9315d..0000000
--- a/dgeevx.c
+++ /dev/null
@@ -1,156 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, doublereal *a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dgeevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- doublereal *scale;
- VALUE rb_abnrm;
- doublereal abnrm;
- VALUE rb_rconde;
- doublereal *rconde;
- VALUE rb_rcondv;
- doublereal *rcondv;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.dgeevx( balanc, jobvl, jobvr, sense, a, lwork)\n or\n NumRu::Lapack.dgeevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, i.e. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the real Schur form of the balanced\n* version of the input matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues will appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and\n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n* For good performance, LWORK must generally be larger.\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 (2*N-2)\n* If SENSE = 'N' or 'E', not referenced.\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, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of WR\n* and WI contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- sense = StringValueCStr(rb_sense)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- iwork = ALLOC_N(integer, ((lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2));
-
- dgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(13, rb_wr, rb_wi, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_scale, rb_abnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeevx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeevx", rb_dgeevx, -1);
-}
diff --git a/dgegs.c b/dgegs.c
deleted file mode 100644
index e1a0953..0000000
--- a/dgegs.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgegs_(char *jobvsl, char *jobvsr, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgegs(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_vsl;
- doublereal *vsl;
- VALUE rb_vsr;
- doublereal *vsr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgegs( jobvsl, jobvsr, a, b, lwork)\n or\n NumRu::Lapack.dgegs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGGES.\n*\n* DGEGS computes the eigenvalues, real Schur form, and, optionally,\n* left and or/right Schur vectors of a real matrix pair (A,B).\n* Given two square matrices A and B, the generalized real Schur\n* factorization has the form\n*\n* A = Q*S*Z**T, B = Q*T*Z**T\n*\n* where Q and Z are orthogonal matrices, T is upper triangular, and S\n* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n* of eigenvalues of (A,B). The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n*\n* If only the eigenvalues of (A,B) are needed, the driver routine\n* DGEGV should be used instead. See DGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper quasi-triangular matrix S from the\n* generalized real Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* real Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and (j+1)-st\n* eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,4*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:\n* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR\n* The optimal LWORK is 2*N + N*(NB+1).\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* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from DGGBAL\n* =N+2: error return from DGEQRF\n* =N+3: error return from DORMQR\n* =N+4: error return from DORGQR\n* =N+5: error return from DGGHRD\n* =N+6: error return from DHGEQZ (other than failed\n* iteration)\n* =N+7: error return from DGGBAK (computing VSL)\n* =N+8: error return from DGGBAK (computing VSR)\n* =N+9: error return from DLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dgegs(VALUE mLapack){
- rb_define_module_function(mLapack, "dgegs", rb_dgegs, -1);
-}
diff --git a/dgegv.c b/dgegv.c
deleted file mode 100644
index 66aa64e..0000000
--- a/dgegv.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgegv_(char *jobvl, char *jobvr, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgegv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dgegv( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.dgegv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGGEV.\n*\n* DGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a real matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n*\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n*\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n*\n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n*\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n*\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the real Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* blocks from the Schur form will be correct. See DGGHRD and\n* DHGEQZ for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only those elements of\n* B corresponding to the diagonal blocks from the Schur form of\n* A will be correct. See DGGHRD and DHGEQZ for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue of\n* GNEP.\n*\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* u(j) = VL(:,j) + i*VL(:,j+1)\n* and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then x(j) = VR(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* x(j) = VR(:,j) + i*VR(:,j+1)\n* and\n* x(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvalues\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:\n* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;\n* The optimal LWORK is:\n* 2*N + MAX( 6*N, N*(NB+1) ).\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from DGGBAL\n* =N+2: error return from DGEQRF\n* =N+3: error return from DORMQR\n* =N+4: error return from DORGQR\n* =N+5: error return from DGGHRD\n* =N+6: error return from DHGEQZ (other than failed\n* iteration)\n* =N+7: error return from DTGEVC\n* =N+8: error return from DGGBAK (computing VL)\n* =N+9: error return from DGGBAK (computing VR)\n* =N+10: error return from DLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls DGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, DGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the real Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] See DHGEQZ, DGEGS, or read the book \"Matrix Computations\",\n* by Golub & van Loan, pub. by Johns Hopkins U. Press.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_vl, rb_vr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dgegv(VALUE mLapack){
- rb_define_module_function(mLapack, "dgegv", rb_dgegv, -1);
-}
diff --git a/dgehd2.c b/dgehd2.c
deleted file mode 100644
index 025e0e3..0000000
--- a/dgehd2.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgehd2_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dgehd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgehd2( ilo, ihi, a)\n or\n NumRu::Lapack.dgehd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to DGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n));
-
- dgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dgehd2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgehd2", rb_dgehd2, -1);
-}
diff --git a/dgehrd.c b/dgehrd.c
deleted file mode 100644
index d00a729..0000000
--- a/dgehrd.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgehrd_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgehrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgehrd( ilo, ihi, a, lwork)\n or\n NumRu::Lapack.dgehrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEHRD reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to DGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ilo = NUM2INT(rb_ilo);
- lwork = NUM2INT(rb_lwork);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgehrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dgehrd", rb_dgehrd, -1);
-}
diff --git a/dgejsv.c b/dgejsv.c
deleted file mode 100644
index 24c89b1..0000000
--- a/dgejsv.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgejsv_(char *joba, char *jobu, char *jobv, char *jobr, char *jobt, char *jobp, integer *m, integer *n, doublereal *a, integer *lda, doublereal *sva, doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dgejsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_joba;
- char joba;
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobr;
- char jobr;
- VALUE rb_jobt;
- char jobt;
- VALUE rb_jobp;
- char jobp;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_sva;
- doublereal *sva;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_work_out__;
- doublereal *work_out__;
-
- integer lda;
- integer n;
- integer lwork;
- integer ldu;
- integer ldv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sva, u, v, iwork, info, work = NumRu::Lapack.dgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work)\n or\n NumRu::Lapack.dgejsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEJSV computes the singular value decomposition (SVD) of a real M-by-N\n* matrix [A], where M >= N. The SVD of [A] is written as\n*\n* [A] = [U] * [SIGMA] * [V]^t,\n*\n* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N\n* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and\n* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are\n* the singular values of [A]. The columns of [U] and [V] are the left and\n* the right singular vectors of [A], respectively. The matrices [U] and [V]\n* are computed and stored in the arrays U and V, respectively. The diagonal\n* of [SIGMA] is computed and stored in the array SVA.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER*1\n* Specifies the level of accuracy:\n* = 'C': This option works well (high relative accuracy) if A = B * D,\n* with well-conditioned B and arbitrary diagonal matrix D.\n* The accuracy cannot be spoiled by COLUMN scaling. The\n* accuracy of the computed output depends on the condition of\n* B, and the procedure aims at the best theoretical accuracy.\n* The relative error max_{i=1:N}|d sigma_i| / sigma_i is\n* bounded by f(M,N)*epsilon* cond(B), independent of D.\n* The input matrix is preprocessed with the QRF with column\n* pivoting. This initial preprocessing and preconditioning by\n* a rank revealing QR factorization is common for all values of\n* JOBA. Additional actions are specified as follows:\n* = 'E': Computation as with 'C' with an additional estimate of the\n* condition number of B. It provides a realistic error bound.\n* = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings\n* D1, D2, and well-conditioned matrix C, this option gives\n* higher accuracy than the 'C' option. If the structure of the\n* input matrix is not known, and relative accuracy is\n* desirable, then this option is advisable. The input matrix A\n* is preprocessed with QR factorization with FULL (row and\n* column) pivoting.\n* = 'G' Computation as with 'F' with an additional estimate of the\n* condition number of B, where A=D*B. If A has heavily weighted\n* rows, then using this condition number gives too pessimistic\n* error bound.\n* = 'A': Small singular values are the noise and the matrix is treated\n* as numerically rank defficient. The error in the computed\n* singular values is bounded by f(m,n)*epsilon*||A||.\n* The computed SVD A = U * S * V^t restores A up to\n* f(m,n)*epsilon*||A||.\n* This gives the procedure the licence to discard (set to zero)\n* all singular values below N*epsilon*||A||.\n* = 'R': Similar as in 'A'. Rank revealing property of the initial\n* QR factorization is used do reveal (using triangular factor)\n* a gap sigma_{r+1} < epsilon * sigma_r in which case the\n* numerical RANK is declared to be r. The SVD is computed with\n* absolute error bounds, but more accurately than with 'A'.\n*\n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the columns of U:\n* = 'U': N columns of U are returned in the array U.\n* = 'F': full set of M left sing. vectors is returned in the array U.\n* = 'W': U may be used as workspace of length M*N. See the description\n* of U.\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the matrix V:\n* = 'V': N columns of V are returned in the array V; Jacobi rotations\n* are not explicitly accumulated.\n* = 'J': N columns of V are returned in the array V, but they are\n* computed as the product of Jacobi rotations. This option is\n* allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.\n* = 'W': V may be used as workspace of length N*N. See the description\n* of V.\n* = 'N': V is not computed.\n*\n* JOBR (input) CHARACTER*1\n* Specifies the RANGE for the singular values. Issues the licence to\n* set to zero small positive singular values if they are outside\n* specified range. If A .NE. 0 is scaled so that the largest singular\n* value of c*A is around DSQRT(BIG), BIG=SLAMCH('O'), then JOBR issues\n* the licence to kill columns of A whose norm in c*A is less than\n* DSQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN,\n* where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').\n* = 'N': Do not kill small columns of c*A. This option assumes that\n* BLAS and QR factorizations and triangular solvers are\n* implemented to work in that range. If the condition of A\n* is greater than BIG, use DGESVJ.\n* = 'R': RESTRICTED range for sigma(c*A) is [DSQRT(SFMIN), DSQRT(BIG)]\n* (roughly, as described above). This option is recommended.\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* For computing the singular values in the FULL range [SFMIN,BIG]\n* use DGESVJ.\n*\n* JOBT (input) CHARACTER*1\n* If the matrix is square then the procedure may determine to use\n* transposed A if A^t seems to be better with respect to convergence.\n* If the matrix is not square, JOBT is ignored. This is subject to\n* changes in the future.\n* The decision is based on two values of entropy over the adjoint\n* orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).\n* = 'T': transpose if entropy test indicates possibly faster\n* convergence of Jacobi process if A^t is taken as input. If A is\n* replaced with A^t, then the row pivoting is included automatically.\n* = 'N': do not speculate.\n* This option can be used to compute only the singular values, or the\n* full SVD (U, SIGMA and V). For only one set of singular vectors\n* (U or V), the caller should provide both U and V, as one of the\n* matrices is used as workspace if the matrix A is transposed.\n* The implementer can easily remove this constraint and make the\n* code more complicated. See the descriptions of U and V.\n*\n* JOBP (input) CHARACTER*1\n* Issues the licence to introduce structured perturbations to drown\n* denormalized numbers. This licence should be active if the\n* denormals are poorly implemented, causing slow computation,\n* especially in cases of fast convergence (!). For details see [1,2].\n* For the sake of simplicity, this perturbations are included only\n* when the full SVD or only the singular values are requested. The\n* implementer/user can easily add the perturbation for the cases of\n* computing one set of singular vectors.\n* = 'P': introduce perturbation\n* = 'N': do not perturb\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. M >= N >= 0.\n*\n* A (input/workspace) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) DOUBLE PRECISION array, dimension (N)\n* On exit,\n* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the\n* computation SVA contains Euclidean column norms of the\n* iterated matrices in the array A.\n* - For WORK(1) .NE. WORK(2): The singular values of A are\n* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if\n* sigma_max(A) overflows or if small singular values have been\n* saved from underflow by scaling the input matrix A.\n* - If JOBR='R' then some of the singular values may be returned\n* as exact zeros obtained by \"set to zero\" because they are\n* below the numerical rank threshold or are denormalized numbers.\n*\n* U (workspace/output) DOUBLE PRECISION array, dimension ( LDU, N )\n* If JOBU = 'U', then U contains on exit the M-by-N matrix of\n* the left singular vectors.\n* If JOBU = 'F', then U contains on exit the M-by-M matrix of\n* the left singular vectors, including an ONB\n* of the orthogonal complement of the Range(A).\n* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N),\n* then U is used as workspace if the procedure\n* replaces A with A^t. In that case, [V] is computed\n* in U as left singular vectors of A^t and then\n* copied back to the V array. This 'W' option is just\n* a reminder to the caller that in this case U is\n* reserved as workspace of length N*N.\n* If JOBU = 'N' U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U, LDU >= 1.\n* IF JOBU = 'U' or 'F' or 'W', then LDU >= M.\n*\n* V (workspace/output) DOUBLE PRECISION array, dimension ( LDV, N )\n* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N),\n* then V is used as workspace if the pprocedure\n* replaces A with A^t. In that case, [U] is computed\n* in V as right singular vectors of A^t and then\n* copied back to the U array. This 'W' option is just\n* a reminder to the caller that in this case V is\n* reserved as workspace of length N*N.\n* If JOBV = 'N' V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV >= 1.\n* If JOBV = 'V' or 'J' or 'W', then LDV >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension at least LWORK.\n* On exit,\n* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such\n* that SCALE*SVA(1:N) are the computed singular values\n* of A. (See the description of SVA().)\n* WORK(2) = See the description of WORK(1).\n* WORK(3) = SCONDA is an estimate for the condition number of\n* column equilibrated A. (If JOBA .EQ. 'E' or 'G')\n* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).\n* It is computed using DPOCON. It holds\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n* where R is the triangular factor from the QRF of A.\n* However, if R is truncated and the numerical rank is\n* determined to be strictly smaller than N, SCONDA is\n* returned as -1, thus indicating that the smallest\n* singular values might be lost.\n*\n* If full SVD is needed, the following two condition numbers are\n* useful for the analysis of the algorithm. They are provied for\n* a developer/implementer who is familiar with the details of\n* the method.\n*\n* WORK(4) = an estimate of the scaled condition number of the\n* triangular factor in the first QR factorization.\n* WORK(5) = an estimate of the scaled condition number of the\n* triangular factor in the second QR factorization.\n* The following two parameters are computed if JOBT .EQ. 'T'.\n* They are provided for a developer/implementer who is familiar\n* with the details of the method.\n*\n* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy\n* of diag(A^t*A) / Trace(A^t*A) taken as point in the\n* probability simplex.\n* WORK(7) = the entropy of A*A^t.\n*\n* LWORK (input) INTEGER\n* Length of WORK to confirm proper allocation of work space.\n* LWORK depends on the job:\n*\n* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and\n* -> .. no scaled condition estimate required ( JOBE.EQ.'N'):\n* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.\n* For optimal performance (blocked code) the optimal value\n* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal\n* block size for xGEQP3/xGEQRF.\n* -> .. an estimate of the scaled condition number of A is\n* required (JOBA='E', 'G'). In this case, LWORK is the maximum\n* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7).\n*\n* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'),\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If SIGMA and the left singular vectors are needed\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and\n* -> .. the singular vectors are computed without explicit\n* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N\n* -> .. in the iterative part, the Jacobi rotations are\n* explicitly accumulated (option, see the description of JOBV),\n* then the minimal requirement is LWORK >= max(M+3*N+N*N,7).\n* For better performance, if NB is the optimal block size,\n* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7).\n*\n* IWORK (workspace/output) INTEGER array, dimension M+3*N.\n* On exit,\n* IWORK(1) = the numerical rank determined after the initial\n* QR factorization with pivoting. See the descriptions\n* of JOBA and JOBR.\n* IWORK(2) = the number of the computed nonzero singular values\n* IWORK(3) = if nonzero, a warning message:\n* If IWORK(3).EQ.1 then some of the column norms of A\n* were denormalized floats. The requested high accuracy\n* is not warranted by the data.\n*\n* INFO (output) INTEGER\n* < 0 : if INFO = -i, then the i-th argument had an illegal value.\n* = 0 : successfull exit;\n* > 0 : DGEJSV did not converge in the maximal allowed number\n* of sweeps. The computed values may be inaccurate.\n*\n\n* Further Details\n* ===============\n*\n* DGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,\n* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an\n* additional row pivoting can be used as a preprocessor, which in some\n* cases results in much higher accuracy. An example is matrix A with the\n* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned\n* diagonal matrices and C is well-conditioned matrix. In that case, complete\n* pivoting in the first QR factorizations provides accuracy dependent on the\n* condition number of C, and independent of D1, D2. Such higher accuracy is\n* not completely understood theoretically, but it works well in practice.\n* Further, if A can be written as A = B*D, with well-conditioned B and some\n* diagonal D, then the high accuracy is guaranteed, both theoretically and\n* in software, independent of D. For more details see [1], [2].\n* The computational range for the singular values can be the full range\n* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS\n* & LAPACK routines called by DGEJSV are implemented to work in that range.\n* If that is not the case, then the restriction for safe computation with\n* the singular values in the range of normalized IEEE numbers is that the\n* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not\n* overflow. This code (DGEJSV) is best used in this restricted range,\n* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are\n* returned as zeros. See JOBR for details on this.\n* Further, this implementation is somewhat slower than the one described\n* in [1,2] due to replacement of some non-LAPACK components, and because\n* the choice of some tuning parameters in the iterative part (DGESVJ) is\n* left to the implementer on a particular machine.\n* The rank revealing QR factorization (in this code: SGEQP3) should be\n* implemented as in [3]. We have a new version of SGEQP3 under development\n* that is more robust than the current one in LAPACK, with a cleaner cut in\n* rank defficient cases. It will be available in the SIGMA library [4].\n* If M is much larger than N, it is obvious that the inital QRF with\n* column pivoting can be preprocessed by the QRF without pivoting. That\n* well known trick is not used in DGEJSV because in some cases heavy row\n* weighting can be treated with complete pivoting. The overhead in cases\n* M much larger than N is then only due to pivoting, but the benefits in\n* terms of accuracy have prevailed. The implementer/user can incorporate\n* this extra QRF step easily. The implementer can also improve data movement\n* (matrix transpose, matrix copy, matrix transposed copy) - this\n* implementation of DGEJSV uses only the simplest, naive data movement.\n*\n* Contributors\n*\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n*\n* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR\n* factorization software - a case study.\n* ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28.\n* LAPACK Working note 176.\n* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, examples and comments\n* \n* Please report all bugs and send interesting examples and/or comments to\n* drmac at math.hr. Thank you.\n*\n* ==========================================================================\n*\n* .. Local Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK,\n & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM,\n & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC\n INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING\n LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC,\n & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN,\n & NOSCAL, ROWPIV, RSVEC, TRANSP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DLOG, DMAX1, DMIN1, DBLE,\n & MAX0, MIN0, IDNINT, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DLAMCH, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DLAMCH, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DGELQF, DGEQP3, DGEQRF, DLACPY, DLASCL,\n & DLASET, DLASSQ, DLASWP, DORGQR, DORMLQ,\n & DORMQR, DPOCON, DSCAL, DSWAP, DTRSM, XERBLA\n*\n EXTERNAL DGESVJ\n* ..\n*\n* Test the input arguments\n*\n LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' )\n JRACC = LSAME( JOBV, 'J' )\n RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC\n ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' )\n L2RANK = LSAME( JOBA, 'R' )\n L2ABER = LSAME( JOBA, 'A' )\n ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' )\n L2TRAN = LSAME( JOBT, 'T' )\n L2KILL = LSAME( JOBR, 'R' )\n DEFR = LSAME( JOBR, 'N' )\n L2PERT = LSAME( JOBP, 'P' )\n*\n IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR.\n & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN\n INFO = - 1\n ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR.\n & LSAME( JOBU, 'W' )) ) THEN\n INFO = - 2\n ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR.\n & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN\n INFO = - 3\n ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN\n INFO = - 4\n ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN\n INFO = - 5\n ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN\n INFO = - 6\n ELSE IF ( M .LT. 0 ) THEN\n INFO = - 7\n ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN\n INFO = - 8\n ELSE IF ( LDA .LT. M ) THEN\n INFO = - 10\n ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN\n INFO = - 13\n ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN\n INFO = - 14\n ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND.\n & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR.\n & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND.\n & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR.\n & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N))\n & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N)))\n & THEN\n INFO = - 17\n ELSE\n* #:)\n INFO = 0\n END IF\n*\n IF ( INFO .NE. 0 ) THEN\n* #:(\n CALL XERBLA( 'DGEJSV', - INFO )\n END IF\n*\n* Quick return for void matrix (Y3K safe)\n* #:)\n IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN\n*\n* Determine whether the matrix U should be M x N or M x M\n*\n IF ( LSVEC ) THEN\n N1 = N\n IF ( LSAME( JOBU, 'F' ) ) N1 = M\n END IF\n*\n* Set numerical parameters\n*\n*! NOTE: Make sure DLAMCH() does not fail on the target architecture.\n*\n\n EPSLN = DLAMCH('Epsilon')\n SFMIN = DLAMCH('SafeMinimum')\n SMALL = SFMIN / EPSLN\n BIG = DLAMCH('O')\n* BIG = ONE / SFMIN\n*\n* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N\n*\n*(!) If necessary, scale SVA() to protect the largest norm from\n* overflow. It is possible that this scaling pushes the smallest\n* column norm left from the underflow threshold (extreme case).\n*\n SCALEM = ONE / DSQRT(DBLE(M)*DBLE(N))\n NOSCAL = .TRUE.\n GOSCAL = .TRUE.\n DO 1874 p = 1, N\n AAPP = ZERO\n AAQQ = ONE\n CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ )\n IF ( AAPP .GT. BIG ) THEN\n INFO = - 9\n CALL XERBLA( 'DGEJSV', -INFO )\n RETURN\n END IF\n AAQQ = DSQRT(AAQQ)\n IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN\n SVA(p) = AAPP * AAQQ\n ELSE\n NOSCAL = .FALSE.\n SVA(p) = AAPP * ( AAQQ * SCALEM )\n IF ( GOSCAL ) THEN\n GOSCAL = .FALSE.\n CALL DSCAL( p-1, SCALEM, SVA, 1 )\n END IF\n END IF\n 1874 CONTINUE\n*\n IF ( NOSCAL ) SCALEM = ONE\n*\n AAPP = ZERO\n AAQQ = BIG\n DO 4781 p = 1, N\n AAPP = DMAX1( AAPP, SVA(p) )\n IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) )\n 4781 CONTINUE\n*\n* Quick return for zero M x N matrix\n* #:)\n IF ( AAPP .EQ. ZERO ) THEN\n IF ( LSVEC ) CALL DLASET( 'G', M, N1, ZERO, ONE, U, LDU )\n IF ( RSVEC ) CALL DLASET( 'G', N, N, ZERO, ONE, V, LDV )\n WORK(1) = ONE\n WORK(2) = ONE\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n IWORK(1) = 0\n IWORK(2) = 0\n RETURN\n END IF\n*\n* Issue warning if denormalized column norms detected. Override the\n* high relative accuracy request. Issue licence to kill columns\n* (set them to zero) whose norm is less than sigma_max / BIG (roughly).\n* #:(\n WARNING = 0\n IF ( AAQQ .LE. SFMIN ) THEN\n L2RANK = .TRUE.\n L2KILL = .TRUE.\n WARNING = 1\n END IF\n*\n* Quick return for one-column matrix\n* #:)\n IF ( N .EQ. 1 ) THEN\n*\n IF ( LSVEC ) THEN\n CALL DLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )\n CALL DLACPY( 'A', M, 1, A, LDA, U, LDU )\n* computing all M left singular vectors of the M x 1 matrix\n IF ( N1 .NE. N ) THEN\n CALL DGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )\n CALL DORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )\n CALL DCOPY( M, A(1,1), 1, U(1,1), 1 )\n END IF\n END IF\n IF ( RSVEC ) THEN\n V(1,1) = ONE\n END IF\n IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN\n SVA(1) = SVA(1) / SCALEM\n SCALEM = ONE\n END IF\n WORK(1) = ONE / SCALEM\n WORK(2) = ONE\n IF ( SVA(1) .NE. ZERO ) THEN\n IWORK(1) = 1\n IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN\n IWORK(2) = 1\n ELSE\n IWORK(2) = 0\n END IF\n ELSE\n IWORK(1) = 0\n IWORK(2) = 0\n END IF\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n RETURN\n*\n END IF\n*\n TRANSP = .FALSE.\n L2TRAN = L2TRAN .AND. ( M .EQ. N )\n*\n AATMAX = -ONE\n AATMIN = BIG\n IF ( ROWPIV .OR. L2TRAN ) THEN\n*\n* Compute the row norms, needed to determine row pivoting sequence\n* (in the case of heavily row weighted A, row pivoting is strongly\n* advised) and to collect information needed to compare the\n* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).\n*\n IF ( L2TRAN ) THEN\n DO 1950 p = 1, M\n XSC = ZERO\n TEMP1 = ONE\n CALL DLASSQ( N, A(p,1), LDA, XSC, TEMP1 )\n* DLASSQ gets both the ell_2 and the ell_infinity norm\n* in one pass through the vector\n WORK(M+N+p) = XSC * SCALEM\n WORK(N+p) = XSC * (SCALEM*DSQRT(TEMP1))\n AATMAX = DMAX1( AATMAX, WORK(N+p) )\n IF (WORK(N+p) .NE. ZERO) AATMIN = DMIN1(AATMIN,WORK(N+p))\n 1950 CONTINUE\n ELSE\n DO 1904 p = 1, M\n WORK(M+N+p) = SCALEM*DABS( A(p,IDAMAX(N,A(p,1),LDA)) )\n AATMAX = DMAX1( AATMAX, WORK(M+N+p) )\n AATMIN = DMIN1( AATMIN, WORK(M+N+p) )\n 1904 CONTINUE\n END IF\n*\n END IF\n*\n* For square matrix A try to determine whether A^t would be better\n* input for the preconditioned Jacobi SVD, with faster convergence.\n* The decision is based on an O(N) function of the vector of column\n* and row norms of A, based on the Shannon entropy. This should give\n* the right choice in most cases when the difference actually matters.\n* It may fail and pick the slower converging side.\n*\n ENTRA = ZERO\n ENTRAT = ZERO\n IF ( L2TRAN ) THEN\n*\n XSC = ZERO\n TEMP1 = ONE\n CALL DLASSQ( N, SVA, 1, XSC, TEMP1 )\n TEMP1 = ONE / TEMP1\n*\n ENTRA = ZERO\n DO 1113 p = 1, N\n BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1)\n 1113 CONTINUE\n ENTRA = - ENTRA / DLOG(DBLE(N))\n*\n* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.\n* It is derived from the diagonal of A^t * A. Do the same with the\n* diagonal of A * A^t, compute the entropy of the corresponding\n* probability distribution. Note that A * A^t and A^t * A have the\n* same trace.\n*\n ENTRAT = ZERO\n DO 1114 p = N+1, N+M\n BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1)\n 1114 CONTINUE\n ENTRAT = - ENTRAT / DLOG(DBLE(M))\n*\n* Analyze the entropies and decide A or A^t. Smaller entropy\n* usually means better input for the algorithm.\n*\n TRANSP = ( ENTRAT .LT. ENTRA )\n*\n* If A^t is better than A, transpose A.\n*\n IF ( TRANSP ) THEN\n* In an optimal implementation, this trivial transpose\n* should be replaced with faster transpose.\n DO 1115 p = 1, N - 1\n DO 1116 q = p + 1, N\n TEMP1 = A(q,p)\n A(q,p) = A(p,q)\n A(p,q) = TEMP1\n 1116 CONTINUE\n 1115 CONTINUE\n DO 1117 p = 1, N\n WORK(M+N+p) = SVA(p)\n SVA(p) = WORK(N+p)\n 1117 CONTINUE\n TEMP1 = AAPP\n AAPP = AATMAX\n AATMAX = TEMP1\n TEMP1 = AAQQ\n AAQQ = AATMIN\n AATMIN = TEMP1\n KILL = LSVEC\n LSVEC = RSVEC\n RSVEC = KILL\n IF ( LSVEC ) N1 = N\n*\n ROWPIV = .TRUE.\n END IF\n*\n END IF\n* END IF L2TRAN\n*\n* Scale the matrix so that its maximal singular value remains less\n* than DSQRT(BIG) -- the matrix is scaled so that its maximal column\n* has Euclidean norm equal to DSQRT(BIG/N). The only reason to keep\n* DSQRT(BIG) instead of BIG is the fact that DGEJSV uses LAPACK and\n* BLAS routines that, in some implementations, are not capable of\n* working in the full interval [SFMIN,BIG] and that they may provoke\n* overflows in the intermediate results. If the singular values spread\n* from SFMIN to BIG, then DGESVJ will compute them. So, in that case,\n* one should use DGESVJ instead of DGEJSV.\n*\n BIG1 = DSQRT( BIG )\n TEMP1 = DSQRT( BIG / DBLE(N) )\n*\n CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR )\n IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN\n AAQQ = ( AAQQ / AAPP ) * TEMP1\n ELSE\n AAQQ = ( AAQQ * TEMP1 ) / AAPP\n END IF\n TEMP1 = TEMP1 * SCALEM\n CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR )\n*\n* To undo scaling at the end of this procedure, multiply the\n* computed singular values with USCAL2 / USCAL1.\n*\n USCAL1 = TEMP1\n USCAL2 = AAPP\n*\n IF ( L2KILL ) THEN\n* L2KILL enforces computation of nonzero singular values in\n* the restricted range of condition number of the initial A,\n* sigma_max(A) / sigma_min(A) approx. DSQRT(BIG)/DSQRT(SFMIN).\n XSC = DSQRT( SFMIN )\n ELSE\n XSC = SMALL\n*\n* Now, if the condition number of A is too big,\n* sigma_max(A) / sigma_min(A) .GT. DSQRT(BIG/N) * EPSLN / SFMIN,\n* as a precaution measure, the full SVD is computed using DGESVJ\n* with accumulated Jacobi rotations. This provides numerically\n* more robust computation, at the cost of slightly increased run\n* time. Depending on the concrete implementation of BLAS and LAPACK\n* (i.e. how they behave in presence of extreme ill-conditioning) the\n* implementor may decide to remove this switch.\n IF ( ( AAQQ.LT.DSQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN\n JRACC = .TRUE.\n END IF\n*\n END IF\n IF ( AAQQ .LT. XSC ) THEN\n DO 700 p = 1, N\n IF ( SVA(p) .LT. XSC ) THEN\n CALL DLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA )\n SVA(p) = ZERO\n END IF\n 700 CONTINUE\n END IF\n*\n* Preconditioning using QR factorization with pivoting\n*\n IF ( ROWPIV ) THEN\n* Optional row permutation (Bjoerck row pivoting):\n* A result by Cox and Higham shows that the Bjoerck's\n* row pivoting combined with standard column pivoting\n* has similar effect as Powell-Reid complete pivoting.\n* The ell-infinity norms of A are made nonincreasing.\n DO 1952 p = 1, M - 1\n q = IDAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1\n IWORK(2*N+p) = q\n IF ( p .NE. q ) THEN\n TEMP1 = WORK(M+N+p)\n WORK(M+N+p) = WORK(M+N+q)\n WORK(M+N+q) = TEMP1\n END IF\n 1952 CONTINUE\n CALL DLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 )\n END IF\n*\n* End of the preparation phase (scaling, optional sorting and\n* transposing, optional flushing of small columns).\n*\n* Preconditioning\n*\n* If the full SVD is needed, the right singular vectors are computed\n* from a matrix equation, and for that we need theoretical analysis\n* of the Businger-Golub pivoting. So we use DGEQP3 as the first RR QRF.\n* In all other cases the first RR QRF can be chosen by other criteria\n* (eg speed by replacing global with restricted window pivoting, such\n* as in SGEQPX from TOMS # 782). Good results will be obtained using\n* SGEQPX with properly (!) chosen numerical parameters.\n* Any improvement of DGEQP3 improves overal performance of DGEJSV.\n*\n* A * P1 = Q1 * [ R1^t 0]^t:\n DO 1963 p = 1, N\n* .. all columns are free columns\n IWORK(p) = 0\n 1963 CONTINUE\n CALL DGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR )\n*\n* The upper triangular matrix R1 from the first QRF is inspected for\n* rank deficiency and possibilities for deflation, or possible\n* ill-conditioning. Depending on the user specified flag L2RANK,\n* the procedure explores possibilities to reduce the numerical\n* rank by inspecting the computed upper triangular factor. If\n* L2RANK or L2ABER are up, then DGEJSV will compute the SVD of\n* A + dA, where ||dA|| <= f(M,N)*EPSLN.\n*\n NR = 1\n IF ( L2ABER ) THEN\n* Standard absolute error bound suffices. All sigma_i with\n* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an\n* agressive enforcement of lower numerical rank by introducing a\n* backward error of the order of N*EPSLN*||A||.\n TEMP1 = DSQRT(DBLE(N))*EPSLN\n DO 3001 p = 2, N\n IF ( DABS(A(p,p)) .GE. (TEMP1*DABS(A(1,1))) ) THEN\n NR = NR + 1\n ELSE\n GO TO 3002\n END IF\n 3001 CONTINUE\n 3002 CONTINUE\n ELSE IF ( L2RANK ) THEN\n* .. similarly as above, only slightly more gentle (less agressive).\n* Sudden drop on the diagonal of R1 is used as the criterion for\n* close-to-rank-defficient.\n TEMP1 = DSQRT(SFMIN)\n DO 3401 p = 2, N\n IF ( ( DABS(A(p,p)) .LT. (EPSLN*DABS(A(p-1,p-1))) ) .OR.\n & ( DABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402\n NR = NR + 1\n 3401 CONTINUE\n 3402 CONTINUE\n*\n ELSE\n* The goal is high relative accuracy. However, if the matrix\n* has high scaled condition number the relative accuracy is in\n* general not feasible. Later on, a condition number estimator\n* will be deployed to estimate the scaled condition number.\n* Here we just remove the underflowed part of the triangular\n* factor. This prevents the situation in which the code is\n* working hard to get the accuracy not warranted by the data.\n TEMP1 = DSQRT(SFMIN)\n DO 3301 p = 2, N\n IF ( ( DABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302\n NR = NR + 1\n 3301 CONTINUE\n 3302 CONTINUE\n*\n END IF\n*\n ALMORT = .FALSE.\n IF ( NR .EQ. N ) THEN\n MAXPRJ = ONE\n DO 3051 p = 2, N\n TEMP1 = DABS(A(p,p)) / SVA(IWORK(p))\n MAXPRJ = DMIN1( MAXPRJ, TEMP1 )\n 3051 CONTINUE\n IF ( MAXPRJ**2 .GE. ONE - DBLE(N)*EPSLN ) ALMORT = .TRUE.\n END IF\n*\n*\n SCONDA = - ONE\n CONDR1 = - ONE\n CONDR2 = - ONE\n*\n IF ( ERREST ) THEN\n IF ( N .EQ. NR ) THEN\n IF ( RSVEC ) THEN\n* .. V is available as workspace\n CALL DLACPY( 'U', N, N, A, LDA, V, LDV )\n DO 3053 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL DSCAL( p, ONE/TEMP1, V(1,p), 1 )\n 3053 CONTINUE\n CALL DPOCON( 'U', N, V, LDV, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE IF ( LSVEC ) THEN\n* .. U is available as workspace\n CALL DLACPY( 'U', N, N, A, LDA, U, LDU )\n DO 3054 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL DSCAL( p, ONE/TEMP1, U(1,p), 1 )\n 3054 CONTINUE\n CALL DPOCON( 'U', N, U, LDU, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE\n CALL DLACPY( 'U', N, N, A, LDA, WORK(N+1), N )\n DO 3052 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL DSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 )\n 3052 CONTINUE\n* .. the columns of R are scaled to have unit Euclidean lengths.\n CALL DPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1,\n & WORK(N+N*N+1), IWORK(2*N+M+1), IERR )\n END IF\n SCONDA = ONE / DSQRT(TEMP1)\n* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n ELSE\n SCONDA = - ONE\n END IF\n END IF\n*\n L2PERT = L2PERT .AND. ( DABS( A(1,1)/A(NR,NR) ) .GT. DSQRT(BIG1) )\n* If there is no violent scaling, artificial perturbation is not needed.\n*\n* Phase 3:\n*\n\n IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN\n*\n* Singular Values only\n*\n* .. transpose A(1:NR,1:N)\n DO 1946 p = 1, MIN0( N-1, NR )\n CALL DCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1946 CONTINUE\n*\n* The following two DO-loops introduce small relative perturbation\n* into the strict upper triangle of the lower triangular matrix.\n* Small entries below the main diagonal are also changed.\n* This modification is useful if the computing environment does not\n* provide/allow FLUSH TO ZERO underflow, for it prevents many\n* annoying denormalized numbers in case of strongly scaled matrices.\n* The perturbation is structured so that it does not introduce any\n* new perturbation of the singular values, and it does not destroy\n* the job done by the preconditioner.\n* The licence for this perturbation is in the variable L2PERT, which\n* should be .FALSE. if FLUSH TO ZERO underflow is active.\n*\n IF ( .NOT. ALMORT ) THEN\n*\n IF ( L2PERT ) THEN\n* XSC = DSQRT(SMALL)\n XSC = EPSLN / DBLE(N)\n DO 4947 q = 1, NR\n TEMP1 = XSC*DABS(A(q,q))\n DO 4949 p = 1, N\n IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = DSIGN( TEMP1, A(p,q) )\n 4949 CONTINUE\n 4947 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA )\n END IF\n*\n* .. second preconditioning using the QR factorization\n*\n CALL DGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR )\n*\n* .. and transpose upper to lower triangular\n DO 1948 p = 1, NR - 1\n CALL DCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1948 CONTINUE\n*\n END IF\n*\n* Row-cyclic Jacobi SVD algorithm with column pivoting\n*\n* .. again some perturbation (a \"background noise\") is added\n* to drown denormals\n IF ( L2PERT ) THEN\n* XSC = DSQRT(SMALL)\n XSC = EPSLN / DBLE(N)\n DO 1947 q = 1, NR\n TEMP1 = XSC*DABS(A(q,q))\n DO 1949 p = 1, NR\n IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = DSIGN( TEMP1, A(p,q) )\n 1949 CONTINUE\n 1947 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA )\n END IF\n*\n* .. and one-sided Jacobi rotations are started on a lower\n* triangular matrix (plus perturbation which is ignored in\n* the part which destroys triangular form (confusing?!))\n*\n CALL DGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,\n & N, V, LDV, WORK, LWORK, INFO )\n*\n SCALEM = WORK(1)\n NUMRANK = IDNINT(WORK(2))\n*\n*\n ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN\n*\n* -> Singular Values and Right Singular Vectors <-\n*\n IF ( ALMORT ) THEN\n*\n* .. in this case NR equals N\n DO 1998 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1998 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL DGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,\n & WORK, LWORK, INFO )\n SCALEM = WORK(1)\n NUMRANK = IDNINT(WORK(2))\n\n ELSE\n*\n* .. two more QR factorizations ( one QRF is not enough, two require\n* accumulated product of Jacobi rotations, three are perfect )\n*\n CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )\n CALL DGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)\n CALL DLACPY( 'Lower', NR, NR, A, LDA, V, LDV )\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n CALL DGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n DO 8998 p = 1, NR\n CALL DCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )\n 8998 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL DGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,\n & LDU, WORK(N+1), LWORK, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = IDNINT(WORK(N+2))\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV )\n CALL DLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )\n END IF\n*\n CALL DORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK,\n & V, LDV, WORK(N+1), LWORK-N, IERR )\n*\n END IF\n*\n DO 8991 p = 1, N\n CALL DCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )\n 8991 CONTINUE\n CALL DLACPY( 'All', N, N, A, LDA, V, LDV )\n*\n IF ( TRANSP ) THEN\n CALL DLACPY( 'All', N, N, V, LDV, U, LDU )\n END IF\n*\n ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN\n*\n* .. Singular Values and Left Singular Vectors ..\n*\n* .. second preconditioning step to avoid need to accumulate\n* Jacobi rotations in the Jacobi iterations.\n DO 1965 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )\n 1965 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL DGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n DO 1967 p = 1, NR - 1\n CALL DCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )\n 1967 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL DGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A,\n & LDA, WORK(N+1), LWORK-N, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = IDNINT(WORK(N+2))\n*\n IF ( NR .LT. M ) THEN\n CALL DLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )\n CALL DLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )\n END IF\n END IF\n*\n CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n DO 1974 p = 1, N1\n XSC = ONE / DNRM2( M, U(1,p), 1 )\n CALL DSCAL( M, XSC, U(1,p), 1 )\n 1974 CONTINUE\n*\n IF ( TRANSP ) THEN\n CALL DLACPY( 'All', N, N, U, LDU, V, LDV )\n END IF\n*\n ELSE\n*\n* .. Full SVD ..\n*\n IF ( .NOT. JRACC ) THEN\n*\n IF ( .NOT. ALMORT ) THEN\n*\n* Second Preconditioning Step (QRF [with pivoting])\n* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is\n* equivalent to an LQF CALL. Since in many libraries the QRF\n* seems to be better optimized than the LQF, we do explicit\n* transpose and use the QRF. This is subject to changes in an\n* optimized implementation of DGEJSV.\n*\n DO 1968 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1968 CONTINUE\n*\n* .. the following two loops perturb small entries to avoid\n* denormals in the second QR factorization, where they are\n* as good as zeros. This is done to avoid painfully slow\n* computation with denormals. The relative size of the perturbation\n* is a parameter that can be changed by the implementer.\n* This perturbation device will be obsolete on machines with\n* properly implemented arithmetic.\n* To switch it off, set L2PERT=.FALSE. To remove it from the\n* code, remove the action under L2PERT=.TRUE., leave the ELSE part.\n* The following two loops should be blocked and fused with the\n* transposed copy above.\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 2969 q = 1, NR\n TEMP1 = XSC*DABS( V(q,q) )\n DO 2968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = DSIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 2968 CONTINUE\n 2969 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n*\n* Estimate the row scaled condition number of R1\n* (If R1 is rectangular, N > NR, then the condition number\n* of the leading NR x NR submatrix is estimated.)\n*\n CALL DLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )\n DO 3950 p = 1, NR\n TEMP1 = DNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)\n CALL DSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)\n 3950 CONTINUE\n CALL DPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1,\n & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR)\n CONDR1 = ONE / DSQRT(TEMP1)\n* .. here need a second oppinion on the condition number\n* .. then assume worst case scenario\n* R1 is OK for inverse <=> CONDR1 .LT. DBLE(N)\n* more conservative <=> CONDR1 .LT. DSQRT(DBLE(N))\n*\n COND_OK = DSQRT(DBLE(NR))\n*[TP] COND_OK is a tuning parameter.\n\n IF ( CONDR1 .LT. COND_OK ) THEN\n* .. the second QRF without pivoting. Note: in an optimized\n* implementation, this QRF should be implemented as the QRF\n* of a lower triangular matrix.\n* R1^t = Q2 * R2\n CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)/EPSLN\n DO 3959 p = 2, NR\n DO 3958 q = 1, p - 1\n TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n IF ( DABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = DSIGN( TEMP1, V(q,p) )\n 3958 CONTINUE\n 3959 CONTINUE\n END IF\n*\n IF ( NR .NE. N )\n* .. save ...\n & CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n* .. this transposed copy should be better than naive\n DO 1969 p = 1, NR - 1\n CALL DCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 )\n 1969 CONTINUE\n*\n CONDR2 = CONDR1\n*\n ELSE\n*\n* .. ill-conditioned case: second QRF with pivoting\n* Note that windowed pivoting would be equaly good\n* numerically, and more run-time efficient. So, in\n* an optimal implementation, the next call to DGEQP3\n* should be replaced with eg. CALL SGEQPX (ACM TOMS #782)\n* with properly (carefully) chosen parameters.\n*\n* R1^t * P2 = Q2 * R2\n DO 3003 p = 1, NR\n IWORK(N+p) = 0\n 3003 CONTINUE\n CALL DGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),\n & WORK(2*N+1), LWORK-2*N, IERR )\n** CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n** & LWORK-2*N, IERR )\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 3969 p = 2, NR\n DO 3968 q = 1, p - 1\n TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n IF ( DABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = DSIGN( TEMP1, V(q,p) )\n 3968 CONTINUE\n 3969 CONTINUE\n END IF\n*\n CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 8970 p = 2, NR\n DO 8971 q = 1, p - 1\n TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n V(p,q) = - DSIGN( TEMP1, V(q,p) )\n 8971 CONTINUE\n 8970 CONTINUE\n ELSE\n CALL DLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV )\n END IF\n* Now, compute R2 = L3 * Q3, the LQ factorization.\n CALL DGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1),\n & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR )\n* .. and estimate the condition number\n CALL DLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )\n DO 4950 p = 1, NR\n TEMP1 = DNRM2( p, WORK(2*N+N*NR+NR+p), NR )\n CALL DSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )\n 4950 CONTINUE\n CALL DPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1,\n & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR )\n CONDR2 = ONE / DSQRT(TEMP1)\n*\n IF ( CONDR2 .GE. COND_OK ) THEN\n* .. save the Householder vectors used for Q3\n* (this overwrittes the copy of R2, as it will not be\n* needed in this branch, but it does not overwritte the\n* Huseholder vectors of Q2.).\n CALL DLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N )\n* .. and the rest of the information on Q3 is in\n* WORK(2*N+N*NR+1:2*N+N*NR+N)\n END IF\n*\n END IF\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 4968 q = 2, NR\n TEMP1 = XSC * V(q,q)\n DO 4969 p = 1, q - 1\n* V(p,q) = - DSIGN( TEMP1, V(q,p) )\n V(p,q) = - DSIGN( TEMP1, V(p,q) )\n 4969 CONTINUE\n 4968 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV )\n END IF\n*\n* Second preconditioning finished; continue with Jacobi SVD\n* The input matrix is lower trinagular.\n*\n* Recover the right singular vectors as solution of a well\n* conditioned triangular matrix equation.\n*\n IF ( CONDR1 .LT. COND_OK ) THEN\n*\n CALL DGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U,\n & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n DO 3970 p = 1, NR\n CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL DSCAL( NR, SVA(p), V(1,p), 1 )\n 3970 CONTINUE\n\n* .. pick the right matrix equation and solve it\n*\n IF ( NR. EQ. N ) THEN\n* :)) .. best case, R1 is inverted. The solution of this matrix\n* equation is Q2*V2 = the product of the Jacobi rotations\n* used in DGESVJ, premultiplied with the orthogonal matrix\n* from the second QR factorization.\n CALL DTRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV )\n ELSE\n* .. R1 is well conditioned, but non-square. Transpose(R2)\n* is inverted to get the product of the Jacobi rotations\n* used in DGESVJ. The Q-factor from the second QR\n* factorization is then built in explicitly.\n CALL DTRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),\n & N,V,LDV)\n IF ( NR .LT. N ) THEN\n CALL DLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)\n CALL DLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)\n CALL DLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)\n END IF\n CALL DORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR)\n END IF\n*\n ELSE IF ( CONDR2 .LT. COND_OK ) THEN\n*\n* :) .. the input matrix A is very likely a relative of\n* the Kahan matrix :)\n* The matrix R2 is inverted. The solution of the matrix equation\n* is Q3^T*V3 = the product of the Jacobi rotations (appplied to\n* the lower triangular L3 from the LQ factorization of\n* R2=L3*Q3), pre-multiplied with the transposed Q3.\n CALL DGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n DO 3870 p = 1, NR\n CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL DSCAL( NR, SVA(p), U(1,p), 1 )\n 3870 CONTINUE\n CALL DTRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU)\n* .. apply the permutation from the second QR factorization\n DO 873 q = 1, NR\n DO 872 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 872 CONTINUE\n DO 874 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 874 CONTINUE\n 873 CONTINUE\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n ELSE\n* Last line of defense.\n* #:( This is a rather pathological case: no scaled condition\n* improvement after two pivoted QR factorizations. Other\n* possibility is that the rank revealing QR factorization\n* or the condition estimator has failed, or the COND_OK\n* is set very close to ONE (which is unnecessary). Normally,\n* this branch should never be executed, but in rare cases of\n* failure of the RRQR or condition estimator, the last line of\n* defense ensures that DGEJSV completes the task.\n* Compute the full SVD of L3 using DGESVJ with explicit\n* accumulation of Jacobi rotations.\n CALL DGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n CALL DORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N,\n & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1),\n & LWORK-2*N-N*NR-NR, IERR )\n DO 773 q = 1, NR\n DO 772 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 772 CONTINUE\n DO 774 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 774 CONTINUE\n 773 CONTINUE\n*\n END IF\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = DSQRT(DBLE(N)) * EPSLN\n DO 1972 q = 1, N\n DO 972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 972 CONTINUE\n DO 973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 973 CONTINUE\n XSC = ONE / DNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( N, XSC, V(1,q), 1 )\n 1972 CONTINUE\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n IF ( NR .LT. M ) THEN\n CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL DLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)\n CALL DLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU)\n END IF\n END IF\n*\n* The Q matrix from the first QRF is built into the left singular\n* matrix U. This applies to all cases.\n*\n CALL DORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n\n* The columns of U are normalized. The cost is O(M*N) flops.\n TEMP1 = DSQRT(DBLE(M)) * EPSLN\n DO 1973 p = 1, NR\n XSC = ONE / DNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( M, XSC, U(1,p), 1 )\n 1973 CONTINUE\n*\n* If the initial QRF is computed with row pivoting, the left\n* singular vectors must be adjusted.\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n ELSE\n*\n* .. the initial matrix A has almost orthogonal columns and\n* the second QRF is not needed\n*\n CALL DLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 5970 p = 2, N\n TEMP1 = XSC * WORK( N + (p-1)*N + p )\n DO 5971 q = 1, p - 1\n WORK(N+(q-1)*N+p)=-DSIGN(TEMP1,WORK(N+(p-1)*N+q))\n 5971 CONTINUE\n 5970 CONTINUE\n ELSE\n CALL DLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )\n END IF\n*\n CALL DGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA,\n & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO )\n*\n SCALEM = WORK(N+N*N+1)\n NUMRANK = IDNINT(WORK(N+N*N+2))\n DO 6970 p = 1, N\n CALL DCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )\n CALL DSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )\n 6970 CONTINUE\n*\n CALL DTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,\n & ONE, A, LDA, WORK(N+1), N )\n DO 6972 p = 1, N\n CALL DCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )\n 6972 CONTINUE\n TEMP1 = DSQRT(DBLE(N))*EPSLN\n DO 6971 p = 1, N\n XSC = ONE / DNRM2( N, V(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( N, XSC, V(1,p), 1 )\n 6971 CONTINUE\n*\n* Assemble the left singular vector matrix U (M x N).\n*\n IF ( N .LT. M ) THEN\n CALL DLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU )\n IF ( N .LT. N1 ) THEN\n CALL DLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU )\n CALL DLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )\n END IF\n END IF\n CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n TEMP1 = DSQRT(DBLE(M))*EPSLN\n DO 6973 p = 1, N1\n XSC = ONE / DNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( M, XSC, U(1,p), 1 )\n 6973 CONTINUE\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n END IF\n*\n* end of the >> almost orthogonal case << in the full SVD\n*\n ELSE\n*\n* This branch deploys a preconditioned Jacobi SVD with explicitly\n* accumulated rotations. It is included as optional, mainly for\n* experimental purposes. It does perfom well, and can also be used.\n* In this implementation, this branch will be automatically activated\n* if the condition number sigma_max(A) / sigma_min(A) is predicted\n* to be greater than the overflow threshold. This is because the\n* a posteriori computation of the singular vectors assumes robust\n* implementation of BLAS and some LAPACK procedures, capable of working\n* in presence of extreme values. Since that is not always the case, ...\n*\n DO 7968 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 7968 CONTINUE\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL/EPSLN)\n DO 5969 q = 1, NR\n TEMP1 = XSC*DABS( V(q,q) )\n DO 5968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = DSIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 5968 CONTINUE\n 5969 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n\n CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n CALL DLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )\n*\n DO 7969 p = 1, NR\n CALL DCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )\n 7969 CONTINUE\n\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL/EPSLN)\n DO 9970 q = 2, NR\n DO 9971 p = 1, q - 1\n TEMP1 = XSC * DMIN1(DABS(U(p,p)),DABS(U(q,q)))\n U(p,q) = - DSIGN( TEMP1, U(q,p) )\n 9971 CONTINUE\n 9970 CONTINUE\n ELSE\n CALL DLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n END IF\n\n CALL DGESVJ( 'G', 'U', 'V', NR, NR, U, LDU, SVA,\n & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO )\n SCALEM = WORK(2*N+N*NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+2))\n\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n\n CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = DSQRT(DBLE(N)) * EPSLN\n DO 7972 q = 1, N\n DO 8972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 8972 CONTINUE\n DO 8973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 8973 CONTINUE\n XSC = ONE / DNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( N, XSC, V(1,q), 1 )\n 7972 CONTINUE\n*\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n*\n IF ( NR .LT. M ) THEN\n CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU )\n CALL DLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )\n END IF\n END IF\n*\n CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n*\n END IF\n IF ( TRANSP ) THEN\n* .. swap U and V because the procedure worked on A^t\n DO 6974 p = 1, N\n CALL DSWAP( N, U(1,p), 1, V(1,p), 1 )\n 6974 CONTINUE\n END IF\n*\n END IF\n* end of the full SVD\n*\n* Undo scaling, if necessary (and possible)\n*\n IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN\n CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR )\n USCAL1 = ONE\n USCAL2 = ONE\n END IF\n*\n IF ( NR .LT. N ) THEN\n DO 3004 p = NR+1, N\n SVA(p) = ZERO\n 3004 CONTINUE\n END IF\n*\n WORK(1) = USCAL2 * SCALEM\n WORK(2) = USCAL1\n IF ( ERREST ) WORK(3) = SCONDA\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = CONDR1\n WORK(5) = CONDR2\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ENTRA\n WORK(7) = ENTRAT\n END IF\n*\n IWORK(1) = NR\n IWORK(2) = NUMRANK\n IWORK(3) = WARNING\n*\n RETURN\n* ..\n* .. END OF DGEJSV\n* ..\n END\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_joba = argv[0];
- rb_jobu = argv[1];
- rb_jobv = argv[2];
- rb_jobr = argv[3];
- rb_jobt = argv[4];
- rb_jobp = argv[5];
- rb_m = argv[6];
- rb_a = argv[7];
- rb_work = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (8th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobr = StringValueCStr(rb_jobr)[0];
- m = NUM2INT(rb_m);
- jobt = StringValueCStr(rb_jobt)[0];
- jobu = StringValueCStr(rb_jobu)[0];
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (9th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
- lwork = NA_SHAPE0(rb_work);
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
- joba = StringValueCStr(rb_joba)[0];
- jobp = StringValueCStr(rb_jobp)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldv = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? n : 1;
- ldu = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? m : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sva = NA_PTR_TYPE(rb_sva, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[1];
- shape[0] = m+3*n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = lwork;
- rb_work_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work_out__ = NA_PTR_TYPE(rb_work_out__, doublereal*);
- MEMCPY(work_out__, work, doublereal, NA_TOTAL(rb_work));
- rb_work = rb_work_out__;
- work = work_out__;
-
- dgejsv_(&joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a, &lda, sva, u, &ldu, v, &ldv, work, &lwork, iwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_sva, rb_u, rb_v, rb_iwork, rb_info, rb_work);
-}
-
-void
-init_lapack_dgejsv(VALUE mLapack){
- rb_define_module_function(mLapack, "dgejsv", rb_dgejsv, -1);
-}
diff --git a/dgelq2.c b/dgelq2.c
deleted file mode 100644
index 106d223..0000000
--- a/dgelq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgelq2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dgelq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgelq2( a)\n or\n NumRu::Lapack.dgelq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELQ2 computes an LQ factorization of a real m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (m));
-
- dgelq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dgelq2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgelq2", rb_dgelq2, -1);
-}
diff --git a/dgelqf.c b/dgelqf.c
deleted file mode 100644
index c14eae0..0000000
--- a/dgelqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgelqf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgelqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgelqf( m, a, lwork)\n or\n NumRu::Lapack.dgelqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELQF computes an LQ factorization of a real M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgelqf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgelqf", rb_dgelqf, -1);
-}
diff --git a/dgels.c b/dgels.c
deleted file mode 100644
index be69457..0000000
--- a/dgels.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgels_(char *trans, integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgels(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.dgels( trans, m, a, b, lwork)\n or\n NumRu::Lapack.dgels # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELS solves overdetermined or underdetermined real linear systems\n* involving an M-by-N matrix A, or its transpose, using a QR or LQ\n* factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided:\n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of\n* an undetermined system A**T * X = B.\n*\n* 4. If TRANS = 'T' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**T * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'T': the linear system involves A**T.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by DGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by DGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'T'.\n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of\n* elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dgels(VALUE mLapack){
- rb_define_module_function(mLapack, "dgels", rb_dgels, -1);
-}
diff --git a/dgelsd.c b/dgelsd.c
deleted file mode 100644
index 84f6af4..0000000
--- a/dgelsd.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgelsd_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dgelsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer c__9;
- integer c__0;
- integer liwork;
- integer smlsiz;
- integer nlvl;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, b = NumRu::Lapack.dgelsd( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.dgelsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder transformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n* if M is greater than or equal to N or\n* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* For good performance, LWORK should generally be larger.\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 (MAX(1,LIWORK))\n* LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- c__9 = 9;
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- c__0 = 0;
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- smlsiz = ilaenv_(&c__9,"DGELSD"," ",&c__0,&c__0,&c__0,&c__0);
- nlvl = MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1));
- liwork = 3*(MIN(m,n))*nlvl+11*(MIN(m,n));
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
-
- dgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_s, rb_rank, rb_work, rb_info, rb_b);
-}
-
-void
-init_lapack_dgelsd(VALUE mLapack){
- rb_define_module_function(mLapack, "dgelsd", rb_dgelsd, -1);
-}
diff --git a/dgelss.c b/dgelss.c
deleted file mode 100644
index 4736424..0000000
--- a/dgelss.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgelss_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgelss(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.dgelss( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.dgelss # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELSS computes the minimum norm solution to a real linear least\n* squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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, and also:\n* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n* For good performance, LWORK should generally be larger.\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* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, &info);
-
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_rank, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dgelss(VALUE mLapack){
- rb_define_module_function(mLapack, "dgelss", rb_dgelss, -1);
-}
diff --git a/dgelsx.c b/dgelsx.c
deleted file mode 100644
index 7d16fce..0000000
--- a/dgelsx.c
+++ /dev/null
@@ -1,117 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgelsx_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *info);
-
-static VALUE
-rb_dgelsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, a, b, jpvt = NumRu::Lapack.dgelsx( m, a, b, jpvt, rcond)\n or\n NumRu::Lapack.dgelsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGELSY.\n*\n* DGELSX computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(doublereal, (MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)));
-
- dgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_dgelsx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgelsx", rb_dgelsx, -1);
-}
diff --git a/dgelsy.c b/dgelsy.c
deleted file mode 100644
index b742de4..0000000
--- a/dgelsy.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgelsy_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *jpvt, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgelsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.dgelsy( m, a, b, jpvt, rcond, lwork)\n or\n NumRu::Lapack.dgelsy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELSY computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of AP\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* The unblocked strategy requires that:\n* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n* where MN = min( M, N ).\n* The block algorithm requires that:\n* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,\n* and DORMRZ.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
- rb_lwork = argv[5];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
-
- dgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, &info);
-
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_rank, rb_work, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_dgelsy(VALUE mLapack){
- rb_define_module_function(mLapack, "dgelsy", rb_dgelsy, -1);
-}
diff --git a/dgeql2.c b/dgeql2.c
deleted file mode 100644
index d07ba23..0000000
--- a/dgeql2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeql2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dgeql2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgeql2( m, a)\n or\n NumRu::Lapack.dgeql2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQL2 computes a QL factorization of a real m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n));
-
- dgeql2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeql2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeql2", rb_dgeql2, -1);
-}
diff --git a/dgeqlf.c b/dgeqlf.c
deleted file mode 100644
index e7faa5d..0000000
--- a/dgeqlf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeqlf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgeqlf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgeqlf( m, a, lwork)\n or\n NumRu::Lapack.dgeqlf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQLF computes a QL factorization of a real M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeqlf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeqlf", rb_dgeqlf, -1);
-}
diff --git a/dgeqp3.c b/dgeqp3.c
deleted file mode 100644
index a3555c6..0000000
--- a/dgeqp3.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeqp3_(integer *m, integer *n, doublereal *a, integer *lda, integer *jpvt, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgeqp3(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.dgeqp3( m, a, jpvt, lwork)\n or\n NumRu::Lapack.dgeqp3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* orthogonal matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= 3*N+1.\n* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n* is the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
-
- dgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_tau, rb_work, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_dgeqp3(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeqp3", rb_dgeqp3, -1);
-}
diff --git a/dgeqpf.c b/dgeqpf.c
deleted file mode 100644
index 057da99..0000000
--- a/dgeqpf.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeqpf_(integer *m, integer *n, doublereal *a, integer *lda, integer *jpvt, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dgeqpf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.dgeqpf( m, a, jpvt)\n or\n NumRu::Lapack.dgeqpf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGEQP3.\n*\n* DGEQPF computes a QR factorization with column pivoting of a\n* real M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the orthogonal matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(doublereal, (3*n));
-
- dgeqpf_(&m, &n, a, &lda, jpvt, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_dgeqpf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeqpf", rb_dgeqpf, -1);
-}
diff --git a/dgeqr2.c b/dgeqr2.c
deleted file mode 100644
index f6a200c..0000000
--- a/dgeqr2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeqr2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dgeqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgeqr2( m, a)\n or\n NumRu::Lapack.dgeqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQR2 computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n));
-
- dgeqr2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeqr2", rb_dgeqr2, -1);
-}
diff --git a/dgeqr2p.c b/dgeqr2p.c
deleted file mode 100644
index b5471fb..0000000
--- a/dgeqr2p.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeqr2p_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dgeqr2p(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgeqr2p( m, a)\n or\n NumRu::Lapack.dgeqr2p # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQR2 computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n));
-
- dgeqr2p_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeqr2p(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeqr2p", rb_dgeqr2p, -1);
-}
diff --git a/dgeqrf.c b/dgeqrf.c
deleted file mode 100644
index 603d1ce..0000000
--- a/dgeqrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeqrf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgeqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgeqrf( m, a, lwork)\n or\n NumRu::Lapack.dgeqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQRF computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeqrf", rb_dgeqrf, -1);
-}
diff --git a/dgeqrfp.c b/dgeqrfp.c
deleted file mode 100644
index 4617159..0000000
--- a/dgeqrfp.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgeqrfp_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgeqrfp(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgeqrfp( m, a, lwork)\n or\n NumRu::Lapack.dgeqrfp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQRFP computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQR2P, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgeqrfp(VALUE mLapack){
- rb_define_module_function(mLapack, "dgeqrfp", rb_dgeqrfp, -1);
-}
diff --git a/dgerfs.c b/dgerfs.c
deleted file mode 100644
index 90ae788..0000000
--- a/dgerfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgerfs_(char *trans, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgerfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dgerfs( trans, a, af, ipiv, b, x)\n or\n NumRu::Lapack.dgerfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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 matrices B and X. NRHS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dgerfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dgerfs", rb_dgerfs, -1);
-}
diff --git a/dgerfsx.c b/dgerfsx.c
deleted file mode 100644
index 5e53706..0000000
--- a/dgerfsx.c
+++ /dev/null
@@ -1,200 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgerfsx_(char *trans, char *equed, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, doublereal *r, doublereal *c, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgerfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.dgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.dgerfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. \n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_r = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_x = argv[8];
- rb_params = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (9th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (6th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_x, rb_params);
-}
-
-void
-init_lapack_dgerfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgerfsx", rb_dgerfsx, -1);
-}
diff --git a/dgerq2.c b/dgerq2.c
deleted file mode 100644
index bf6c739..0000000
--- a/dgerq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgerq2_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dgerq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgerq2( a)\n or\n NumRu::Lapack.dgerq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERQ2 computes an RQ factorization of a real m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the orthogonal matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (m));
-
- dgerq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dgerq2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgerq2", rb_dgerq2, -1);
-}
diff --git a/dgerqf.c b/dgerqf.c
deleted file mode 100644
index 8e3c41e..0000000
--- a/dgerqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgerqf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgerqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgerqf( m, a, lwork)\n or\n NumRu::Lapack.dgerqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERQF computes an RQ factorization of a real M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgerqf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgerqf", rb_dgerqf, -1);
-}
diff --git a/dgesc2.c b/dgesc2.c
deleted file mode 100644
index 835d630..0000000
--- a/dgesc2.c
+++ /dev/null
@@ -1,89 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgesc2_(integer *n, doublereal *a, integer *lda, doublereal *rhs, integer *ipiv, integer *jpiv, doublereal *scale);
-
-static VALUE
-rb_dgesc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_rhs;
- doublereal *rhs;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_rhs_out__;
- doublereal *rhs_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.dgesc2( a, rhs, ipiv, jpiv)\n or\n NumRu::Lapack.dgesc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* DGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by DGETC2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by DGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) DOUBLE PRECISION array, dimension (N).\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_rhs = argv[1];
- rb_ipiv = argv[2];
- rb_jpiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_DFLOAT)
- rb_rhs = na_change_type(rb_rhs, NA_DFLOAT);
- rhs = NA_PTR_TYPE(rb_rhs, doublereal*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, doublereal*);
- MEMCPY(rhs_out__, rhs, doublereal, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- dgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
-
- rb_scale = rb_float_new((double)scale);
- return rb_ary_new3(2, rb_scale, rb_rhs);
-}
-
-void
-init_lapack_dgesc2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgesc2", rb_dgesc2, -1);
-}
diff --git a/dgesdd.c b/dgesdd.c
deleted file mode 100644
index 45fba8b..0000000
--- a/dgesdd.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgesdd_(char *jobz, integer *m, integer *n, doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dgesdd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldu;
- integer ucol;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.dgesdd( jobz, m, a, lwork)\n or\n NumRu::Lapack.dgesdd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESDD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and right singular\n* vectors. If singular vectors are desired, it uses a\n* divide-and-conquer algorithm.\n*\n* The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**T, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**T are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**T are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* on the array A and all rows of V**T are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**T are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**T are computed.\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 >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**T (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* orthogonal matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N orthogonal matrix V**T;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 JOBZ = 'N',\n* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).\n* If JOBZ = 'O',\n* LWORK >= 3*min(M,N) + \n* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n* If JOBZ = 'S' or 'A'\n* LWORK >= 3*min(M,N) +\n* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n* For good performance, LWORK should generally be larger.\n* If LWORK = -1 but other input arguments are legal, WORK(1)\n* returns the optimal LWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: DBDSDC did not converge, updating process failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- jobz = StringValueCStr(rb_jobz)[0];
- ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
- ldu = ((lsame_(&jobz,"S")) || ((('a') || (((lsame_(&jobz,"O")) && (m < n)))))) ? m : 1;
- ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m == n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = ucol;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- iwork = ALLOC_N(integer, (8*MIN(m,n)));
-
- dgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgesdd(VALUE mLapack){
- rb_define_module_function(mLapack, "dgesdd", rb_dgesdd, -1);
-}
diff --git a/dgesv.c b/dgesv.c
deleted file mode 100644
index e8f89b7..0000000
--- a/dgesv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgesv_(integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dgesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.dgesv( a, b)\n or\n NumRu::Lapack.dgesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGESV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL DGETRF, DGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dgesv(VALUE mLapack){
- rb_define_module_function(mLapack, "dgesv", rb_dgesv, -1);
-}
diff --git a/dgesvd.c b/dgesvd.c
deleted file mode 100644
index 2e9e5d6..0000000
--- a/dgesvd.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgesvd_(char *jobu, char *jobvt, integer *m, integer *n, doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgesvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobvt;
- char jobvt;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer ldu;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.dgesvd( jobu, jobvt, m, a, lwork)\n or\n NumRu::Lapack.dgesvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**T, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**T:\n* = 'A': all N rows of V**T are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**T (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**T (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**T (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**T (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n* V**T;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;\n* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n* superdiagonal elements of an upper bidiagonal matrix B\n* whose diagonal is in S (not necessarily sorted). B\n* satisfies A = U * B * VT, so it has the same singular values\n* as A, and singular vectors related by U and VT.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n* For good performance, LWORK should generally be larger.\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* > 0: if DBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of WORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobvt = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- jobvt = StringValueCStr(rb_jobvt)[0];
- lwork = NUM2INT(rb_lwork);
- jobu = StringValueCStr(rb_jobu)[0];
- ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
- ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgesvd(VALUE mLapack){
- rb_define_module_function(mLapack, "dgesvd", rb_dgesvd, -1);
-}
diff --git a/dgesvj.c b/dgesvj.c
deleted file mode 100644
index 2b0ae45..0000000
--- a/dgesvj.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgesvj_(char *joba, char *jobu, char *jobv, integer *m, integer *n, doublereal *a, integer *lda, doublereal *sva, integer *mv, doublereal *v, integer *ldv, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgesvj(int argc, VALUE *argv, VALUE self){
- VALUE rb_joba;
- char joba;
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_mv;
- integer mv;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_sva;
- doublereal *sva;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_v_out__;
- doublereal *v_out__;
- VALUE rb_work_out__;
- doublereal *work_out__;
-
- integer lda;
- integer n;
- integer ldv;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sva, info, a, v, work = NumRu::Lapack.dgesvj( joba, jobu, jobv, m, a, mv, v, work)\n or\n NumRu::Lapack.dgesvj # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVJ computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, where M >= N. The SVD of A is written as\n* [++] [xx] [x0] [xx]\n* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]\n* [++] [xx]\n* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n* of SIGMA are the singular values of A. The columns of U and V are the\n* left and the right singular vectors of A, respectively.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n* rotations. The rotations are implemented as fast scaled rotations of\n* Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n* column interchanges of de Rijk [2]. The relative accuracy of the computed\n* singular values and the accuracy of the computed singular vectors (in\n* angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n* The condition number that determines the accuracy in the full rank case\n* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n* spectral condition number. The best performance of this Jacobi SVD\n* procedure is achieved if used in an accelerated version of Drmac and\n* Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n* Some tunning parameters (marked with [TP]) are available for the\n* implementer.\n* The computational range for the nonzero singular values is the machine\n* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n* denormalized singular values can be computed with the corresponding\n* gradual loss of accurate digits.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n* ~~~~~~~~~~\n* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n* singular value decomposition on a vector computer.\n* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n* value computation in floating point arithmetic.\n* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER* 1\n* Specifies the structure of A.\n* = 'L': The input matrix A is lower triangular;\n* = 'U': The input matrix A is upper triangular;\n* = 'G': The input matrix A is general M-by-N matrix, M >= N.\n*\n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the left singular vectors\n* (columns of U):\n* = 'U': The left singular vectors corresponding to the nonzero\n* singular values are computed and returned in the leading\n* columns of A. See more details in the description of A.\n* The default numerical orthogonality threshold is set to\n* approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E').\n* = 'C': Analogous to JOBU='U', except that user can control the\n* level of numerical orthogonality of the computed left\n* singular vectors. TOL can be set to TOL = CTOL*EPS, where\n* CTOL is given on input in the array WORK.\n* No CTOL smaller than ONE is allowed. CTOL greater\n* than 1 / EPS is meaningless. The option 'C'\n* can be used if M*EPS is satisfactory orthogonality\n* of the computed left singular vectors, so CTOL=M could\n* save few sweeps of Jacobi rotations.\n* See the descriptions of A and WORK(1).\n* = 'N': The matrix U is not computed. However, see the\n* description of A.\n*\n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the right singular vectors, that\n* is, the matrix V:\n* = 'V' : the matrix V is computed and returned in the array V\n* = 'A' : the Jacobi rotations are applied to the MV-by-N\n* array V. In other words, the right singular vector\n* matrix V is not computed explicitly, instead it is\n* applied to an MV-by-N matrix initially stored in the\n* first MV rows of V.\n* = 'N' : the matrix V is not computed and the array V is not\n* referenced\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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit :\n* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' :\n* If INFO .EQ. 0 :\n* RANKA orthonormal columns of U are returned in the\n* leading RANKA columns of the array A. Here RANKA <= N\n* is the number of computed singular values of A that are\n* above the underflow threshold DLAMCH('S'). The singular\n* vectors corresponding to underflowed or zero singular\n* values are not computed. The value of RANKA is returned\n* in the array WORK as RANKA=NINT(WORK(2)). Also see the\n* descriptions of SVA and WORK. The computed columns of U\n* are mutually numerically orthogonal up to approximately\n* TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n* see the description of JOBU.\n* If INFO .GT. 0 :\n* the procedure DGESVJ did not converge in the given number\n* of iterations (sweeps). In that case, the computed\n* columns of U may not be orthogonal up to TOL. The output\n* U (stored in A), SIGMA (given by the computed singular\n* values in SVA(1:N)) and V is still a decomposition of the\n* input matrix A in the sense that the residual\n* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n*\n* If JOBU .EQ. 'N' :\n* If INFO .EQ. 0 :\n* Note that the left singular vectors are 'for free' in the\n* one-sided Jacobi SVD algorithm. However, if only the\n* singular values are needed, the level of numerical\n* orthogonality of U is not an issue and iterations are\n* stopped when the columns of the iterated matrix are\n* numerically orthogonal up to approximately M*EPS. Thus,\n* on exit, A contains the columns of U scaled with the\n* corresponding singular values.\n* If INFO .GT. 0 :\n* the procedure DGESVJ did not converge in the given number\n* of iterations (sweeps).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) DOUBLE PRECISION array, dimension (N)\n* On exit :\n* If INFO .EQ. 0 :\n* depending on the value SCALE = WORK(1), we have:\n* If SCALE .EQ. ONE :\n* SVA(1:N) contains the computed singular values of A.\n* During the computation SVA contains the Euclidean column\n* norms of the iterated matrices in the array A.\n* If SCALE .NE. ONE :\n* The singular values of A are SCALE*SVA(1:N), and this\n* factored representation is due to the fact that some of the\n* singular values of A might underflow or overflow.\n* If INFO .GT. 0 :\n* the procedure DGESVJ did not converge in the given number of\n* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n*\n* MV (input) INTEGER\n* If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ\n* is applied to the first MV rows of V. See the description of JOBV.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n* If JOBV = 'V', then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'A', then V contains the product of the computed right\n* singular vector matrix and the initial matrix in\n* the array V.\n* If JOBV = 'N', then V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV .GE. 1.\n* If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n*\n* WORK (input/workspace/output) DOUBLE PRECISION array, dimension max(4,M+N).\n* On entry :\n* If JOBU .EQ. 'C' :\n* WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n* The process stops if all columns of A are mutually\n* orthogonal up to CTOL*EPS, EPS=DLAMCH('E').\n* It is required that CTOL >= ONE, i.e. it is not\n* allowed to force the routine to obtain orthogonality\n* below EPS.\n* On exit :\n* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n* are the computed singular values of A.\n* (See description of SVA().)\n* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n* singular values.\n* WORK(3) = NINT(WORK(3)) is the number of the computed singular\n* values that are larger than the underflow threshold.\n* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n* rotations needed for numerical convergence.\n* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n* This is useful information in cases when DGESVJ did\n* not converge, as it can be used to estimate whether\n* the output is stil useful and for post festum analysis.\n* WORK(6) = the largest absolute value over all sines of the\n* Jacobi rotation angles in the last sweep. It can be\n* useful for a post festum analysis.\n*\n* LWORK (input) INTEGER\n* length of WORK, WORK >= MAX(6,M+N)\n*\n* INFO (output) INTEGER\n* = 0 : successful exit.\n* < 0 : if INFO = -i, then the i-th argument had an illegal value\n* > 0 : DGESVJ did not converge in the maximal allowed number (30)\n* of sweeps. The output may still be useful. See the\n* description of WORK.\n*\n\n* =====================================================================\n*\n* .. Local Parameters ..\n DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n INTEGER NSWEEP\n PARAMETER ( NSWEEP = 30 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n + THSIGN, TOL\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n + SWBAND\n LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n + RSVEC, UCTOL, UPPER\n* ..\n* .. Local Arrays ..\n DOUBLE PRECISION FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n* ..\n* from BLAS\n DOUBLE PRECISION DDOT, DNRM2\n EXTERNAL DDOT, DNRM2\n INTEGER IDAMAX\n EXTERNAL IDAMAX\n* from LAPACK\n DOUBLE PRECISION DLAMCH\n EXTERNAL DLAMCH\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n* ..\n* from BLAS\n EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP\n* from LAPACK\n EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA\n*\n EXTERNAL DGSVJ0, DGSVJ1\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_joba = argv[0];
- rb_jobu = argv[1];
- rb_jobv = argv[2];
- rb_m = argv[3];
- rb_a = argv[4];
- rb_mv = argv[5];
- rb_v = argv[6];
- rb_work = argv[7];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of v");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- jobu = StringValueCStr(rb_jobu)[0];
- mv = NUM2INT(rb_mv);
- jobv = StringValueCStr(rb_jobv)[0];
- joba = StringValueCStr(rb_joba)[0];
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (8th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
- lwork = NA_SHAPE0(rb_work);
- if (lwork != (MAX(4,m+n)))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", MAX(4,m+n));
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
- lwork = MAX(4,m+n);
- {
- int shape[1];
- shape[0] = n;
- rb_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sva = NA_PTR_TYPE(rb_sva, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- {
- int shape[1];
- shape[0] = lwork;
- rb_work_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work_out__ = NA_PTR_TYPE(rb_work_out__, doublereal*);
- MEMCPY(work_out__, work, doublereal, NA_TOTAL(rb_work));
- rb_work = rb_work_out__;
- work = work_out__;
-
- dgesvj_(&joba, &jobu, &jobv, &m, &n, a, &lda, sva, &mv, v, &ldv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_sva, rb_info, rb_a, rb_v, rb_work);
-}
-
-void
-init_lapack_dgesvj(VALUE mLapack){
- rb_define_module_function(mLapack, "dgesvj", rb_dgesvj, -1);
-}
diff --git a/dgesvx.c b/dgesvx.c
deleted file mode 100644
index 8ca0a03..0000000
--- a/dgesvx.c
+++ /dev/null
@@ -1,229 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgesvx_(char *fact, char *trans, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgesvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_af_out__;
- doublereal *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.dgesvx( fact, trans, a, af, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.dgesvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVX uses the LU factorization to compute the solution to a real\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) DOUBLE PRECISION array, dimension (4*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = 4*n;
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublereal*);
- MEMCPY(af_out__, af, doublereal, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
-
- dgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_dgesvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgesvx", rb_dgesvx, -1);
-}
diff --git a/dgesvxx.c b/dgesvxx.c
deleted file mode 100644
index 989e4d5..0000000
--- a/dgesvxx.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgesvxx_(char *fact, char *trans, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgesvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_af_out__;
- doublereal *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.dgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.dgesvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVXX uses the LU factorization to compute the solution to a\n* double precision system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In DGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
- rb_params = argv[9];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublereal*);
- MEMCPY(af_out__, af, doublereal, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_dgesvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgesvxx", rb_dgesvxx, -1);
-}
diff --git a/dgetc2.c b/dgetc2.c
deleted file mode 100644
index 48f8178..0000000
--- a/dgetc2.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgetc2_(integer *n, doublereal *a, integer *lda, integer *ipiv, integer *jpiv, integer *info);
-
-static VALUE
-rb_dgetc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.dgetc2( a)\n or\n NumRu::Lapack.dgetc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGETC2 computes an LU factorization with complete pivoting of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is the Level 2 BLAS algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the n-by-n matrix A to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, i.e., giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n* we try to solve for x in Ax = b. So U is perturbed to\n* avoid the overflow.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgetc2_(&n, a, &lda, ipiv, jpiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_jpiv, rb_info, rb_a);
-}
-
-void
-init_lapack_dgetc2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgetc2", rb_dgetc2, -1);
-}
diff --git a/dgetf2.c b/dgetf2.c
deleted file mode 100644
index e2bea1c..0000000
--- a/dgetf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgetf2_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_dgetf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.dgetf2( m, a)\n or\n NumRu::Lapack.dgetf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgetf2_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_dgetf2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgetf2", rb_dgetf2, -1);
-}
diff --git a/dgetrf.c b/dgetrf.c
deleted file mode 100644
index 2756854..0000000
--- a/dgetrf.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgetrf_(integer *m, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_dgetrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.dgetrf( m, a)\n or\n NumRu::Lapack.dgetrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgetrf_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_dgetrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgetrf", rb_dgetrf, -1);
-}
diff --git a/dgetri.c b/dgetri.c
deleted file mode 100644
index 6bd5b54..0000000
--- a/dgetri.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgetri_(integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgetri(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dgetri( a, ipiv, lwork)\n or\n NumRu::Lapack.dgetri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGETRI computes the inverse of a matrix using the LU factorization\n* computed by DGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_ipiv = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dgetri(VALUE mLapack){
- rb_define_module_function(mLapack, "dgetri", rb_dgetri, -1);
-}
diff --git a/dgetrs.c b/dgetrs.c
deleted file mode 100644
index 3aebf6a..0000000
--- a/dgetrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgetrs_(char *trans, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dgetrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dgetrs( trans, a, ipiv, b)\n or\n NumRu::Lapack.dgetrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGETRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by DGETRF.\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'* X = B (Transpose)\n* = 'C': A'* 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dgetrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dgetrs", rb_dgetrs, -1);
-}
diff --git a/dggbak.c b/dggbak.c
deleted file mode 100644
index 74f8e88..0000000
--- a/dggbak.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggbak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, integer *m, doublereal *v, integer *ldv, integer *info);
-
-static VALUE
-rb_dggbak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- doublereal *lscale;
- VALUE rb_rscale;
- doublereal *rscale;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- doublereal *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.dggbak( job, side, ilo, ihi, lscale, rscale, v)\n or\n NumRu::Lapack.dggbak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* DGGBAK forms the right or left eigenvectors of a real generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* DGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to DGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by DGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by DGGBAL.\n*\n* RSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by DGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by DTGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSCAL, DSWAP, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_lscale = argv[4];
- rb_rscale = argv[5];
- rb_v = argv[6];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_rscale))
- rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
- if (NA_RANK(rb_rscale) != 1)
- rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_rscale);
- if (NA_TYPE(rb_rscale) != NA_DFLOAT)
- rb_rscale = na_change_type(rb_rscale, NA_DFLOAT);
- rscale = NA_PTR_TYPE(rb_rscale, doublereal*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_lscale))
- rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
- if (NA_RANK(rb_lscale) != 1)
- rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lscale) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of lscale must be the same as shape 0 of rscale");
- if (NA_TYPE(rb_lscale) != NA_DFLOAT)
- rb_lscale = na_change_type(rb_lscale, NA_DFLOAT);
- lscale = NA_PTR_TYPE(rb_lscale, doublereal*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- dggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_dggbak(VALUE mLapack){
- rb_define_module_function(mLapack, "dggbak", rb_dggbak, -1);
-}
diff --git a/dggbal.c b/dggbal.c
deleted file mode 100644
index 3a2e3dc..0000000
--- a/dggbal.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggbal_(char *job, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal *work, integer *info);
-
-static VALUE
-rb_dggbal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- doublereal *lscale;
- VALUE rb_rscale;
- doublereal *rscale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.dggbal( job, a, b)\n or\n NumRu::Lapack.dggbal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGBAL balances a pair of general real matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i = 1,...,N.\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j)\n* is the scaling factor applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j)\n* is the scaling factor applied to column j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
-
- dggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
-
- free(work);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggbal(VALUE mLapack){
- rb_define_module_function(mLapack, "dggbal", rb_dggbal, -1);
-}
diff --git a/dgges.c b/dgges.c
deleted file mode 100644
index 37cb8d9..0000000
--- a/dgges.c
+++ /dev/null
@@ -1,173 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(doublereal *arg0, doublereal *arg1, doublereal *arg2){
- VALUE rb_arg0, rb_arg1, rb_arg2;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
- rb_arg2 = rb_float_new((double)(*arg2));
-
- rb_ret = rb_yield_values(3, rb_arg0, rb_arg1, rb_arg2);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID dgges_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *work, integer *lwork, logical *bwork, integer *info);
-
-static VALUE
-rb_dgges(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_vsl;
- doublereal *vsl;
- VALUE rb_vsr;
- doublereal *vsr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b,c| ... }\n or\n NumRu::Lapack.dgges # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n* the generalized eigenvalues, the generalized real Schur form (S,T),\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T.The\n* leading columns of VSL and VSR then form an orthonormal basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* DGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG);\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n*\n* Note that in the ill-conditioned case, a selected complex\n* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n* in this case.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N = 0, LWORK >= 1, else LWORK >= 8*N+16.\n* For good performance , LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ.\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in DTGSEN.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- dgges_(&jobvsl, &jobvsr, &sort, rb_selctg, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, bwork, &info);
-
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_sdim, rb_alphar, rb_alphai, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dgges(VALUE mLapack){
- rb_define_module_function(mLapack, "dgges", rb_dgges, -1);
-}
diff --git a/dggesx.c b/dggesx.c
deleted file mode 100644
index 0d4aaad..0000000
--- a/dggesx.c
+++ /dev/null
@@ -1,200 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(doublereal *arg0, doublereal *arg1, doublereal *arg2){
- VALUE rb_arg0, rb_arg1, rb_arg2;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
- rb_arg2 = rb_float_new((double)(*arg2));
-
- rb_ret = rb_yield_values(3, rb_arg0, rb_arg1, rb_arg2);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID dggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, char *sense, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *sdim, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *vsl, integer *ldvsl, doublereal *vsr, integer *ldvsr, doublereal *rconde, doublereal *rcondv, doublereal *work, integer *lwork, integer *iwork, integer *liwork, logical *bwork, integer *info);
-
-static VALUE
-rb_dggesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_vsl;
- doublereal *vsl;
- VALUE rb_vsr;
- doublereal *vsr;
- VALUE rb_rconde;
- doublereal *rconde;
- VALUE rb_rcondv;
- doublereal *rcondv;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer *iwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b,c| ... }\n or\n NumRu::Lapack.dggesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGESX computes for a pair of N-by-N real nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n* since ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition numbers for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n* LWORK >= max( 8*N, 6*N+16 ).\n* Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n* this may not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+6.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in DTGSEN.\n*\n\n* Further Details\n* ===============\n*\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / RCONDE( 1 ).\n*\n* An approximate (asymptotic) bound on the maximum angular error in\n* the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / RCONDV( 2 ).\n*\n* See LAPACK User's Guide, section 4.11 for more information.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
- rb_liwork = argv[7];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- liwork = NUM2INT(rb_liwork);
- sense = StringValueCStr(rb_sense)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- dggesx_(&jobvsl, &jobvsr, &sort, rb_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, iwork, &liwork, bwork, &info);
-
- free(iwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_sdim, rb_alphar, rb_alphai, rb_beta, rb_vsl, rb_vsr, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggesx(VALUE mLapack){
- rb_define_module_function(mLapack, "dggesx", rb_dggesx, -1);
-}
diff --git a/dggev.c b/dggev.c
deleted file mode 100644
index b8869a6..0000000
--- a/dggev.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggev_(char *jobvl, char *jobvr, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dggev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dggev( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.dggev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B .\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* alpha/beta. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ.\n* =N+2: error return from DTGEVC.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_vl, rb_vr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggev(VALUE mLapack){
- rb_define_module_function(mLapack, "dggev", rb_dggev, -1);
-}
diff --git a/dggevx.c b/dggevx.c
deleted file mode 100644
index efac056..0000000
--- a/dggevx.c
+++ /dev/null
@@ -1,204 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *rcondv, doublereal *work, integer *lwork, integer *iwork, logical *bwork, integer *info);
-
-static VALUE
-rb_dggevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- doublereal *lscale;
- VALUE rb_rscale;
- doublereal *rscale;
- VALUE rb_abnrm;
- doublereal abnrm;
- VALUE rb_bbnrm;
- doublereal bbnrm;
- VALUE rb_rconde;
- doublereal *rconde;
- VALUE rb_rcondv;
- doublereal *rcondv;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer *iwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggevx( balanc, jobvl, jobvr, sense, a, b, lwork)\n or\n NumRu::Lapack.dggevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j) .\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed.\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* For a complex conjugate pair of eigenvalues two consecutive\n* elements of RCONDE are set to the same value. Thus RCONDE(j),\n* RCONDV(j), and the j-th columns of VL and VR all correspond\n* to the j-th eigenpair.\n* If SENSE = 'N or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* If SENSE = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. For a complex eigenvector two consecutive\n* elements of RCONDV are set to the same value. If the\n* eigenvalues cannot be reordered to compute RCONDV(j),\n* RCONDV(j) is set to 0; this can only occur when the true\n* value would be very small anyway.\n* If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,2*N).\n* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n* LWORK >= max(1,6*N).\n* If SENSE = 'E' or 'B', LWORK >= max(1,10*N).\n* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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 (N+6)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ.\n* =N+2: error return from DTGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+6));
- bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
-
- dggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, iwork, bwork, &info);
-
- free(iwork);
- free(bwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_bbnrm = rb_float_new((double)bbnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(17, rb_alphar, rb_alphai, rb_beta, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_abnrm, rb_bbnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggevx(VALUE mLapack){
- rb_define_module_function(mLapack, "dggevx", rb_dggevx, -1);
-}
diff --git a/dggglm.c b/dggglm.c
deleted file mode 100644
index cddd022..0000000
--- a/dggglm.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggglm_(integer *n, integer *m, integer *p, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *d, doublereal *x, doublereal *y, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dggglm(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_d_out__;
- doublereal *d_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.dggglm( a, b, d, lwork)\n or\n NumRu::Lapack.dggglm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) DOUBLE PRECISION array, dimension (M)\n* Y (output) DOUBLE PRECISION array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* DGEQRF, SGERQF, DORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_d = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = m;
- rb_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = p;
- rb_y = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- dggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_y, rb_work, rb_info, rb_a, rb_b, rb_d);
-}
-
-void
-init_lapack_dggglm(VALUE mLapack){
- rb_define_module_function(mLapack, "dggglm", rb_dggglm, -1);
-}
diff --git a/dgghrd.c b/dgghrd.c
deleted file mode 100644
index 1d05a67..0000000
--- a/dgghrd.c
+++ /dev/null
@@ -1,148 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgghrd_(char *compq, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *q, integer *ldq, doublereal *z, integer *ldz, integer *info);
-
-static VALUE
-rb_dgghrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.dgghrd( compq, compz, ilo, ihi, a, b, q, z)\n or\n NumRu::Lapack.dgghrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* DGGHRD reduces a pair of real matrices (A,B) to generalized upper\n* Hessenberg form using orthogonal transformations, where A is a\n* general matrix and B is upper triangular. The form of the\n* generalized eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the orthogonal matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**T*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**T*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**T*x.\n*\n* The orthogonal matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n*\n* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n*\n* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n*\n* If Q1 is the orthogonal matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then DGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Z;\n* = 'I': Z is initialized to the unit matrix, and the\n* orthogonal matrix Z is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry,\n* and the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to SGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**T B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n* typically from the QR factorization of B.\n* On exit, if COMPQ='I', the orthogonal matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n* On exit, if COMPZ='I', the orthogonal matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and Van Loan (Johns Hopkins Press.)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_compq = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ilo = NUM2INT(rb_ilo);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- compq = StringValueCStr(rb_compq)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_dgghrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dgghrd", rb_dgghrd, -1);
-}
diff --git a/dgglse.c b/dgglse.c
deleted file mode 100644
index 21f474a..0000000
--- a/dgglse.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgglse_(integer *m, integer *n, integer *p, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *c, doublereal *d, doublereal *x, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgglse(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_d_out__;
- doublereal *d_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer m;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.dgglse( a, b, c, d, lwork)\n or\n NumRu::Lapack.dgglse # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( (A) ) = N.\n* ( (B) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) DOUBLE PRECISION array, dimension (N)\n* On exit, X is the solution of the LSE problem.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* DGEQRF, SGERQF, DORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- p = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = n;
- rb_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[1];
- shape[0] = p;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- dgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_work, rb_info, rb_a, rb_b, rb_c, rb_d);
-}
-
-void
-init_lapack_dgglse(VALUE mLapack){
- rb_define_module_function(mLapack, "dgglse", rb_dgglse, -1);
-}
diff --git a/dggqrf.c b/dggqrf.c
deleted file mode 100644
index caad7a2..0000000
--- a/dggqrf.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggqrf_(integer *n, integer *m, integer *p, doublereal *a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, doublereal *taub, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dggqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- doublereal *taua;
- VALUE rb_taub;
- doublereal *taub;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.dggqrf( n, a, b, lwork)\n or\n NumRu::Lapack.dggqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the orthogonal matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the orthogonal\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of DORMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine DORGQR.\n* To use Q to update another matrix, use LAPACK subroutine DORMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine DORGRQ.\n* To use Z to update another matrix, use LAPACK subroutine DORMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- n = NUM2INT(rb_n);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(n,m);
- rb_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(n,p);
- rb_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dggqrf", rb_dggqrf, -1);
-}
diff --git a/dggrqf.c b/dggrqf.c
deleted file mode 100644
index 36ee1af..0000000
--- a/dggrqf.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggrqf_(integer *m, integer *p, integer *n, doublereal *a, integer *lda, doublereal *taua, doublereal *b, integer *ldb, doublereal *taub, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dggrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_p;
- integer p;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- doublereal *taua;
- VALUE rb_taub;
- doublereal *taub;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.dggrqf( m, p, a, b, lwork)\n or\n NumRu::Lapack.dggrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the orthogonal\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the orthogonal matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of DORMRQ.\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 INF0= -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine DORGRQ.\n* To use Q to update another matrix, use LAPACK subroutine DORMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine DORGQR.\n* To use Z to update another matrix, use LAPACK subroutine DORMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_p = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- p = NUM2INT(rb_p);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(p,n);
- rb_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "dggrqf", rb_dggrqf, -1);
-}
diff --git a/dggsvd.c b/dggsvd.c
deleted file mode 100644
index 43313d7..0000000
--- a/dggsvd.c
+++ /dev/null
@@ -1,168 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *alpha, doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer *ldq, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dggsvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_alpha;
- doublereal *alpha;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.dggsvd( jobu, jobv, jobq, a, b)\n or\n NumRu::Lapack.dggsvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N real matrix A and P-by-N real matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are orthogonal matrices, and Z' is the transpose\n* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',\n* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n* D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n* following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the orthogonal\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n* also equal to the CS decomposition of A and B. Furthermore, the GSVD\n* can be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) ).\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in the Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix R if M-K-L < 0.\n* See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n* BETA(K+1:M) =S, BETA(M+1:K+L) =1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) DOUBLE PRECISION array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) DOUBLE PRECISION array,\n* dimension (max(3*N,M,P)+N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine DTGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA DOUBLE PRECISION\n* TOLB DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n DOUBLE PRECISION DLAMCH, DLANGE\n EXTERNAL LSAME, DLAMCH, DLANGE\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DGGSVP, DTGSJA, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- lda = m;
- ldb = p;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, (MAX(3*n,m)*(p)+n));
-
- dggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, iwork, &info);
-
- free(work);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_k, rb_l, rb_alpha, rb_beta, rb_u, rb_v, rb_q, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggsvd(VALUE mLapack){
- rb_define_module_function(mLapack, "dggsvd", rb_dggsvd, -1);
-}
diff --git a/dggsvp.c b/dggsvp.c
deleted file mode 100644
index fbba14d..0000000
--- a/dggsvp.c
+++ /dev/null
@@ -1,155 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer *l, doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer *ldq, integer *iwork, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dggsvp(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_tola;
- doublereal tola;
- VALUE rb_tolb;
- doublereal tolb;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer *iwork;
- doublereal *tau;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.dggsvp( jobu, jobv, jobq, a, b, tola, tolb)\n or\n NumRu::Lapack.dggsvp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGSVP computes orthogonal matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* DGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,M)\n* If JOBU = 'U', U contains the orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) DOUBLE PRECISION array, dimension (LDV,P)\n* If JOBV = 'V', V contains the orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* TAU (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))\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* Further Details\n* ===============\n*\n* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_tola = argv[5];
- rb_tolb = argv[6];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- tolb = NUM2DBL(rb_tolb);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- tola = NUM2DBL(rb_tola);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- m = lda;
- ldb = p;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
- tau = ALLOC_N(doublereal, (n));
- work = ALLOC_N(doublereal, (MAX(MAX(3*n,m),p)));
-
- dggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, tau, work, &info);
-
- free(iwork);
- free(tau);
- free(work);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_k, rb_l, rb_u, rb_v, rb_q, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dggsvp(VALUE mLapack){
- rb_define_module_function(mLapack, "dggsvp", rb_dggsvp, -1);
-}
diff --git a/dgsvj0.c b/dgsvj0.c
deleted file mode 100644
index 00a84bc..0000000
--- a/dgsvj0.c
+++ /dev/null
@@ -1,159 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgsvj0_(char *jobv, integer *m, integer *n, doublereal *a, integer *lda, doublereal *d, doublereal *sva, integer *mv, doublereal *v, integer *ldv, doublereal *eps, doublereal *sfmin, doublereal *tol, integer *nsweep, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgsvj0(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobv;
- char jobv;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_sva;
- doublereal *sva;
- VALUE rb_mv;
- integer mv;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_eps;
- doublereal eps;
- VALUE rb_sfmin;
- doublereal sfmin;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_nsweep;
- integer nsweep;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_sva_out__;
- doublereal *sva_out__;
- VALUE rb_v_out__;
- doublereal *v_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldv;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, d, sva, v = NumRu::Lapack.dgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep)\n or\n NumRu::Lapack.dgsvj0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGSVJ0 is called from DGESVJ as a pre-processor and that is its main\n* purpose. It applies Jacobi rotations in the same way as DGESVJ does, but\n* it does not check convergence (stopping criterion). Few tuning\n* parameters (marked by [TP]) are available for the implementer.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* DGSVJ0 is used just to enable SGESVJ to call a simplified version of\n* itself to work on a submatrix of the original matrix.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\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* A (input/output) DOUBLE PRECISION 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 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) DOUBLE PRECISION 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 A, TOL and NSWEEP.)\n*\n* SVA (input/workspace/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION\n* EPS = DLAMCH('Epsilon')\n*\n* SFMIN (input) DOUBLE PRECISION\n* SFMIN = DLAMCH('Safe Minimum')\n*\n* TOL (input) DOUBLE PRECISION\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 DABS(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) DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n + THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n + NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND\n LOGICAL APPLV, ROTOK, RSVEC\n* ..\n* .. Local Arrays ..\n DOUBLE PRECISION FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DDOT, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DDOT, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobv = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_d = argv[3];
- rb_sva = argv[4];
- rb_mv = argv[5];
- rb_v = argv[6];
- rb_eps = argv[7];
- rb_sfmin = argv[8];
- rb_tol = argv[9];
- rb_nsweep = argv[10];
-
- sfmin = NUM2DBL(rb_sfmin);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- nsweep = NUM2INT(rb_nsweep);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of v");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of v");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_sva))
- rb_raise(rb_eArgError, "sva (5th argument) must be NArray");
- if (NA_RANK(rb_sva) != 1)
- rb_raise(rb_eArgError, "rank of sva (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sva) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 1 of v");
- if (NA_TYPE(rb_sva) != NA_DFLOAT)
- rb_sva = na_change_type(rb_sva, NA_DFLOAT);
- sva = NA_PTR_TYPE(rb_sva, doublereal*);
- jobv = StringValueCStr(rb_jobv)[0];
- tol = NUM2DBL(rb_tol);
- eps = NUM2DBL(rb_eps);
- mv = NUM2INT(rb_mv);
- lwork = m;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_sva_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sva_out__ = NA_PTR_TYPE(rb_sva_out__, doublereal*);
- MEMCPY(sva_out__, sva, doublereal, NA_TOTAL(rb_sva));
- rb_sva = rb_sva_out__;
- sva = sva_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- work = ALLOC_N(doublereal, (lwork));
-
- dgsvj0_(&jobv, &m, &n, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_d, rb_sva, rb_v);
-}
-
-void
-init_lapack_dgsvj0(VALUE mLapack){
- rb_define_module_function(mLapack, "dgsvj0", rb_dgsvj0, -1);
-}
diff --git a/dgsvj1.c b/dgsvj1.c
deleted file mode 100644
index 6057e3a..0000000
--- a/dgsvj1.c
+++ /dev/null
@@ -1,163 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgsvj1_(char *jobv, integer *m, integer *n, integer *n1, doublereal *a, integer *lda, doublereal *d, doublereal *sva, integer *mv, doublereal *v, integer *ldv, doublereal *eps, doublereal *sfmin, doublereal *tol, integer *nsweep, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dgsvj1(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobv;
- char jobv;
- VALUE rb_m;
- integer m;
- VALUE rb_n1;
- integer n1;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_sva;
- doublereal *sva;
- VALUE rb_mv;
- integer mv;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_eps;
- doublereal eps;
- VALUE rb_sfmin;
- doublereal sfmin;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_nsweep;
- integer nsweep;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_sva_out__;
- doublereal *sva_out__;
- VALUE rb_v_out__;
- doublereal *v_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldv;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, d, sva, v = NumRu::Lapack.dgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep)\n or\n NumRu::Lapack.dgsvj1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGSVJ1 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* DGSVJ1 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION\n* EPS = DLAMCH('Epsilon')\n*\n* SFMIN (input) DOUBLE PRECISION\n* SFMIN = DLAMCH('Safe Minimum')\n*\n* TOL (input) DOUBLE PRECISION\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 DABS(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) DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION 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 DOUBLE PRECISION FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DDOT, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DDOT, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobv = argv[0];
- rb_m = argv[1];
- rb_n1 = argv[2];
- rb_a = argv[3];
- rb_d = argv[4];
- rb_sva = argv[5];
- rb_mv = argv[6];
- rb_v = argv[7];
- rb_eps = argv[8];
- rb_sfmin = argv[9];
- rb_tol = argv[10];
- rb_nsweep = argv[11];
-
- sfmin = NUM2DBL(rb_sfmin);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (8th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- nsweep = NUM2INT(rb_nsweep);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of v");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- n1 = NUM2INT(rb_n1);
- if (!NA_IsNArray(rb_sva))
- rb_raise(rb_eArgError, "sva (6th argument) must be NArray");
- if (NA_RANK(rb_sva) != 1)
- rb_raise(rb_eArgError, "rank of sva (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sva) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 1 of v");
- if (NA_TYPE(rb_sva) != NA_DFLOAT)
- rb_sva = na_change_type(rb_sva, NA_DFLOAT);
- sva = NA_PTR_TYPE(rb_sva, doublereal*);
- mv = NUM2INT(rb_mv);
- jobv = StringValueCStr(rb_jobv)[0];
- tol = NUM2DBL(rb_tol);
- eps = NUM2DBL(rb_eps);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of v");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = m;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_sva_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sva_out__ = NA_PTR_TYPE(rb_sva_out__, doublereal*);
- MEMCPY(sva_out__, sva, doublereal, NA_TOTAL(rb_sva));
- rb_sva = rb_sva_out__;
- sva = sva_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- work = ALLOC_N(doublereal, (lwork));
-
- dgsvj1_(&jobv, &m, &n, &n1, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_d, rb_sva, rb_v);
-}
-
-void
-init_lapack_dgsvj1(VALUE mLapack){
- rb_define_module_function(mLapack, "dgsvj1", rb_dgsvj1, -1);
-}
diff --git a/dgtcon.c b/dgtcon.c
deleted file mode 100644
index 8e7e571..0000000
--- a/dgtcon.c
+++ /dev/null
@@ -1,105 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgtcon_(char *norm, integer *n, doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgtcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_du2;
- doublereal *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dgtcon( norm, dl, d, du, du2, ipiv, anorm)\n or\n NumRu::Lapack.dgtcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGTCON estimates the reciprocal of the condition number of a real\n* tridiagonal matrix A using the LU factorization as computed by\n* DGTTRF.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by DGTTRF.\n*\n* D (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION 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) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_anorm = argv[6];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_DFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- work = ALLOC_N(doublereal, (2*n));
- iwork = ALLOC_N(integer, (n));
-
- dgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dgtcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dgtcon", rb_dgtcon, -1);
-}
diff --git a/dgtrfs.c b/dgtrfs.c
deleted file mode 100644
index 2885640..0000000
--- a/dgtrfs.c
+++ /dev/null
@@ -1,190 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgtrfs_(char *trans, integer *n, integer *nrhs, doublereal *dl, doublereal *d, doublereal *du, doublereal *dlf, doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgtrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_dlf;
- doublereal *dlf;
- VALUE rb_df;
- doublereal *df;
- VALUE rb_duf;
- doublereal *duf;
- VALUE rb_du2;
- doublereal *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)\n or\n NumRu::Lapack.dgtrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTRFS( 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* DGTRFS 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by DGTTRF.\n*\n* DF (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGTTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_dlf = argv[4];
- rb_df = argv[5];
- rb_duf = argv[6];
- rb_du2 = argv[7];
- rb_ipiv = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (6th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_DFLOAT)
- rb_df = na_change_type(rb_df, NA_DFLOAT);
- df = NA_PTR_TYPE(rb_df, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_DFLOAT)
- rb_dlf = na_change_type(rb_dlf, NA_DFLOAT);
- dlf = NA_PTR_TYPE(rb_dlf, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_DFLOAT)
- rb_duf = na_change_type(rb_duf, NA_DFLOAT);
- duf = NA_PTR_TYPE(rb_duf, doublereal*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_DFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dgtrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dgtrfs", rb_dgtrfs, -1);
-}
diff --git a/dgtsv.c b/dgtsv.c
deleted file mode 100644
index 6af0639..0000000
--- a/dgtsv.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgtsv_(integer *n, integer *nrhs, doublereal *dl, doublereal *d, doublereal *du, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dgtsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- doublereal *dl_out__;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_du_out__;
- doublereal *du_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.dgtsv( dl, d, du, b)\n or\n NumRu::Lapack.dgtsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an n by n tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-2) elements of the\n* second super-diagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N by NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, doublereal*);
- MEMCPY(dl_out__, dl, doublereal, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, doublereal*);
- MEMCPY(du_out__, du, doublereal, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_dl, rb_d, rb_du, rb_b);
-}
-
-void
-init_lapack_dgtsv(VALUE mLapack){
- rb_define_module_function(mLapack, "dgtsv", rb_dgtsv, -1);
-}
diff --git a/dgtsvx.c b/dgtsvx.c
deleted file mode 100644
index f8b248f..0000000
--- a/dgtsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgtsvx_(char *fact, char *trans, integer *n, integer *nrhs, doublereal *dl, doublereal *d, doublereal *du, doublereal *dlf, doublereal *df, doublereal *duf, doublereal *du2, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dgtsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_dlf;
- doublereal *dlf;
- VALUE rb_df;
- doublereal *df;
- VALUE rb_duf;
- doublereal *duf;
- VALUE rb_du2;
- doublereal *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_dlf_out__;
- doublereal *dlf_out__;
- VALUE rb_df_out__;
- doublereal *df_out__;
- VALUE rb_duf_out__;
- doublereal *duf_out__;
- VALUE rb_du2_out__;
- doublereal *du2_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.dgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)\n or\n NumRu::Lapack.dgtsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGTSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B or A**T * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored\n* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n* will not be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of A.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input or output) DOUBLE PRECISION array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by DGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) DOUBLE PRECISION array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) DOUBLE PRECISION array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by DGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_dlf = argv[5];
- rb_df = argv[6];
- rb_duf = argv[7];
- rb_du2 = argv[8];
- rb_ipiv = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (7th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_DFLOAT)
- rb_df = na_change_type(rb_df, NA_DFLOAT);
- df = NA_PTR_TYPE(rb_df, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_DFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_DFLOAT)
- rb_dlf = na_change_type(rb_dlf, NA_DFLOAT);
- dlf = NA_PTR_TYPE(rb_dlf, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_DFLOAT)
- rb_duf = na_change_type(rb_duf, NA_DFLOAT);
- duf = NA_PTR_TYPE(rb_duf, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dlf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dlf_out__ = NA_PTR_TYPE(rb_dlf_out__, doublereal*);
- MEMCPY(dlf_out__, dlf, doublereal, NA_TOTAL(rb_dlf));
- rb_dlf = rb_dlf_out__;
- dlf = dlf_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, doublereal*);
- MEMCPY(df_out__, df, doublereal, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_duf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- duf_out__ = NA_PTR_TYPE(rb_duf_out__, doublereal*);
- MEMCPY(duf_out__, duf, doublereal, NA_TOTAL(rb_duf));
- rb_duf = rb_duf_out__;
- duf = duf_out__;
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- du2_out__ = NA_PTR_TYPE(rb_du2_out__, doublereal*);
- MEMCPY(du2_out__, du2, doublereal, NA_TOTAL(rb_du2));
- rb_du2 = rb_du2_out__;
- du2 = du2_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_dlf, rb_df, rb_duf, rb_du2, rb_ipiv);
-}
-
-void
-init_lapack_dgtsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dgtsvx", rb_dgtsvx, -1);
-}
diff --git a/dgttrf.c b/dgttrf.c
deleted file mode 100644
index 9e6a810..0000000
--- a/dgttrf.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgttrf_(integer *n, doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, integer *ipiv, integer *info);
-
-static VALUE
-rb_dgttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_du2;
- doublereal *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- doublereal *dl_out__;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_du_out__;
- doublereal *du_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.dgttrf( dl, d, du)\n or\n NumRu::Lapack.dgttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGTTRF computes an LU factorization of a real tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) DOUBLE PRECISION array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- du2 = NA_PTR_TYPE(rb_du2, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, doublereal*);
- MEMCPY(dl_out__, dl, doublereal, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, doublereal*);
- MEMCPY(du_out__, du, doublereal, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
-
- dgttrf_(&n, dl, d, du, du2, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_du2, rb_ipiv, rb_info, rb_dl, rb_d, rb_du);
-}
-
-void
-init_lapack_dgttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dgttrf", rb_dgttrf, -1);
-}
diff --git a/dgttrs.c b/dgttrs.c
deleted file mode 100644
index e33da00..0000000
--- a/dgttrs.c
+++ /dev/null
@@ -1,118 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgttrs_(char *trans, integer *n, integer *nrhs, doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dgttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_du2;
- doublereal *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dgttrs( trans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.dgttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGTTRS solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by DGTTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DGTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_DFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dgttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dgttrs", rb_dgttrs, -1);
-}
diff --git a/dgtts2.c b/dgtts2.c
deleted file mode 100644
index f6d7f0c..0000000
--- a/dgtts2.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dgtts2_(integer *itrans, integer *n, integer *nrhs, doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, integer *ipiv, doublereal *b, integer *ldb);
-
-static VALUE
-rb_dgtts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itrans;
- integer itrans;
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_du2;
- doublereal *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.dgtts2( itrans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.dgtts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* DGTTS2 solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by DGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A'* X = B (Transpose)\n* = 2: A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IP, J\n DOUBLE PRECISION TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itrans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- itrans = NUM2INT(rb_itrans);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_DFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_dgtts2(VALUE mLapack){
- rb_define_module_function(mLapack, "dgtts2", rb_dgtts2, -1);
-}
diff --git a/dhgeqz.c b/dhgeqz.c
deleted file mode 100644
index 02a3265..0000000
--- a/dhgeqz.c
+++ /dev/null
@@ -1,188 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dhgeqz_(char *job, char *compq, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h, integer *ldh, doublereal *t, integer *ldt, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *q, integer *ldq, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dhgeqz(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_t_out__;
- doublereal *t_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer ldh;
- integer n;
- integer ldt;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.dhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)\n or\n NumRu::Lapack.dhgeqz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the double-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a real matrix pair (A,B):\n*\n* A = Q1*H*Z1**T, B = Q1*T*Z1**T,\n*\n* as computed by DGGHRD.\n*\n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**T, T = Q*P*Z**T,\n* \n* where Q and Z are orthogonal matrices, P is an upper triangular\n* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n* diagonal blocks.\n*\n* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n* eigenvalues.\n*\n* Additionally, the 2-by-2 upper triangular diagonal blocks of P\n* corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n* P(j,j) > 0, and P(j+1,j+1) > 0.\n*\n* Optionally, the orthogonal matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced\n* the matrix pair (A,B) to generalized upper Hessenberg form, then the\n* output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n* generalized Schur factorization of (A,B):\n*\n* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n* complex and beta real.\n* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n* generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* Real eigenvalues can be read directly from the generalized Schur\n* form: \n* alpha = S(i,i), beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Compute eigenvalues and the Schur form. \n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper quasi-triangular\n* matrix S from the generalized Schur factorization;\n* 2-by-2 diagonal blocks (corresponding to complex conjugate\n* pairs of eigenvalues) are returned in standard form, with\n* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n* If JOB = 'E', the diagonal blocks of H match those of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization;\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n* are reduced to positive diagonal form, i.e., if H(j+1,j) is\n* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n* T(j+1,j+1) > 0.\n* If JOB = 'E', the diagonal blocks of T match those of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n* of left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of\n* right Schur vectors of (H,T), and if COMPZ = 'V', the\n* orthogonal matrix of right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* Iteration counters:\n*\n* JITER -- counts iterations.\n* IITER -- counts iterations run since ILAST was last\n* changed. This is therefore reset only when a 1-by-1 or\n* 2-by-2 block deflates off the bottom.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_compz = argv[2];
- rb_ilo = argv[3];
- rb_ihi = argv[4];
- rb_h = argv[5];
- rb_t = argv[6];
- rb_q = argv[7];
- rb_z = argv[8];
- rb_lwork = argv[9];
-
- ilo = NUM2INT(rb_ilo);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (8th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of z");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of z");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublereal*);
- MEMCPY(t_out__, t, doublereal, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dhgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alphar, alphai, beta, q, &ldq, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_work, rb_info, rb_h, rb_t, rb_q, rb_z);
-}
-
-void
-init_lapack_dhgeqz(VALUE mLapack){
- rb_define_module_function(mLapack, "dhgeqz", rb_dhgeqz, -1);
-}
diff --git a/dhsein.c b/dhsein.c
deleted file mode 100644
index cda20fd..0000000
--- a/dhsein.c
+++ /dev/null
@@ -1,186 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dhsein_(char *side, char *eigsrc, char *initv, logical *select, integer *n, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m, doublereal *work, integer *ifaill, integer *ifailr, integer *info);
-
-static VALUE
-rb_dhsein(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_eigsrc;
- char eigsrc;
- VALUE rb_initv;
- char initv;
- VALUE rb_select;
- logical *select;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_ifaill;
- integer *ifaill;
- VALUE rb_ifailr;
- integer *ifailr;
- VALUE rb_info;
- integer info;
- VALUE rb_select_out__;
- logical *select_out__;
- VALUE rb_wr_out__;
- doublereal *wr_out__;
- VALUE rb_vl_out__;
- doublereal *vl_out__;
- VALUE rb_vr_out__;
- doublereal *vr_out__;
- doublereal *work;
-
- integer n;
- integer ldh;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.dhsein( side, eigsrc, initv, select, h, wr, wi, vl, vr)\n or\n NumRu::Lapack.dhsein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* DHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a real upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in (WR,WI):\n* = 'Q': the eigenvalues were found using DHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows DHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, DHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* real eigenvector corresponding to a real eigenvalue WR(j),\n* SELECT(j) must be set to .TRUE.. To select the complex\n* eigenvector corresponding to a complex eigenvalue\n* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n* .FALSE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) DOUBLE PRECISION array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input/output) DOUBLE PRECISION array, dimension (N)\n* WI (input) DOUBLE PRECISION array, dimension (N)\n* On entry, the real and imaginary parts of the eigenvalues of\n* H; a complex conjugate pair of eigenvalues must be stored in\n* consecutive elements of WR and WI.\n* On exit, WR may have been altered since close eigenvalues\n* are perturbed slightly in searching for independent\n* eigenvectors.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors; each selected real eigenvector\n* occupies one column and each selected complex eigenvector\n* occupies two columns.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VL hold a complex eigenvector, then IFAILL(i) and\n* IFAILL(i+1) are set to the same value.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VR hold a complex eigenvector, then IFAILR(i) and\n* IFAILR(i+1) are set to the same value.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_side = argv[0];
- rb_eigsrc = argv[1];
- rb_initv = argv[2];
- rb_select = argv[3];
- rb_h = argv[4];
- rb_wr = argv[5];
- rb_wi = argv[6];
- rb_vl = argv[7];
- rb_vr = argv[8];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (8th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (8th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- side = StringValueCStr(rb_side)[0];
- eigsrc = StringValueCStr(rb_eigsrc)[0];
- if (!NA_IsNArray(rb_wr))
- rb_raise(rb_eArgError, "wr (6th argument) must be NArray");
- if (NA_RANK(rb_wr) != 1)
- rb_raise(rb_eArgError, "rank of wr (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_wr);
- if (NA_TYPE(rb_wr) != NA_DFLOAT)
- rb_wr = na_change_type(rb_wr, NA_DFLOAT);
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (9th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DFLOAT)
- rb_vr = na_change_type(rb_vr, NA_DFLOAT);
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- initv = StringValueCStr(rb_initv)[0];
- if (!NA_IsNArray(rb_wi))
- rb_raise(rb_eArgError, "wi (7th argument) must be NArray");
- if (NA_RANK(rb_wi) != 1)
- rb_raise(rb_eArgError, "rank of wi (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wi) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of wi must be the same as shape 0 of wr");
- if (NA_TYPE(rb_wi) != NA_DFLOAT)
- rb_wi = na_change_type(rb_wi, NA_DFLOAT);
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of wr");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 0 of wr");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifaill = NA_PTR_TYPE(rb_ifaill, integer*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifailr = NA_PTR_TYPE(rb_ifailr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- select_out__ = NA_PTR_TYPE(rb_select_out__, logical*);
- MEMCPY(select_out__, select, logical, NA_TOTAL(rb_select));
- rb_select = rb_select_out__;
- select = select_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_wr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr_out__ = NA_PTR_TYPE(rb_wr_out__, doublereal*);
- MEMCPY(wr_out__, wr, doublereal, NA_TOTAL(rb_wr));
- rb_wr = rb_wr_out__;
- wr = wr_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublereal*);
- MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, doublereal*);
- MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(doublereal, ((n+2)*n));
-
- dhsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, wr, wi, vl, &ldvl, vr, &ldvr, &mm, &m, work, ifaill, ifailr, &info);
-
- free(work);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_ifaill, rb_ifailr, rb_info, rb_select, rb_wr, rb_vl, rb_vr);
-}
-
-void
-init_lapack_dhsein(VALUE mLapack){
- rb_define_module_function(mLapack, "dhsein", rb_dhsein, -1);
-}
diff --git a/dhseqr.c b/dhseqr.c
deleted file mode 100644
index 988c174..0000000
--- a/dhseqr.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dhseqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.dhseqr( job, compz, ilo, ihi, h, z, ldz, lwork)\n or\n NumRu::Lapack.dhseqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an orthogonal matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to DGEBAL, and then passed to DGEHRD\n* when the matrix output by DGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', then H contains the\n* upper quasi-triangular matrix T from the Schur decomposition\n* (the Schur form); 2-by-2 diagonal blocks (corresponding to\n* complex conjugate pairs of eigenvalues) are returned in\n* standard form, with H(i,i) = H(i+1,i+1) and\n* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n* contents of H are unspecified on exit. (The output value of\n* H when INFO.GT.0 is given under the description of INFO\n* below.)\n*\n* Unlike earlier versions of DHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues. If two eigenvalues are computed as a complex\n* conjugate pair, they are stored in consecutive elements of\n* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n* the same order as on the diagonal of the Schur form returned\n* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the orthogonal matrix generated by DORGHR\n* after the call to DGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then DHSEQR does a workspace query.\n* In this case, DHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, DHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The DLAHQR vs DLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* DLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_z = argv[5];
- rb_ldz = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- ldz = NUM2INT(rb_ldz);
- compz = StringValueCStr(rb_compz)[0];
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (lsame_(&compz,"N") ? 0 : n))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
- if (NA_SHAPE0(rb_z) != (lsame_(&compz,"N") ? 0 : ldz))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = lsame_(&compz,"N") ? 0 : ldz;
- shape[1] = lsame_(&compz,"N") ? 0 : n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dhseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_wr, rb_wi, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_dhseqr(VALUE mLapack){
- rb_define_module_function(mLapack, "dhseqr", rb_dhseqr, -1);
-}
diff --git a/disnan.c b/disnan.c
deleted file mode 100644
index 0ab8bd1..0000000
--- a/disnan.c
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "rb_lapack.h"
-
-extern logical disnan_(doublereal *din);
-
-static VALUE
-rb_disnan(int argc, VALUE *argv, VALUE self){
- VALUE rb_din;
- doublereal din;
- VALUE rb___out__;
- logical __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.disnan( din)\n or\n NumRu::Lapack.disnan # print help\n\n\nFORTRAN MANUAL\n LOGICAL FUNCTION DISNAN( DIN )\n\n* Purpose\n* =======\n*\n* DISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n* otherwise. To be replaced by the Fortran 2003 intrinsic in the\n* future.\n*\n\n* Arguments\n* =========\n*\n* DIN (input) DOUBLE PRECISION\n* Input to test for NaN.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL DLAISNAN\n EXTERNAL DLAISNAN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_din = argv[0];
-
- din = NUM2DBL(rb_din);
-
- __out__ = disnan_(&din);
-
- rb___out__ = __out__ ? Qtrue : Qfalse;
- return rb___out__;
-}
-
-void
-init_lapack_disnan(VALUE mLapack){
- rb_define_module_function(mLapack, "disnan", rb_disnan, -1);
-}
diff --git a/dla_gbamv.c b/dla_gbamv.c
deleted file mode 100644
index 315077d..0000000
--- a/dla_gbamv.c
+++ /dev/null
@@ -1,110 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_gbamv_(integer *trans, integer *m, integer *n, integer *kl, integer *ku, doublereal *alpha, doublereal *ab, integer *ldab, doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy);
-
-static VALUE
-rb_dla_gbamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb_m;
- integer m;
- VALUE rb_n;
- integer n;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer ldab;
- integer lda;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.dla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy)\n or\n NumRu::Lapack.dla_gbamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_n = argv[2];
- rb_kl = argv[3];
- rb_ku = argv[4];
- rb_alpha = argv[5];
- rb_ab = argv[6];
- rb_x = argv[7];
- rb_incx = argv[8];
- rb_beta = argv[9];
- rb_y = argv[10];
- rb_incy = argv[11];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (7th argument) must be NArray");
- if (NA_RANK(rb_ab) != 1)
- rb_raise(rb_eArgError, "rank of ab (7th argument) must be %d", 1);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- trans = NUM2INT(rb_trans);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- n = NUM2INT(rb_n);
- alpha = NUM2DBL(rb_alpha);
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- beta = NUM2DBL(rb_beta);
- lda = max( 1, m );
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (11th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_dla_gbamv(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_gbamv", rb_dla_gbamv, -1);
-}
diff --git a/dla_gbrcond.c b/dla_gbrcond.c
deleted file mode 100644
index f91374f..0000000
--- a/dla_gbrcond.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_gbrcond_(char *trans, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, integer *cmode, doublereal *c, integer *info, doublereal *work, integer *iwork);
-
-static VALUE
-rb_dla_gbrcond(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork)\n or\n NumRu::Lapack.dla_gbrcond # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (5*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J, KD, KE\n DOUBLE PRECISION AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_cmode = argv[6];
- rb_c = argv[7];
- rb_work = argv[8];
- rb_iwork = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (10th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- ku = NUM2INT(rb_ku);
- cmode = NUM2INT(rb_cmode);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (9th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (5*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 5*n);
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
-
- __out__ = dla_gbrcond_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_dla_gbrcond(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_gbrcond", rb_dla_gbrcond, -1);
-}
diff --git a/dla_gbrfsx_extended.c b/dla_gbrfsx_extended.c
deleted file mode 100644
index a5838f7..0000000
--- a/dla_gbrfsx_extended.c
+++ /dev/null
@@ -1,279 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_gbrfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, logical *colequ, doublereal *c, doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *err_bnds_norm, doublereal *err_bnds_comp, doublereal *res, doublereal *ayb, doublereal *dy, doublereal *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_dla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ldafb;
- integer ldafb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_res;
- doublereal *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublereal *dy;
- VALUE rb_y_tail;
- doublereal *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublereal *y_out__;
- VALUE rb_err_bnds_norm_out__;
- doublereal *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- doublereal *err_bnds_comp_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_norms;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ldafb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.dla_gbrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* DLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGBTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension \n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 23)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 23)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ldafb = argv[6];
- rb_ipiv = argv[7];
- rb_colequ = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
- rb_y = argv[11];
- rb_err_bnds_norm = argv[12];
- rb_err_bnds_comp = argv[13];
- rb_res = argv[14];
- rb_ayb = argv[15];
- rb_dy = argv[16];
- rb_y_tail = argv[17];
- rb_rcond = argv[18];
- rb_ithresh = argv[19];
- rb_rthresh = argv[20];
- rb_dz_ub = argv[21];
- rb_ignore_cwise = argv[22];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (15th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (15th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DFLOAT)
- rb_res = na_change_type(rb_res, NA_DFLOAT);
- res = NA_PTR_TYPE(rb_res, doublereal*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (8th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of res");
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (n))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", n);
- n = ldab;
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (12th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be n");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (18th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be n");
- if (NA_TYPE(rb_y_tail) != NA_DFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_DFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublereal*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (16th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be n");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (13th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (13th argument) must be %d", 2);
- n_norms = NA_SHAPE1(rb_err_bnds_norm);
- if (n_norms != (3))
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be %d", 3);
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_DFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_DFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (14th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_comp) != n_norms)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_DFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_DFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be n");
- if (NA_SHAPE0(rb_afb) != ldab)
- rb_raise(rb_eRuntimeError, "shape 0 of afb must be the same as shape 0 of ab");
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- n_norms = 3;
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (17th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (17th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be n");
- if (NA_TYPE(rb_dy) != NA_DFLOAT)
- rb_dy = na_change_type(rb_dy, NA_DFLOAT);
- dy = NA_PTR_TYPE(rb_dy, doublereal*);
- prec_type = NUM2INT(rb_prec_type);
- ldab = n;
- ldafb = n;
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, doublereal*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, doublereal*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- dla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_dla_gbrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_gbrfsx_extended", rb_dla_gbrfsx_extended, -1);
-}
diff --git a/dla_gbrpvgrw.c b/dla_gbrpvgrw.c
deleted file mode 100644
index 1c8f7ac..0000000
--- a/dla_gbrpvgrw.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_gbrpvgrw_(integer *n, integer *kl, integer *ku, integer *ncols, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb);
-
-static VALUE
-rb_dla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb___out__;
- doublereal __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_gbrpvgrw( kl, ku, ncols, ab, afb)\n or\n NumRu::Lapack.dla_gbrpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* DLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ncols = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- ku = NUM2INT(rb_ku);
-
- __out__ = dla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dla_gbrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_gbrpvgrw", rb_dla_gbrpvgrw, -1);
-}
diff --git a/dla_geamv.c b/dla_geamv.c
deleted file mode 100644
index 6ced5b8..0000000
--- a/dla_geamv.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_geamv_(integer *trans, integer *m, integer *n, doublereal *alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy);
-
-static VALUE
-rb_dla_geamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.dla_geamv( trans, m, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.dla_geamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y - DOUBLE PRECISION\n* Array of DIMENSION at least\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_a = argv[3];
- rb_x = argv[4];
- rb_incx = argv[5];
- rb_beta = argv[6];
- rb_y = argv[7];
- rb_incy = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1, m)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, m));
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- trans = NUM2INT(rb_trans);
- m = NUM2INT(rb_m);
- alpha = NUM2DBL(rb_alpha);
- beta = NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1, m);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (lsame_(&trans,"N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", lsame_(&trans,"N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy));
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = lsame_(&trans,"N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy);
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_dla_geamv(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_geamv", rb_dla_geamv, -1);
-}
diff --git a/dla_gercond.c b/dla_gercond.c
deleted file mode 100644
index 19fdce0..0000000
--- a/dla_gercond.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_gercond_(char *trans, integer *n, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, integer *cmode, doublereal *c, integer *info, doublereal *work, integer *iwork);
-
-static VALUE
-rb_dla_gercond(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_gercond( trans, a, af, ipiv, cmode, c, work, iwork)\n or\n NumRu::Lapack.dla_gercond # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_cmode = argv[4];
- rb_c = argv[5];
- rb_work = argv[6];
- rb_iwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- cmode = NUM2INT(rb_cmode);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (3*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
-
- __out__ = dla_gercond_(&trans, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_dla_gercond(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_gercond", rb_dla_gercond, -1);
-}
diff --git a/dla_gerfsx_extended.c b/dla_gerfsx_extended.c
deleted file mode 100644
index 0b50f0f..0000000
--- a/dla_gerfsx_extended.c
+++ /dev/null
@@ -1,263 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_gerfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c, doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *errs_n, doublereal *errs_c, doublereal *res, doublereal *ayb, doublereal *dy, doublereal *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_dla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_errs_n;
- doublereal *errs_n;
- VALUE rb_errs_c;
- doublereal *errs_c;
- VALUE rb_res;
- doublereal *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublereal *dy;
- VALUE rb_y_tail;
- doublereal *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublereal *y_out__;
- VALUE rb_errs_n_out__;
- doublereal *errs_n_out__;
- VALUE rb_errs_c_out__;
- doublereal *errs_c_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_norms;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, errs_n, errs_c = NumRu::Lapack.dla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.dla_gerfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* DLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 20)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_errs_n = argv[9];
- rb_errs_c = argv[10];
- rb_res = argv[11];
- rb_ayb = argv[12];
- rb_dy = argv[13];
- rb_y_tail = argv[14];
- rb_rcond = argv[15];
- rb_ithresh = argv[16];
- rb_rthresh = argv[17];
- rb_dz_ub = argv[18];
- rb_ignore_cwise = argv[19];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (12th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DFLOAT)
- rb_res = na_change_type(rb_res, NA_DFLOAT);
- res = NA_PTR_TYPE(rb_res, doublereal*);
- if (!NA_IsNArray(rb_errs_c))
- rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
- if (NA_RANK(rb_errs_c) != 2)
- rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
- n_norms = NA_SHAPE1(rb_errs_c);
- if (n_norms != (3))
- rb_raise(rb_eRuntimeError, "shape 1 of errs_c must be %d", 3);
- nrhs = NA_SHAPE0(rb_errs_c);
- if (NA_TYPE(rb_errs_c) != NA_DFLOAT)
- rb_errs_c = na_change_type(rb_errs_c, NA_DFLOAT);
- errs_c = NA_PTR_TYPE(rb_errs_c, doublereal*);
- if (!NA_IsNArray(rb_errs_n))
- rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
- if (NA_RANK(rb_errs_n) != 2)
- rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_errs_n) != n_norms)
- rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be the same as shape 1 of errs_c");
- if (NA_SHAPE0(rb_errs_n) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 0 of errs_c");
- if (NA_TYPE(rb_errs_n) != NA_DFLOAT)
- rb_errs_n = na_change_type(rb_errs_n, NA_DFLOAT);
- errs_n = NA_PTR_TYPE(rb_errs_n, doublereal*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of errs_c");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 0 of errs_c");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_DFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- n_norms = 3;
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DFLOAT)
- rb_dy = na_change_type(rb_dy, NA_DFLOAT);
- dy = NA_PTR_TYPE(rb_dy, doublereal*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_errs_n_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- errs_n_out__ = NA_PTR_TYPE(rb_errs_n_out__, doublereal*);
- MEMCPY(errs_n_out__, errs_n, doublereal, NA_TOTAL(rb_errs_n));
- rb_errs_n = rb_errs_n_out__;
- errs_n = errs_n_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_errs_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- errs_c_out__ = NA_PTR_TYPE(rb_errs_c_out__, doublereal*);
- MEMCPY(errs_c_out__, errs_c, doublereal, NA_TOTAL(rb_errs_c));
- rb_errs_c = rb_errs_c_out__;
- errs_c = errs_c_out__;
-
- dla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_errs_n, rb_errs_c);
-}
-
-void
-init_lapack_dla_gerfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_gerfsx_extended", rb_dla_gerfsx_extended, -1);
-}
diff --git a/dla_lin_berr.c b/dla_lin_berr.c
deleted file mode 100644
index 3112e5e..0000000
--- a/dla_lin_berr.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_lin_berr_(integer *n, integer *nz, integer *nrhs, doublereal *res, doublereal *ayb, doublereal *berr);
-
-static VALUE
-rb_dla_lin_berr(int argc, VALUE *argv, VALUE self){
- VALUE rb_nz;
- integer nz;
- VALUE rb_res;
- doublereal *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_berr;
- doublereal *berr;
-
- integer n;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr = NumRu::Lapack.dla_lin_berr( nz, res, ayb)\n or\n NumRu::Lapack.dla_lin_berr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* DLA_LIN_BERR computes component-wise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the component-wise absolute value of the matrix\n* or vector Z.\n*\n\n* Arguments\n* ==========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see dla_gerfsx_extended.f).\n* \n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The component-wise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION TMP\n INTEGER I, J\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. External Functions ..\n EXTERNAL DLAMCH\n DOUBLE PRECISION DLAMCH\n DOUBLE PRECISION SAFE1\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_nz = argv[0];
- rb_res = argv[1];
- rb_ayb = argv[2];
-
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (2th argument) must be NArray");
- if (NA_RANK(rb_res) != 2)
- rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_res);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DFLOAT)
- rb_res = na_change_type(rb_res, NA_DFLOAT);
- res = NA_PTR_TYPE(rb_res, doublereal*);
- nz = NUM2INT(rb_nz);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 2)
- rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ayb) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of ayb must be the same as shape 1 of res");
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
-
- dla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
-
- return rb_berr;
-}
-
-void
-init_lapack_dla_lin_berr(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_lin_berr", rb_dla_lin_berr, -1);
-}
diff --git a/dla_porcond.c b/dla_porcond.c
deleted file mode 100644
index 37d3fa2..0000000
--- a/dla_porcond.c
+++ /dev/null
@@ -1,103 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_porcond_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *cmode, doublereal *c, integer *info, doublereal *work, integer *iwork);
-
-static VALUE
-rb_dla_porcond(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_porcond( uplo, a, af, cmode, c, work, iwork)\n or\n NumRu::Lapack.dla_porcond # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, TMP\n LOGICAL UP\n* ..\n* .. Array Arguments ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER IDAMAX\n EXTERNAL LSAME, IDAMAX\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_cmode = argv[3];
- rb_c = argv[4];
- rb_work = argv[5];
- rb_iwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- cmode = NUM2INT(rb_cmode);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (7th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of a");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (3*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
-
- __out__ = dla_porcond_(&uplo, &n, a, &lda, af, &ldaf, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_dla_porcond(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_porcond", rb_dla_porcond, -1);
-}
diff --git a/dla_porfsx_extended.c b/dla_porfsx_extended.c
deleted file mode 100644
index 9b3aad4..0000000
--- a/dla_porfsx_extended.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_porfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, logical *colequ, doublereal *c, doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *err_bnds_norm, doublereal *err_bnds_comp, doublereal *res, doublereal *ayb, doublereal *dy, doublereal *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_dla_porfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_res;
- doublereal *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublereal *dy;
- VALUE rb_y_tail;
- doublereal *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublereal *y_out__;
- VALUE rb_err_bnds_norm_out__;
- doublereal *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- doublereal *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.dla_porfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* DLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 20)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_colequ = argv[4];
- rb_c = argv[5];
- rb_b = argv[6];
- rb_y = argv[7];
- rb_n_norms = argv[8];
- rb_err_bnds_norm = argv[9];
- rb_err_bnds_comp = argv[10];
- rb_res = argv[11];
- rb_ayb = argv[12];
- rb_dy = argv[13];
- rb_y_tail = argv[14];
- rb_rcond = argv[15];
- rb_ithresh = argv[16];
- rb_rthresh = argv[17];
- rb_dz_ub = argv[18];
- rb_ignore_cwise = argv[19];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (12th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DFLOAT)
- rb_res = na_change_type(rb_res, NA_DFLOAT);
- res = NA_PTR_TYPE(rb_res, doublereal*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_DFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_DFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_DFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DFLOAT)
- rb_dy = na_change_type(rb_dy, NA_DFLOAT);
- dy = NA_PTR_TYPE(rb_dy, doublereal*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_DFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_DFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, doublereal*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, doublereal*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- dla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_dla_porfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_porfsx_extended", rb_dla_porfsx_extended, -1);
-}
diff --git a/dla_porpvgrw.c b/dla_porpvgrw.c
deleted file mode 100644
index 14a50a6..0000000
--- a/dla_porpvgrw.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_porpvgrw_(char *uplo, integer *ncols, doublereal *a, integer *lda, doublereal *af, integer *ldaf, doublereal *work);
-
-static VALUE
-rb_dla_porpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_work;
- doublereal *work;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_porpvgrw( uplo, ncols, a, af, work)\n or\n NumRu::Lapack.dla_porpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* DLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) DOUBLE PRECISION array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, DLASET\n LOGICAL LSAME\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ncols = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_work = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ncols = NUM2INT(rb_ncols);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (5th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
-
- __out__ = dla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dla_porpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_porpvgrw", rb_dla_porpvgrw, -1);
-}
diff --git a/dla_rpvgrw.c b/dla_rpvgrw.c
deleted file mode 100644
index ff9d1aa..0000000
--- a/dla_rpvgrw.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_rpvgrw_(integer *n, integer *ncols, doublereal *a, integer *lda, doublereal *af, integer *ldaf);
-
-static VALUE
-rb_dla_rpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_rpvgrw( ncols, a, af)\n or\n NumRu::Lapack.dla_rpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n* \n* DLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ncols = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
-
- __out__ = dla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dla_rpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_rpvgrw", rb_dla_rpvgrw, -1);
-}
diff --git a/dla_syamv.c b/dla_syamv.c
deleted file mode 100644
index 9728a3d..0000000
--- a/dla_syamv.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_syamv_(integer *uplo, integer *n, doublereal *alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy);
-
-static VALUE
-rb_dla_syamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- integer uplo;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.dla_syamv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.dla_syamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = NUM2INT(rb_uplo);
- alpha = NUM2DBL(rb_alpha);
- beta = NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_dla_syamv(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_syamv", rb_dla_syamv, -1);
-}
diff --git a/dla_syrcond.c b/dla_syrcond.c
deleted file mode 100644
index 5f131dc..0000000
--- a/dla_syrcond.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_syrcond_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, integer *cmode, doublereal *c, integer *info, doublereal *work, integer *iwork);
-
-static VALUE
-rb_dla_syrcond(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork)\n or\n NumRu::Lapack.dla_syrcond # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER NORMIN\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, SMLNUM, TMP\n LOGICAL UP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER IDAMAX\n DOUBLE PRECISION DLAMCH\n EXTERNAL LSAME, IDAMAX, DLAMCH\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA, DSYTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_cmode = argv[4];
- rb_c = argv[5];
- rb_work = argv[6];
- rb_iwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- cmode = NUM2INT(rb_cmode);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (3*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
-
- __out__ = dla_syrcond_(&uplo, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_dla_syrcond(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_syrcond", rb_dla_syrcond, -1);
-}
diff --git a/dla_syrfsx_extended.c b/dla_syrfsx_extended.c
deleted file mode 100644
index a614336..0000000
--- a/dla_syrfsx_extended.c
+++ /dev/null
@@ -1,264 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_syrfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c, doublereal *b, integer *ldb, doublereal *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *err_bnds_norm, doublereal *err_bnds_comp, doublereal *res, doublereal *ayb, doublereal *dy, doublereal *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_dla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_res;
- doublereal *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublereal *dy;
- VALUE rb_y_tail;
- doublereal *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublereal *y_out__;
- VALUE rb_err_bnds_norm_out__;
- doublereal *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- doublereal *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.dla_syrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* DLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_n_norms = argv[9];
- rb_err_bnds_norm = argv[10];
- rb_err_bnds_comp = argv[11];
- rb_res = argv[12];
- rb_ayb = argv[13];
- rb_dy = argv[14];
- rb_y_tail = argv[15];
- rb_rcond = argv[16];
- rb_ithresh = argv[17];
- rb_rthresh = argv[18];
- rb_dz_ub = argv[19];
- rb_ignore_cwise = argv[20];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (13th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DFLOAT)
- rb_res = na_change_type(rb_res, NA_DFLOAT);
- res = NA_PTR_TYPE(rb_res, doublereal*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_DFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_DFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_DFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DFLOAT)
- rb_dy = na_change_type(rb_dy, NA_DFLOAT);
- dy = NA_PTR_TYPE(rb_dy, doublereal*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_DFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_DFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, doublereal*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, doublereal*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- dla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_dla_syrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_syrfsx_extended", rb_dla_syrfsx_extended, -1);
-}
diff --git a/dla_syrpvgrw.c b/dla_syrpvgrw.c
deleted file mode 100644
index 29cba9c..0000000
--- a/dla_syrpvgrw.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dla_syrpvgrw_(char *uplo, integer *n, integer *info, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, doublereal *work);
-
-static VALUE
-rb_dla_syrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_info;
- integer info;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublereal *work;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_syrpvgrw( uplo, info, a, af, ipiv, work)\n or\n NumRu::Lapack.dla_syrpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* DLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from DSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, DLASET\n LOGICAL LSAME\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_info = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_work = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- info = NUM2INT(rb_info);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DFLOAT)
- rb_work = na_change_type(rb_work, NA_DFLOAT);
- work = NA_PTR_TYPE(rb_work, doublereal*);
-
- __out__ = dla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dla_syrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_syrpvgrw", rb_dla_syrpvgrw, -1);
-}
diff --git a/dla_wwaddw.c b/dla_wwaddw.c
deleted file mode 100644
index fde989d..0000000
--- a/dla_wwaddw.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dla_wwaddw_(integer *n, doublereal *x, doublereal *y, doublereal *w);
-
-static VALUE
-rb_dla_wwaddw(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublereal *x;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.dla_wwaddw( x, y, w)\n or\n NumRu::Lapack.dla_wwaddw # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* DLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) DOUBLE PRECISION array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION S\n INTEGER I\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_w = argv[2];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (2th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of w");
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dla_wwaddw_(&n, x, y, w);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_dla_wwaddw(VALUE mLapack){
- rb_define_module_function(mLapack, "dla_wwaddw", rb_dla_wwaddw, -1);
-}
diff --git a/dlabad.c b/dlabad.c
deleted file mode 100644
index 528a7e5..0000000
--- a/dlabad.c
+++ /dev/null
@@ -1,35 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlabad_(doublereal *small, doublereal *large);
-
-static VALUE
-rb_dlabad(int argc, VALUE *argv, VALUE self){
- VALUE rb_small;
- doublereal small;
- VALUE rb_large;
- doublereal large;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n small, large = NumRu::Lapack.dlabad( small, large)\n or\n NumRu::Lapack.dlabad # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLABAD( SMALL, LARGE )\n\n* Purpose\n* =======\n*\n* DLABAD takes as input the values computed by DLAMCH for underflow and\n* overflow, and returns the square root of each of these values if the\n* log of LARGE is sufficiently large. This subroutine is intended to\n* identify machines with a large exponent range, such as the Crays, and\n* redefine the underflow and overflow limits to be the square roots of\n* the values computed by DLAMCH. This subroutine is needed because\n* DLAMCH does not compensate for poor arithmetic in the upper half of\n* the exponent range, as is found on a Cray.\n*\n\n* Arguments\n* =========\n*\n* SMALL (input/output) DOUBLE PRECISION\n* On entry, the underflow threshold as computed by DLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of SMALL, otherwise unchanged.\n*\n* LARGE (input/output) DOUBLE PRECISION\n* On entry, the overflow threshold as computed by DLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of LARGE, otherwise unchanged.\n*\n\n* =====================================================================\n*\n* .. Intrinsic Functions ..\n INTRINSIC LOG10, SQRT\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_small = argv[0];
- rb_large = argv[1];
-
- large = NUM2DBL(rb_large);
- small = NUM2DBL(rb_small);
-
- dlabad_(&small, &large);
-
- rb_small = rb_float_new((double)small);
- rb_large = rb_float_new((double)large);
- return rb_ary_new3(2, rb_small, rb_large);
-}
-
-void
-init_lapack_dlabad(VALUE mLapack){
- rb_define_module_function(mLapack, "dlabad", rb_dlabad, -1);
-}
diff --git a/dlabrd.c b/dlabrd.c
deleted file mode 100644
index 297b381..0000000
--- a/dlabrd.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlabrd_(integer *m, integer *n, integer *nb, doublereal *a, integer *lda, doublereal *d, doublereal *e, doublereal *tauq, doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer *ldy);
-
-static VALUE
-rb_dlabrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tauq;
- doublereal *tauq;
- VALUE rb_taup;
- doublereal *taup;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer ldx;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.dlabrd( m, nb, a)\n or\n NumRu::Lapack.dlabrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* DLABRD reduces the first NB rows and columns of a real general\n* m by n matrix A to upper or lower bidiagonal form by an orthogonal\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by DGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the orthogonal matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) DOUBLE PRECISION array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) DOUBLE PRECISION array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= M.\n*\n* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- nb = NUM2INT(rb_nb);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ldy = n;
- ldx = m;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = MAX(1,nb);
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
-
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_x, rb_y, rb_a);
-}
-
-void
-init_lapack_dlabrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dlabrd", rb_dlabrd, -1);
-}
diff --git a/dlacn2.c b/dlacn2.c
deleted file mode 100644
index eeb131e..0000000
--- a/dlacn2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlacn2_(integer *n, doublereal *v, doublereal *x, integer *isgn, doublereal *est, integer *kase, integer *isave);
-
-static VALUE
-rb_dlacn2(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublereal *x;
- VALUE rb_est;
- doublereal est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_isave;
- integer *isave;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_isave_out__;
- integer *isave_out__;
- doublereal *v;
- integer *isgn;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.dlacn2( x, est, kase, isave)\n or\n NumRu::Lapack.dlacn2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* DLACN2 estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and DLACN2 must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to DLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to DLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from DLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to DLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* This is a thread safe version of DLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* DLACON DLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
- rb_isave = argv[3];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- est = NUM2DBL(rb_est);
- if (!NA_IsNArray(rb_isave))
- rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
- if (NA_RANK(rb_isave) != 1)
- rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isave) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
- if (NA_TYPE(rb_isave) != NA_LINT)
- rb_isave = na_change_type(rb_isave, NA_LINT);
- isave = NA_PTR_TYPE(rb_isave, integer*);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 3;
- rb_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isave_out__ = NA_PTR_TYPE(rb_isave_out__, integer*);
- MEMCPY(isave_out__, isave, integer, NA_TOTAL(rb_isave));
- rb_isave = rb_isave_out__;
- isave = isave_out__;
- v = ALLOC_N(doublereal, (n));
- isgn = ALLOC_N(integer, (n));
-
- dlacn2_(&n, v, x, isgn, &est, &kase, isave);
-
- free(v);
- free(isgn);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(4, rb_x, rb_est, rb_kase, rb_isave);
-}
-
-void
-init_lapack_dlacn2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlacn2", rb_dlacn2, -1);
-}
diff --git a/dlacon.c b/dlacon.c
deleted file mode 100644
index 771626f..0000000
--- a/dlacon.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlacon_(integer *n, doublereal *v, doublereal *x, integer *isgn, doublereal *est, integer *kase);
-
-static VALUE
-rb_dlacon(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublereal *x;
- VALUE rb_est;
- doublereal est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *v;
- integer *isgn;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.dlacon( x, est, kase)\n or\n NumRu::Lapack.dlacon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )\n\n* Purpose\n* =======\n*\n* DLACON estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and DLACON must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to DLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to DLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from DLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- est = NUM2DBL(rb_est);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- v = ALLOC_N(doublereal, (n));
- isgn = ALLOC_N(integer, (n));
-
- dlacon_(&n, v, x, isgn, &est, &kase);
-
- free(v);
- free(isgn);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(3, rb_x, rb_est, rb_kase);
-}
-
-void
-init_lapack_dlacon(VALUE mLapack){
- rb_define_module_function(mLapack, "dlacon", rb_dlacon, -1);
-}
diff --git a/dlacpy.c b/dlacpy.c
deleted file mode 100644
index 411919e..0000000
--- a/dlacpy.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlacpy_(char *uplo, integer *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb);
-
-static VALUE
-rb_dlacpy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.dlacpy( uplo, m, a)\n or\n NumRu::Lapack.dlacpy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* DLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper triangle\n* or trapezoid is accessed; if UPLO = 'L', only the lower\n* triangle or trapezoid is accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) DOUBLE PRECISION array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- ldb = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b = NA_PTR_TYPE(rb_b, doublereal*);
-
- dlacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_dlacpy(VALUE mLapack){
- rb_define_module_function(mLapack, "dlacpy", rb_dlacpy, -1);
-}
diff --git a/dladiv.c b/dladiv.c
deleted file mode 100644
index 3b333a4..0000000
--- a/dladiv.c
+++ /dev/null
@@ -1,47 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dladiv_(doublereal *a, doublereal *b, doublereal *c, doublereal *d, doublereal *p, doublereal *q);
-
-static VALUE
-rb_dladiv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal a;
- VALUE rb_b;
- doublereal b;
- VALUE rb_c;
- doublereal c;
- VALUE rb_d;
- doublereal d;
- VALUE rb_p;
- doublereal p;
- VALUE rb_q;
- doublereal q;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n p, q = NumRu::Lapack.dladiv( a, b, c, d)\n or\n NumRu::Lapack.dladiv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLADIV( A, B, C, D, P, Q )\n\n* Purpose\n* =======\n*\n* DLADIV performs complex division in real arithmetic\n*\n* a + i*b\n* p + i*q = ---------\n* c + i*d\n*\n* The algorithm is due to Robert L. Smith and can be found\n* in D. Knuth, The art of Computer Programming, Vol.2, p.195\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION\n* B (input) DOUBLE PRECISION\n* C (input) DOUBLE PRECISION\n* D (input) DOUBLE PRECISION\n* The scalars a, b, c, and d in the above expression.\n*\n* P (output) DOUBLE PRECISION\n* Q (output) DOUBLE PRECISION\n* The scalars p and q in the above expression.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION E, F\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
-
- a = NUM2DBL(rb_a);
- b = NUM2DBL(rb_b);
- c = NUM2DBL(rb_c);
- d = NUM2DBL(rb_d);
-
- dladiv_(&a, &b, &c, &d, &p, &q);
-
- rb_p = rb_float_new((double)p);
- rb_q = rb_float_new((double)q);
- return rb_ary_new3(2, rb_p, rb_q);
-}
-
-void
-init_lapack_dladiv(VALUE mLapack){
- rb_define_module_function(mLapack, "dladiv", rb_dladiv, -1);
-}
diff --git a/dlae2.c b/dlae2.c
deleted file mode 100644
index ddd9c5e..0000000
--- a/dlae2.c
+++ /dev/null
@@ -1,43 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlae2_(doublereal *a, doublereal *b, doublereal *c, doublereal *rt1, doublereal *rt2);
-
-static VALUE
-rb_dlae2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal a;
- VALUE rb_b;
- doublereal b;
- VALUE rb_c;
- doublereal c;
- VALUE rb_rt1;
- doublereal rt1;
- VALUE rb_rt2;
- doublereal rt2;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2 = NumRu::Lapack.dlae2( a, b, c)\n or\n NumRu::Lapack.dlae2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAE2( A, B, C, RT1, RT2 )\n\n* Purpose\n* =======\n*\n* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, and RT2\n* is the eigenvalue of smaller absolute value.\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) DOUBLE PRECISION\n* The (1,2) and (2,1) elements of the 2-by-2 matrix.\n*\n* C (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) DOUBLE PRECISION\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) DOUBLE PRECISION\n* The eigenvalue of smaller absolute value.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a = NUM2DBL(rb_a);
- b = NUM2DBL(rb_b);
- c = NUM2DBL(rb_c);
-
- dlae2_(&a, &b, &c, &rt1, &rt2);
-
- rb_rt1 = rb_float_new((double)rt1);
- rb_rt2 = rb_float_new((double)rt2);
- return rb_ary_new3(2, rb_rt1, rb_rt2);
-}
-
-void
-init_lapack_dlae2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlae2", rb_dlae2, -1);
-}
diff --git a/dlaebz.c b/dlaebz.c
deleted file mode 100644
index 08418e0..0000000
--- a/dlaebz.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaebz_(integer *ijob, integer *nitmax, integer *n, integer *mmax, integer *minp, integer *nbmin, doublereal *abstol, doublereal *reltol, doublereal *pivmin, doublereal *d, doublereal *e, doublereal *e2, integer *nval, doublereal *ab, doublereal *c, integer *mout, integer *nab, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlaebz(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_nitmax;
- integer nitmax;
- VALUE rb_minp;
- integer minp;
- VALUE rb_nbmin;
- integer nbmin;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_reltol;
- doublereal reltol;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_e2;
- doublereal *e2;
- VALUE rb_nval;
- integer *nval;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_nab;
- integer *nab;
- VALUE rb_mout;
- integer mout;
- VALUE rb_info;
- integer info;
- VALUE rb_nval_out__;
- integer *nval_out__;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_nab_out__;
- integer *nab_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer mmax;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n mout, info, nval, ab, c, nab = NumRu::Lapack.dlaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab)\n or\n NumRu::Lapack.dlaebz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAEBZ contains the iteration loops which compute and use the\n* function N(w), which is the count of eigenvalues of a symmetric\n* tridiagonal matrix T less than or equal to its argument w. It\n* performs a choice of two types of loops:\n*\n* IJOB=1, followed by\n* IJOB=2: It takes as input a list of intervals and returns a list of\n* sufficiently small intervals whose union contains the same\n* eigenvalues as the union of the original intervals.\n* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n* The output interval (AB(j,1),AB(j,2)] will contain\n* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n*\n* IJOB=3: It performs a binary search in each input interval\n* (AB(j,1),AB(j,2)] for a point w(j) such that\n* N(w(j))=NVAL(j), and uses C(j) as the starting point of\n* the search. If such a w(j) is found, then on output\n* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output\n* (AB(j,1),AB(j,2)] will be a small interval containing the\n* point where N(w) jumps through NVAL(j), unless that point\n* lies outside the initial interval.\n*\n* Note that the intervals are in all cases half-open intervals,\n* i.e., of the form (a,b] , which includes b but not a .\n*\n* To avoid underflow, the matrix should be scaled so that its largest\n* element is no greater than overflow**(1/2) * underflow**(1/4)\n* in absolute value. To assure the most accurate computation\n* of small eigenvalues, the matrix should be scaled to be\n* not much smaller than that, either.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966\n*\n* Note: the arguments are, in general, *not* checked for unreasonable\n* values.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies what is to be done:\n* = 1: Compute NAB for the initial intervals.\n* = 2: Perform bisection iteration to find eigenvalues of T.\n* = 3: Perform bisection iteration to invert N(w), i.e.,\n* to find a point which has a specified number of\n* eigenvalues of T to its left.\n* Other values will cause DLAEBZ to return with INFO=-1.\n*\n* NITMAX (input) INTEGER\n* The maximum number of \"levels\" of bisection to be\n* performed, i.e., an interval of width W will not be made\n* smaller than 2^(-NITMAX) * W. If not all intervals\n* have converged after NITMAX iterations, then INFO is set\n* to the number of non-converged intervals.\n*\n* N (input) INTEGER\n* The dimension n of the tridiagonal matrix T. It must be at\n* least 1.\n*\n* MMAX (input) INTEGER\n* The maximum number of intervals. If more than MMAX intervals\n* are generated, then DLAEBZ will quit with INFO=MMAX+1.\n*\n* MINP (input) INTEGER\n* The initial number of intervals. It may not be greater than\n* MMAX.\n*\n* NBMIN (input) INTEGER\n* The smallest number of intervals that should be processed\n* using a vector loop. If zero, then only the scalar loop\n* will be used.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The minimum (absolute) width of an interval. When an\n* interval is narrower than ABSTOL, or than RELTOL times the\n* larger (in magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. This must be at least\n* zero.\n*\n* RELTOL (input) DOUBLE PRECISION\n* The minimum relative width of an interval. When an interval\n* is narrower than ABSTOL, or than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum absolute value of a \"pivot\" in the Sturm\n* sequence loop. This *must* be at least max |e(j)**2| *\n* safe_min and at least safe_min, where safe_min is at least\n* the smallest number that can divide one without overflow.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N)\n* The offdiagonal elements of the tridiagonal matrix T in\n* positions 1 through N-1. E(N) is arbitrary.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N)\n* The squares of the offdiagonal elements of the tridiagonal\n* matrix T. E2(N) is ignored.\n*\n* NVAL (input/output) INTEGER array, dimension (MINP)\n* If IJOB=1 or 2, not referenced.\n* If IJOB=3, the desired values of N(w). The elements of NVAL\n* will be reordered to correspond with the intervals in AB.\n* Thus, NVAL(j) on output will not, in general be the same as\n* NVAL(j) on input, but it will correspond with the interval\n* (AB(j,1),AB(j,2)] on output.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2)\n* The endpoints of the intervals. AB(j,1) is a(j), the left\n* endpoint of the j-th interval, and AB(j,2) is b(j), the\n* right endpoint of the j-th interval. The input intervals\n* will, in general, be modified, split, and reordered by the\n* calculation.\n*\n* C (input/output) DOUBLE PRECISION array, dimension (MMAX)\n* If IJOB=1, ignored.\n* If IJOB=2, workspace.\n* If IJOB=3, then on input C(j) should be initialized to the\n* first search point in the binary search.\n*\n* MOUT (output) INTEGER\n* If IJOB=1, the number of eigenvalues in the intervals.\n* If IJOB=2 or 3, the number of intervals output.\n* If IJOB=3, MOUT will equal MINP.\n*\n* NAB (input/output) INTEGER array, dimension (MMAX,2)\n* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n* If IJOB=2, then on input, NAB(i,j) should be set. It must\n* satisfy the condition:\n* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n* which means that in interval i only eigenvalues\n* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,\n* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with\n* IJOB=1.\n* On output, NAB(i,j) will contain\n* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n* the input interval that the output interval\n* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n* the input values of NAB(k,1) and NAB(k,2).\n* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n* unless N(w) > NVAL(i) for all search points w , in which\n* case NAB(i,1) will not be modified, i.e., the output\n* value will be the same as the input value (modulo\n* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n* for all search points w , in which case NAB(i,2) will\n* not be modified. Normally, NAB should be set to some\n* distinctive value(s) before DLAEBZ is called.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (MMAX)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: All intervals converged.\n* = 1--MMAX: The last INFO intervals did not converge.\n* = MMAX+1: More than MMAX intervals were generated.\n*\n\n* Further Details\n* ===============\n*\n* This routine is intended to be called only by other LAPACK\n* routines, thus the interface is less user-friendly. It is intended\n* for two purposes:\n*\n* (a) finding eigenvalues. In this case, DLAEBZ should have one or\n* more initial intervals set up in AB, and DLAEBZ should be called\n* with IJOB=1. This sets up NAB, and also counts the eigenvalues.\n* Intervals with no eigenvalues would usually be thrown out at\n* this point. Also, if not all the eigenvalues in an interval i\n* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX\n* no smaller than the value of MOUT returned by the call with\n* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n* tolerance specified by ABSTOL and RELTOL.\n*\n* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n* In this case, start with a Gershgorin interval (a,b). Set up\n* AB to contain 2 search intervals, both initially (a,b). One\n* NVAL element should contain f-1 and the other should contain l\n* , while C should contain a and b, resp. NAB(i,1) should be -1\n* and NAB(i,2) should be N+1, to flag an error if the desired\n* interval does not lie in (a,b). DLAEBZ is then called with\n* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --\n* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and\n* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and\n* w(l-r)=...=w(l+k) are handled similarly.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_ijob = argv[0];
- rb_nitmax = argv[1];
- rb_minp = argv[2];
- rb_nbmin = argv[3];
- rb_abstol = argv[4];
- rb_reltol = argv[5];
- rb_pivmin = argv[6];
- rb_d = argv[7];
- rb_e = argv[8];
- rb_e2 = argv[9];
- rb_nval = argv[10];
- rb_ab = argv[11];
- rb_c = argv[12];
- rb_nab = argv[13];
-
- abstol = NUM2DBL(rb_abstol);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (12th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be %d", 2);
- mmax = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (10th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e2);
- if (NA_TYPE(rb_e2) != NA_DFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_DFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, doublereal*);
- nitmax = NUM2INT(rb_nitmax);
- pivmin = NUM2DBL(rb_pivmin);
- if (!NA_IsNArray(rb_nab))
- rb_raise(rb_eArgError, "nab (14th argument) must be NArray");
- if (NA_RANK(rb_nab) != 2)
- rb_raise(rb_eArgError, "rank of nab (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_nab) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of nab must be %d", 2);
- if (NA_SHAPE0(rb_nab) != mmax)
- rb_raise(rb_eRuntimeError, "shape 0 of nab must be the same as shape 0 of ab");
- if (NA_TYPE(rb_nab) != NA_LINT)
- rb_nab = na_change_type(rb_nab, NA_LINT);
- nab = NA_PTR_TYPE(rb_nab, integer*);
- nbmin = NUM2INT(rb_nbmin);
- reltol = NUM2DBL(rb_reltol);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (9th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of e2");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- minp = NUM2INT(rb_minp);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (8th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e2");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_nval))
- rb_raise(rb_eArgError, "nval (11th argument) must be NArray");
- if (NA_RANK(rb_nval) != 1)
- rb_raise(rb_eArgError, "rank of nval (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_nval) != ((ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of nval must be %d", (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0);
- if (NA_TYPE(rb_nval) != NA_LINT)
- rb_nval = na_change_type(rb_nval, NA_LINT);
- nval = NA_PTR_TYPE(rb_nval, integer*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (13th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- {
- int shape[1];
- shape[0] = (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0;
- rb_nval_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- nval_out__ = NA_PTR_TYPE(rb_nval_out__, integer*);
- MEMCPY(nval_out__, nval, integer, NA_TOTAL(rb_nval));
- rb_nval = rb_nval_out__;
- nval = nval_out__;
- {
- int shape[2];
- shape[0] = mmax;
- shape[1] = 2;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[1];
- shape[0] = ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = mmax;
- shape[1] = 2;
- rb_nab_out__ = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- nab_out__ = NA_PTR_TYPE(rb_nab_out__, integer*);
- MEMCPY(nab_out__, nab, integer, NA_TOTAL(rb_nab));
- rb_nab = rb_nab_out__;
- nab = nab_out__;
- work = ALLOC_N(doublereal, (mmax));
- iwork = ALLOC_N(integer, (mmax));
-
- dlaebz_(&ijob, &nitmax, &n, &mmax, &minp, &nbmin, &abstol, &reltol, &pivmin, d, e, e2, nval, ab, c, &mout, nab, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_mout = INT2NUM(mout);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_mout, rb_info, rb_nval, rb_ab, rb_c, rb_nab);
-}
-
-void
-init_lapack_dlaebz(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaebz", rb_dlaebz, -1);
-}
diff --git a/dlaed0.c b/dlaed0.c
deleted file mode 100644
index 09a0d82..0000000
--- a/dlaed0.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed0_(integer *icompq, integer *qsiz, integer *n, doublereal *d, doublereal *e, doublereal *q, integer *ldq, doublereal *qstore, integer *ldqs, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlaed0(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- doublereal *qstore;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldq;
- integer ldqs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, q = NumRu::Lapack.dlaed0( icompq, qsiz, d, e, q)\n or\n NumRu::Lapack.dlaed0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAED0 computes all eigenvalues and corresponding eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n* = 2: Compute eigenvalues and eigenvectors of tridiagonal\n* matrix.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the main diagonal of the tridiagonal matrix.\n* On exit, its eigenvalues.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, Q must contain an N-by-N orthogonal matrix.\n* If ICOMPQ = 0 Q is not referenced.\n* If ICOMPQ = 1 On entry, Q is a subset of the columns of the\n* orthogonal matrix used to reduce the full\n* matrix to tridiagonal form corresponding to\n* the subset of the full matrix which is being\n* decomposed at this time.\n* If ICOMPQ = 2 On entry, Q will be the identity matrix.\n* On exit, Q contains the eigenvectors of the\n* tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If eigenvectors are\n* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.\n*\n* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)\n* Referenced only when ICOMPQ = 1. Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE. If ICOMPQ = 1,\n* then LDQS >= max(1,N). In any case, LDQS >= 1.\n*\n* WORK (workspace) DOUBLE PRECISION array,\n* If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n* 1 + 3*N + 2*N*lg N + 2*N**2\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of WORK must be at least\n* 4*N + N**2.\n*\n* IWORK (workspace) INTEGER array,\n* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of IWORK must be at least\n* 3 + 5*N.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_icompq = argv[0];
- rb_qsiz = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_q = argv[4];
-
- qsiz = NUM2INT(rb_qsiz);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- ldqs = icompq == 1 ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- qstore = ALLOC_N(doublereal, (ldqs)*(n));
- work = ALLOC_N(doublereal, (((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0));
- iwork = ALLOC_N(integer, (((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0));
-
- dlaed0_(&icompq, &qsiz, &n, d, e, q, &ldq, qstore, &ldqs, work, iwork, &info);
-
- free(qstore);
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_q);
-}
-
-void
-init_lapack_dlaed0(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed0", rb_dlaed0, -1);
-}
diff --git a/dlaed1.c b/dlaed1.c
deleted file mode 100644
index 6d7e76f..0000000
--- a/dlaed1.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed1_(integer *n, doublereal *d, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlaed1(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_indxq_out__;
- integer *indxq_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, q, indxq = NumRu::Lapack.dlaed1( d, q, indxq, rho, cutpnt)\n or\n NumRu::Lapack.dlaed1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAED1 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles\n* the case in which eigenvalues only or eigenvalues and eigenvectors\n* of a full symmetric matrix (which was reduced to tridiagonal form)\n* are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine DLAED4 (as called by DLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* On entry, the permutation which separately sorts the two\n* subproblems in D into ascending order.\n* On exit, the permutation which will reintegrate the\n* subproblems back into sorted order,\n* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* RHO (input) DOUBLE PRECISION\n* The subdiagonal entry used to create the rank-1 modification.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= CUTPNT <= N/2.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,\n $ IW, IZ, K, N1, N2, ZPP1\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_q = argv[1];
- rb_indxq = argv[2];
- rb_rho = argv[3];
- rb_cutpnt = argv[4];
-
- cutpnt = NUM2INT(rb_cutpnt);
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (3th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (2th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of indxq");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq_out__ = NA_PTR_TYPE(rb_indxq_out__, integer*);
- MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rb_indxq));
- rb_indxq = rb_indxq_out__;
- indxq = indxq_out__;
- work = ALLOC_N(doublereal, (4*n + pow(n,2)));
- iwork = ALLOC_N(integer, (4*n));
-
- dlaed1_(&n, d, q, &ldq, indxq, &rho, &cutpnt, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_q, rb_indxq);
-}
-
-void
-init_lapack_dlaed1(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed1", rb_dlaed1, -1);
-}
diff --git a/dlaed2.c b/dlaed2.c
deleted file mode 100644
index 43b4a64..0000000
--- a/dlaed2.c
+++ /dev/null
@@ -1,170 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed2_(integer *k, integer *n, integer *n1, doublereal *d, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, doublereal *z, doublereal *dlamda, doublereal *w, doublereal *q2, integer *indx, integer *indxc, integer *indxp, integer *coltyp, integer *info);
-
-static VALUE
-rb_dlaed2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n1;
- integer n1;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_k;
- integer k;
- VALUE rb_dlamda;
- doublereal *dlamda;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_q2;
- doublereal *q2;
- VALUE rb_indxc;
- integer *indxc;
- VALUE rb_coltyp;
- integer *coltyp;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_indxq_out__;
- integer *indxq_out__;
- integer *indx;
- integer *indxp;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.dlaed2( n1, d, q, indxq, rho, z)\n or\n NumRu::Lapack.dlaed2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* DLAED2 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation. 0 <= K <=N.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined.\n* On exit, D contains the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, Q contains the eigenvectors of two submatrices in\n* the two square blocks with corners at (1,1), (N1,N1)\n* and (N1+1, N1+1), (N,N).\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have N1 added to their\n* values. Destroyed on exit.\n*\n* RHO (input/output) DOUBLE PRECISION\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* DLAED3.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* On entry, Z contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n* On exit, the contents of Z have been destroyed by the updating\n* process.\n*\n* DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* DLAED3 to form the secular equation.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first k values of the final deflation-altered z-vector\n* which will be passed to DLAED3.\n*\n* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)\n* A copy of the first K eigenvectors which will be used by\n* DLAED3 in a matrix multiply (DGEMM) to solve for the new\n* eigenvectors.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of DLAMDA into\n* ascending order.\n*\n* INDXC (output) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups: the first group contains non-zero\n* elements only at and above N1, the second contains\n* non-zero elements only below N1, and the third is dense.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* COLTYP (workspace/output) INTEGER array, dimension (N)\n* During execution, a label which will indicate which of the\n* following types a column in the Q2 matrix is:\n* 1 : non-zero in the upper half only;\n* 2 : dense;\n* 3 : non-zero in the lower half only;\n* 4 : deflated.\n* On exit, COLTYP(i) is the number of columns of type i,\n* for i=1 to 4 only.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_n1 = argv[0];
- rb_d = argv[1];
- rb_q = argv[2];
- rb_indxq = argv[3];
- rb_rho = argv[4];
- rb_z = argv[5];
-
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (4th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- rho = NUM2DBL(rb_rho);
- n1 = NUM2INT(rb_n1);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of indxq");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dlamda = NA_PTR_TYPE(rb_dlamda, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = pow(n1,2)+pow(n-n1,2);
- rb_q2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- q2 = NA_PTR_TYPE(rb_q2, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_indxc = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxc = NA_PTR_TYPE(rb_indxc, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- coltyp = NA_PTR_TYPE(rb_coltyp, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq_out__ = NA_PTR_TYPE(rb_indxq_out__, integer*);
- MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rb_indxq));
- rb_indxq = rb_indxq_out__;
- indxq = indxq_out__;
- indx = ALLOC_N(integer, (n));
- indxp = ALLOC_N(integer, (n));
-
- dlaed2_(&k, &n, &n1, d, q, &ldq, indxq, &rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, &info);
-
- free(indx);
- free(indxp);
- rb_k = INT2NUM(k);
- rb_info = INT2NUM(info);
- rb_rho = rb_float_new((double)rho);
- return rb_ary_new3(11, rb_k, rb_dlamda, rb_w, rb_q2, rb_indxc, rb_coltyp, rb_info, rb_d, rb_q, rb_indxq, rb_rho);
-}
-
-void
-init_lapack_dlaed2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed2", rb_dlaed2, -1);
-}
diff --git a/dlaed3.c b/dlaed3.c
deleted file mode 100644
index 422a0d2..0000000
--- a/dlaed3.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed3_(integer *k, integer *n, integer *n1, doublereal *d, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, doublereal *q2, integer *indx, integer *ctot, doublereal *w, doublereal *s, integer *info);
-
-static VALUE
-rb_dlaed3(int argc, VALUE *argv, VALUE self){
- VALUE rb_n1;
- integer n1;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_dlamda;
- doublereal *dlamda;
- VALUE rb_q2;
- doublereal *q2;
- VALUE rb_indx;
- integer *indx;
- VALUE rb_ctot;
- integer *ctot;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_info;
- integer info;
- VALUE rb_dlamda_out__;
- doublereal *dlamda_out__;
- VALUE rb_w_out__;
- doublereal *w_out__;
- doublereal *s;
-
- integer k;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, q, info, dlamda, w = NumRu::Lapack.dlaed3( n1, rho, dlamda, q2, indx, ctot, w)\n or\n NumRu::Lapack.dlaed3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n* Purpose\n* =======\n*\n* DLAED3 finds the roots of the secular equation, as defined by the\n* values in D, W, and RHO, between 1 and K. It makes the\n* appropriate calls to DLAED4 and then updates the eigenvectors by\n* multiplying the matrix of eigenvectors of the pair of eigensystems\n* being combined by the matrix of eigenvectors of the K-by-K system\n* which is solved here.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* DLAED4. K >= 0.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (deflation may result in N>K).\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading submatrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* D(I) contains the updated eigenvalues for\n* 1 <= I <= K.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n* Initially the first K columns are used as workspace.\n* On output the columns 1 to K contain\n* the updated eigenvectors.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) DOUBLE PRECISION\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation. May be changed on output by\n* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n* Cray-2, or Cray C-90, as described above.\n*\n* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)\n* The first K columns of this matrix contain the non-deflated\n* eigenvectors for the split problem.\n*\n* INDX (input) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups (see DLAED2).\n* The rows of the eigenvectors found by DLAED4 must be likewise\n* permuted before the matrix multiply can take place.\n*\n* CTOT (input) INTEGER array, dimension (4)\n* A count of the total number of the various types of columns\n* in Q, as described in INDX. The fourth column type is any\n* column which has been deflated.\n*\n* W (input/output) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector. Destroyed on\n* output.\n*\n* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K\n* Will contain the eigenvectors of the repaired matrix which\n* will be multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_n1 = argv[0];
- rb_rho = argv[1];
- rb_dlamda = argv[2];
- rb_q2 = argv[3];
- rb_indx = argv[4];
- rb_ctot = argv[5];
- rb_w = argv[6];
-
- if (!NA_IsNArray(rb_ctot))
- rb_raise(rb_eArgError, "ctot (6th argument) must be NArray");
- if (NA_RANK(rb_ctot) != 1)
- rb_raise(rb_eArgError, "rank of ctot (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ctot) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
- if (NA_TYPE(rb_ctot) != NA_LINT)
- rb_ctot = na_change_type(rb_ctot, NA_LINT);
- ctot = NA_PTR_TYPE(rb_ctot, integer*);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (7th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
- k = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- if (!NA_IsNArray(rb_q2))
- rb_raise(rb_eArgError, "q2 (4th argument) must be NArray");
- if (NA_RANK(rb_q2) != 2)
- rb_raise(rb_eArgError, "rank of q2 (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q2);
- if (NA_SHAPE0(rb_q2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of q2 must be the same as shape 1 of q2");
- if (NA_TYPE(rb_q2) != NA_DFLOAT)
- rb_q2 = na_change_type(rb_q2, NA_DFLOAT);
- q2 = NA_PTR_TYPE(rb_q2, doublereal*);
- if (!NA_IsNArray(rb_dlamda))
- rb_raise(rb_eArgError, "dlamda (3th argument) must be NArray");
- if (NA_RANK(rb_dlamda) != 1)
- rb_raise(rb_eArgError, "rank of dlamda (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlamda) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of dlamda must be the same as shape 0 of w");
- if (NA_TYPE(rb_dlamda) != NA_DFLOAT)
- rb_dlamda = na_change_type(rb_dlamda, NA_DFLOAT);
- dlamda = NA_PTR_TYPE(rb_dlamda, doublereal*);
- if (!NA_IsNArray(rb_indx))
- rb_raise(rb_eArgError, "indx (5th argument) must be NArray");
- if (NA_RANK(rb_indx) != 1)
- rb_raise(rb_eArgError, "rank of indx (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_indx) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of indx must be the same as shape 1 of q2");
- if (NA_TYPE(rb_indx) != NA_LINT)
- rb_indx = na_change_type(rb_indx, NA_LINT);
- indx = NA_PTR_TYPE(rb_indx, integer*);
- n1 = NUM2INT(rb_n1);
- rho = NUM2DBL(rb_rho);
- ldq = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[1];
- shape[0] = k;
- rb_dlamda_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dlamda_out__ = NA_PTR_TYPE(rb_dlamda_out__, doublereal*);
- MEMCPY(dlamda_out__, dlamda, doublereal, NA_TOTAL(rb_dlamda));
- rb_dlamda = rb_dlamda_out__;
- dlamda = dlamda_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, doublereal*);
- MEMCPY(w_out__, w, doublereal, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- s = ALLOC_N(doublereal, (MAX(1,k))*((n1 + 1)));
-
- dlaed3_(&k, &n, &n1, d, q, &ldq, &rho, dlamda, q2, indx, ctot, w, s, &info);
-
- free(s);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_q, rb_info, rb_dlamda, rb_w);
-}
-
-void
-init_lapack_dlaed3(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed3", rb_dlaed3, -1);
-}
diff --git a/dlaed4.c b/dlaed4.c
deleted file mode 100644
index 2f3bff8..0000000
--- a/dlaed4.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed4_(integer *n, integer *i, doublereal *d, doublereal *z, doublereal *delta, doublereal *rho, doublereal *dlam, integer *info);
-
-static VALUE
-rb_dlaed4(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_delta;
- doublereal *delta;
- VALUE rb_dlam;
- doublereal dlam;
- VALUE rb_info;
- integer info;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, dlam, info = NumRu::Lapack.dlaed4( i, d, z, rho)\n or\n NumRu::Lapack.dlaed4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th updated eigenvalue of a symmetric\n* rank-one modification to a diagonal matrix whose elements are\n* given in the array d, and that\n*\n* D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The original eigenvalues. It is assumed that they are in\n* order, D(I) < D(J) for I < J.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension (N)\n* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5\n* for detail. The vector DELTA contains the information necessary\n* to construct the eigenvectors by DLAED3 and DLAED9.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) DOUBLE PRECISION\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = n;
- rb_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, doublereal*);
-
- dlaed4_(&n, &i, d, z, delta, &rho, &dlam, &info);
-
- rb_dlam = rb_float_new((double)dlam);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_delta, rb_dlam, rb_info);
-}
-
-void
-init_lapack_dlaed4(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed4", rb_dlaed4, -1);
-}
diff --git a/dlaed5.c b/dlaed5.c
deleted file mode 100644
index aa481e2..0000000
--- a/dlaed5.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed5_(integer *i, doublereal *d, doublereal *z, doublereal *delta, doublereal *rho, doublereal *dlam);
-
-static VALUE
-rb_dlaed5(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_delta;
- doublereal *delta;
- VALUE rb_dlam;
- doublereal dlam;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, dlam = NumRu::Lapack.dlaed5( i, d, z, rho)\n or\n NumRu::Lapack.dlaed5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th eigenvalue of a symmetric rank-one\n* modification of a 2-by-2 diagonal matrix\n*\n* diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal elements in the array D are assumed to satisfy\n*\n* D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) DOUBLE PRECISION array, dimension (2)\n* The original eigenvalues. We assume D(1) < D(2).\n*\n* Z (input) DOUBLE PRECISION array, dimension (2)\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension (2)\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) DOUBLE PRECISION\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = 2;
- rb_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, doublereal*);
-
- dlaed5_(&i, d, z, delta, &rho, &dlam);
-
- rb_dlam = rb_float_new((double)dlam);
- return rb_ary_new3(2, rb_delta, rb_dlam);
-}
-
-void
-init_lapack_dlaed5(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed5", rb_dlaed5, -1);
-}
diff --git a/dlaed6.c b/dlaed6.c
deleted file mode 100644
index 89db208..0000000
--- a/dlaed6.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed6_(integer *kniter, logical *orgati, doublereal *rho, doublereal *d, doublereal *z, doublereal *finit, doublereal *tau, integer *info);
-
-static VALUE
-rb_dlaed6(int argc, VALUE *argv, VALUE self){
- VALUE rb_kniter;
- integer kniter;
- VALUE rb_orgati;
- logical orgati;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_finit;
- doublereal finit;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info = NumRu::Lapack.dlaed6( kniter, orgati, rho, d, z, finit)\n or\n NumRu::Lapack.dlaed6 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n* Purpose\n* =======\n*\n* DLAED6 computes the positive or negative root (closest to the origin)\n* of\n* z(1) z(2) z(3)\n* f(x) = rho + --------- + ---------- + ---------\n* d(1)-x d(2)-x d(3)-x\n*\n* It is assumed that\n*\n* if ORGATI = .true. the root is between d(2) and d(3);\n* otherwise it is between d(1) and d(2)\n*\n* This routine will be called by DLAED4 when necessary. In most cases,\n* the root sought is the smallest in magnitude, though it might not be\n* in some extremely rare situations.\n*\n\n* Arguments\n* =========\n*\n* KNITER (input) INTEGER\n* Refer to DLAED4 for its significance.\n*\n* ORGATI (input) LOGICAL\n* If ORGATI is true, the needed root is between d(2) and\n* d(3); otherwise it is between d(1) and d(2). See\n* DLAED4 for further details.\n*\n* RHO (input) DOUBLE PRECISION\n* Refer to the equation f(x) above.\n*\n* D (input) DOUBLE PRECISION array, dimension (3)\n* D satisfies d(1) < d(2) < d(3).\n*\n* Z (input) DOUBLE PRECISION array, dimension (3)\n* Each of the elements in z must be positive.\n*\n* FINIT (input) DOUBLE PRECISION\n* The value of f at 0. It is more accurate than the one\n* evaluated inside this routine (if someone wants to do\n* so).\n*\n* TAU (output) DOUBLE PRECISION\n* The root of the equation f(x).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, failure to converge\n*\n\n* Further Details\n* ===============\n*\n* 30/06/99: Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* 10/02/03: This version has a few statements commented out for thread\n* safety (machine parameters are computed on each entry). SJH.\n*\n* 05/10/06: Modified from a new version of Ren-Cang Li, use\n* Gragg-Thornton-Warner cubic convergent scheme for better stability.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_kniter = argv[0];
- rb_orgati = argv[1];
- rb_rho = argv[2];
- rb_d = argv[3];
- rb_z = argv[4];
- rb_finit = argv[5];
-
- orgati = (rb_orgati == Qtrue);
- finit = NUM2DBL(rb_finit);
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (5th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 3);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 3);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- kniter = NUM2INT(rb_kniter);
-
- dlaed6_(&kniter, &orgati, &rho, d, z, &finit, &tau, &info);
-
- rb_tau = rb_float_new((double)tau);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_tau, rb_info);
-}
-
-void
-init_lapack_dlaed6(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed6", rb_dlaed6, -1);
-}
diff --git a/dlaed7.c b/dlaed7.c
deleted file mode 100644
index f139aa6..0000000
--- a/dlaed7.c
+++ /dev/null
@@ -1,229 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed7_(integer *icompq, integer *n, integer *qsiz, integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlaed7(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_tlvls;
- integer tlvls;
- VALUE rb_curlvl;
- integer curlvl;
- VALUE rb_curpbm;
- integer curpbm;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_qstore;
- doublereal *qstore;
- VALUE rb_qptr;
- integer *qptr;
- VALUE rb_prmptr;
- integer *prmptr;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_qstore_out__;
- doublereal *qstore_out__;
- VALUE rb_qptr_out__;
- integer *qptr_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.dlaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum)\n or\n NumRu::Lapack.dlaed7 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense symmetric matrix\n* that has been reduced to tridiagonal form. DLAED1 handles\n* the case in which all eigenvalues and eigenvectors of a symmetric\n* tridiagonal matrix are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLAED8.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine DLAED4 (as called by DLAED9).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= CURLVL <= TLVLS.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* The permutation which will reintegrate the subproblem just\n* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n* will be in ascending order.\n*\n* RHO (input) DOUBLE PRECISION\n* The subdiagonal element used to create the rank-1\n* modification.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 16)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
- rb_icompq = argv[0];
- rb_qsiz = argv[1];
- rb_tlvls = argv[2];
- rb_curlvl = argv[3];
- rb_curpbm = argv[4];
- rb_d = argv[5];
- rb_q = argv[6];
- rb_rho = argv[7];
- rb_cutpnt = argv[8];
- rb_qstore = argv[9];
- rb_qptr = argv[10];
- rb_prmptr = argv[11];
- rb_perm = argv[12];
- rb_givptr = argv[13];
- rb_givcol = argv[14];
- rb_givnum = argv[15];
-
- qsiz = NUM2INT(rb_qsiz);
- cutpnt = NUM2INT(rb_cutpnt);
- tlvls = NUM2INT(rb_tlvls);
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- curlvl = NUM2INT(rb_curlvl);
- icompq = NUM2INT(rb_icompq);
- curpbm = NUM2INT(rb_curpbm);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (13th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_perm) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_prmptr))
- rb_raise(rb_eArgError, "prmptr (12th argument) must be NArray");
- if (NA_RANK(rb_prmptr) != 1)
- rb_raise(rb_eArgError, "rank of prmptr (12th argument) must be %d", 1);
- if (NA_SHAPE0(rb_prmptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
- if (NA_TYPE(rb_prmptr) != NA_LINT)
- rb_prmptr = na_change_type(rb_prmptr, NA_LINT);
- prmptr = NA_PTR_TYPE(rb_prmptr, integer*);
- if (!NA_IsNArray(rb_qstore))
- rb_raise(rb_eArgError, "qstore (10th argument) must be NArray");
- if (NA_RANK(rb_qstore) != 1)
- rb_raise(rb_eArgError, "rank of qstore (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qstore) != (pow(n,2)+1))
- rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
- if (NA_TYPE(rb_qstore) != NA_DFLOAT)
- rb_qstore = na_change_type(rb_qstore, NA_DFLOAT);
- qstore = NA_PTR_TYPE(rb_qstore, doublereal*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (14th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (15th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (15th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (16th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (16th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
- if (NA_TYPE(rb_givnum) != NA_DFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_DFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- if (!NA_IsNArray(rb_qptr))
- rb_raise(rb_eArgError, "qptr (11th argument) must be NArray");
- if (NA_RANK(rb_qptr) != 1)
- rb_raise(rb_eArgError, "rank of qptr (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qptr) != (n+2))
- rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
- if (NA_TYPE(rb_qptr) != NA_LINT)
- rb_qptr = na_change_type(rb_qptr, NA_LINT);
- qptr = NA_PTR_TYPE(rb_qptr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = pow(n,2)+1;
- rb_qstore_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- qstore_out__ = NA_PTR_TYPE(rb_qstore_out__, doublereal*);
- MEMCPY(qstore_out__, qstore, doublereal, NA_TOTAL(rb_qstore));
- rb_qstore = rb_qstore_out__;
- qstore = qstore_out__;
- {
- int shape[1];
- shape[0] = n+2;
- rb_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- qptr_out__ = NA_PTR_TYPE(rb_qptr_out__, integer*);
- MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rb_qptr));
- rb_qptr = rb_qptr_out__;
- qptr = qptr_out__;
- work = ALLOC_N(doublereal, (3*n+qsiz*n));
- iwork = ALLOC_N(integer, (4*n));
-
- dlaed7_(&icompq, &n, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, indxq, &rho, &cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_indxq, rb_info, rb_d, rb_q, rb_qstore, rb_qptr);
-}
-
-void
-init_lapack_dlaed7(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed7", rb_dlaed7, -1);
-}
diff --git a/dlaed8.c b/dlaed8.c
deleted file mode 100644
index 9fcc3a7..0000000
--- a/dlaed8.c
+++ /dev/null
@@ -1,189 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed8_(integer *icompq, integer *k, integer *n, integer *qsiz, doublereal *d, doublereal *q, integer *ldq, integer *indxq, doublereal *rho, integer *cutpnt, doublereal *z, doublereal *dlamda, doublereal *q2, integer *ldq2, doublereal *w, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, integer *indxp, integer *indx, integer *info);
-
-static VALUE
-rb_dlaed8(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ldq2;
- integer ldq2;
- VALUE rb_k;
- integer k;
- VALUE rb_dlamda;
- doublereal *dlamda;
- VALUE rb_q2;
- doublereal *q2;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- integer *indxp;
- integer *indx;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.dlaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, ldq2)\n or\n NumRu::Lapack.dlaed8 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n* Purpose\n* =======\n*\n* DLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the two submatrices to be\n* combined. On exit, the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* If ICOMPQ = 0, Q is not referenced. Otherwise,\n* on entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have CUTPNT added to\n* their values in order to be accurate.\n*\n* RHO (input/output) DOUBLE PRECISION\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* DLAED3.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* On entry, Z contains the updating vector (the last row of\n* the first sub-eigenvector matrix and the first row of the\n* second sub-eigenvector matrix).\n* On exit, the contents of Z are destroyed by the updating\n* process.\n*\n* DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* DLAED3 to form the secular equation.\n*\n* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* a copy of the first K eigenvectors which will be used by\n* DLAED7 in a matrix multiply (DGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first k values of the final deflation-altered z-vector and\n* will be passed to DLAED3.\n*\n* PERM (output) INTEGER array, dimension (N)\n* The permutations (from deflation and sorting) to be applied\n* to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of D into ascending\n* order.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_icompq = argv[0];
- rb_qsiz = argv[1];
- rb_d = argv[2];
- rb_q = argv[3];
- rb_ldq = argv[4];
- rb_indxq = argv[5];
- rb_rho = argv[6];
- rb_cutpnt = argv[7];
- rb_z = argv[8];
- rb_ldq2 = argv[9];
-
- qsiz = NUM2INT(rb_qsiz);
- cutpnt = NUM2INT(rb_cutpnt);
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (6th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- rho = NUM2DBL(rb_rho);
- ldq = NUM2INT(rb_ldq);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (4th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != (icompq==0 ? 0 : n))
- rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", icompq==0 ? 0 : n);
- if (NA_SHAPE0(rb_q) != (icompq==0 ? 0 : ldq))
- rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", icompq==0 ? 0 : ldq);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- ldq2 = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dlamda = NA_PTR_TYPE(rb_dlamda, doublereal*);
- {
- int shape[2];
- shape[0] = icompq==0 ? 0 : ldq2;
- shape[1] = icompq==0 ? 0 : n;
- rb_q2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q2 = NA_PTR_TYPE(rb_q2, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = icompq==0 ? 0 : ldq;
- shape[1] = icompq==0 ? 0 : n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- indxp = ALLOC_N(integer, (n));
- indx = ALLOC_N(integer, (n));
-
- dlaed8_(&icompq, &k, &n, &qsiz, d, q, &ldq, indxq, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, perm, &givptr, givcol, givnum, indxp, indx, &info);
-
- free(indxp);
- free(indx);
- rb_k = INT2NUM(k);
- rb_givptr = INT2NUM(givptr);
- rb_info = INT2NUM(info);
- rb_rho = rb_float_new((double)rho);
- return rb_ary_new3(12, rb_k, rb_dlamda, rb_q2, rb_w, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_info, rb_d, rb_q, rb_rho);
-}
-
-void
-init_lapack_dlaed8(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed8", rb_dlaed8, -1);
-}
diff --git a/dlaed9.c b/dlaed9.c
deleted file mode 100644
index 670f602..0000000
--- a/dlaed9.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaed9_(integer *k, integer *kstart, integer *kstop, integer *n, doublereal *d, doublereal *q, integer *ldq, doublereal *rho, doublereal *dlamda, doublereal *w, doublereal *s, integer *lds, integer *info);
-
-static VALUE
-rb_dlaed9(int argc, VALUE *argv, VALUE self){
- VALUE rb_kstart;
- integer kstart;
- VALUE rb_kstop;
- integer kstop;
- VALUE rb_n;
- integer n;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_dlamda;
- doublereal *dlamda;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_info;
- integer info;
- doublereal *q;
-
- integer k;
- integer lds;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, s, info = NumRu::Lapack.dlaed9( kstart, kstop, n, rho, dlamda, w)\n or\n NumRu::Lapack.dlaed9 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n* Purpose\n* =======\n*\n* DLAED9 finds the roots of the secular equation, as defined by the\n* values in D, Z, and RHO, between KSTART and KSTOP. It makes the\n* appropriate calls to DLAED4 and then stores the new matrix of\n* eigenvectors for use in calculating the next level of Z vectors.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* DLAED4. K >= 0.\n*\n* KSTART (input) INTEGER\n* KSTOP (input) INTEGER\n* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n* are to be computed. 1 <= KSTART <= KSTOP <= K.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (delation may result in N > K).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* D(I) contains the updated eigenvalues\n* for KSTART <= I <= KSTOP.\n*\n* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* RHO (input) DOUBLE PRECISION\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* W (input) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector.\n*\n* S (output) DOUBLE PRECISION array, dimension (LDS, K)\n* Will contain the eigenvectors of the repaired matrix which\n* will be stored for subsequent Z vector calculation and\n* multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION TEMP\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DLAMC3, DNRM2\n EXTERNAL DLAMC3, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DLAED4, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, SIGN, SQRT\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_kstart = argv[0];
- rb_kstop = argv[1];
- rb_n = argv[2];
- rb_rho = argv[3];
- rb_dlamda = argv[4];
- rb_w = argv[5];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (6th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
- k = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- kstart = NUM2INT(rb_kstart);
- if (!NA_IsNArray(rb_dlamda))
- rb_raise(rb_eArgError, "dlamda (5th argument) must be NArray");
- if (NA_RANK(rb_dlamda) != 1)
- rb_raise(rb_eArgError, "rank of dlamda (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlamda) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of dlamda must be the same as shape 0 of w");
- if (NA_TYPE(rb_dlamda) != NA_DFLOAT)
- rb_dlamda = na_change_type(rb_dlamda, NA_DFLOAT);
- dlamda = NA_PTR_TYPE(rb_dlamda, doublereal*);
- rho = NUM2DBL(rb_rho);
- kstop = NUM2INT(rb_kstop);
- n = NUM2INT(rb_n);
- lds = MAX( 1, k );
- ldq = MAX( 1, n );
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[2];
- shape[0] = lds;
- shape[1] = k;
- rb_s = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- q = ALLOC_N(doublereal, (ldq)*(MAX(1,n)));
-
- dlaed9_(&k, &kstart, &kstop, &n, d, q, &ldq, &rho, dlamda, w, s, &lds, &info);
-
- free(q);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_d, rb_s, rb_info);
-}
-
-void
-init_lapack_dlaed9(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaed9", rb_dlaed9, -1);
-}
diff --git a/dlaeda.c b/dlaeda.c
deleted file mode 100644
index c18f100..0000000
--- a/dlaeda.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaeda_(integer *n, integer *tlvls, integer *curlvl, integer *curpbm, integer *prmptr, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublereal *q, integer *qptr, doublereal *z, doublereal *ztemp, integer *info);
-
-static VALUE
-rb_dlaeda(int argc, VALUE *argv, VALUE self){
- VALUE rb_tlvls;
- integer tlvls;
- VALUE rb_curlvl;
- integer curlvl;
- VALUE rb_curpbm;
- integer curpbm;
- VALUE rb_prmptr;
- integer *prmptr;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_qptr;
- integer *qptr;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- doublereal *ztemp;
-
- integer ldqptr;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, info = NumRu::Lapack.dlaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr)\n or\n NumRu::Lapack.dlaeda # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n* Purpose\n* =======\n*\n* DLAEDA computes the Z vector corresponding to the merge step in the\n* CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n* problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and incidentally the\n* size of the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* Q (input) DOUBLE PRECISION array, dimension (N**2)\n* Contains the square eigenblocks from previous levels, the\n* starting positions for blocks are given by QPTR.\n*\n* QPTR (input) INTEGER array, dimension (N+2)\n* Contains a list of pointers which indicate where in Q an\n* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates\n* the size of the block.\n*\n* Z (output) DOUBLE PRECISION array, dimension (N)\n* On output this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n*\n* ZTEMP (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_tlvls = argv[0];
- rb_curlvl = argv[1];
- rb_curpbm = argv[2];
- rb_prmptr = argv[3];
- rb_perm = argv[4];
- rb_givptr = argv[5];
- rb_givcol = argv[6];
- rb_givnum = argv[7];
- rb_q = argv[8];
- rb_qptr = argv[9];
-
- curpbm = NUM2INT(rb_curpbm);
- if (!NA_IsNArray(rb_qptr))
- rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
- if (NA_RANK(rb_qptr) != 1)
- rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
- ldqptr = NA_SHAPE0(rb_qptr);
- if (NA_TYPE(rb_qptr) != NA_LINT)
- rb_qptr = na_change_type(rb_qptr, NA_LINT);
- qptr = NA_PTR_TYPE(rb_qptr, integer*);
- tlvls = NUM2INT(rb_tlvls);
- curlvl = NUM2INT(rb_curlvl);
- n = ldqptr-2;
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (5th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_perm) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_prmptr))
- rb_raise(rb_eArgError, "prmptr (4th argument) must be NArray");
- if (NA_RANK(rb_prmptr) != 1)
- rb_raise(rb_eArgError, "rank of prmptr (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_prmptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
- if (NA_TYPE(rb_prmptr) != NA_LINT)
- rb_prmptr = na_change_type(rb_prmptr, NA_LINT);
- prmptr = NA_PTR_TYPE(rb_prmptr, integer*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (6th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (9th argument) must be NArray");
- if (NA_RANK(rb_q) != 1)
- rb_raise(rb_eArgError, "rank of q (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_q) != (pow(n,2)))
- rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", pow(n,2));
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (7th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (8th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
- if (NA_TYPE(rb_givnum) != NA_DFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_DFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- ztemp = ALLOC_N(doublereal, (n));
-
- dlaeda_(&n, &tlvls, &curlvl, &curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, &info);
-
- free(ztemp);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_z, rb_info);
-}
-
-void
-init_lapack_dlaeda(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaeda", rb_dlaeda, -1);
-}
diff --git a/dlaein.c b/dlaein.c
deleted file mode 100644
index a801c80..0000000
--- a/dlaein.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaein_(logical *rightv, logical *noinit, integer *n, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, doublereal *vr, doublereal *vi, doublereal *b, integer *ldb, doublereal *work, doublereal *eps3, doublereal *smlnum, doublereal *bignum, integer *info);
-
-static VALUE
-rb_dlaein(int argc, VALUE *argv, VALUE self){
- VALUE rb_rightv;
- logical rightv;
- VALUE rb_noinit;
- logical noinit;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_wr;
- doublereal wr;
- VALUE rb_wi;
- doublereal wi;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_vi;
- doublereal *vi;
- VALUE rb_eps3;
- doublereal eps3;
- VALUE rb_smlnum;
- doublereal smlnum;
- VALUE rb_bignum;
- doublereal bignum;
- VALUE rb_info;
- integer info;
- VALUE rb_vr_out__;
- doublereal *vr_out__;
- VALUE rb_vi_out__;
- doublereal *vi_out__;
- doublereal *b;
- doublereal *work;
-
- integer ldh;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, vr, vi = NumRu::Lapack.dlaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum)\n or\n NumRu::Lapack.dlaein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n* Purpose\n* =======\n*\n* DLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in (VR,VI).\n* = .FALSE.: initial vector supplied in (VR,VI).\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) DOUBLE PRECISION array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input) DOUBLE PRECISION\n* WI (input) DOUBLE PRECISION\n* The real and imaginary parts of the eigenvalue of H whose\n* corresponding right or left eigenvector is to be computed.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (N)\n* VI (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n* a real starting vector for inverse iteration using the real\n* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n* must contain the real and imaginary parts of a complex\n* starting vector for inverse iteration using the complex\n* eigenvalue (WR,WI); otherwise VR and VI need not be set.\n* On exit, if WI = 0.0 (real eigenvalue), VR contains the\n* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n* VR and VI contain the real and imaginary parts of the\n* computed complex eigenvector. The eigenvector is normalized\n* so that the component of largest magnitude has magnitude 1;\n* here the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n* VI is not referenced if WI = 0.0.\n*\n* B (workspace) DOUBLE PRECISION array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= N+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* EPS3 (input) DOUBLE PRECISION\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) DOUBLE PRECISION\n* A machine-dependent value close to the underflow threshold.\n*\n* BIGNUM (input) DOUBLE PRECISION\n* A machine-dependent value close to the overflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; VR is set to the\n* last iterate, and so is VI if WI.ne.0.0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_rightv = argv[0];
- rb_noinit = argv[1];
- rb_h = argv[2];
- rb_wr = argv[3];
- rb_wi = argv[4];
- rb_vr = argv[5];
- rb_vi = argv[6];
- rb_eps3 = argv[7];
- rb_smlnum = argv[8];
- rb_bignum = argv[9];
-
- smlnum = NUM2DBL(rb_smlnum);
- eps3 = NUM2DBL(rb_eps3);
- wr = NUM2DBL(rb_wr);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 1)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DFLOAT)
- rb_vr = na_change_type(rb_vr, NA_DFLOAT);
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- rightv = (rb_rightv == Qtrue);
- noinit = (rb_noinit == Qtrue);
- bignum = NUM2DBL(rb_bignum);
- if (!NA_IsNArray(rb_vi))
- rb_raise(rb_eArgError, "vi (7th argument) must be NArray");
- if (NA_RANK(rb_vi) != 1)
- rb_raise(rb_eArgError, "rank of vi (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vi) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vi must be the same as shape 0 of vr");
- if (NA_TYPE(rb_vi) != NA_DFLOAT)
- rb_vi = na_change_type(rb_vi, NA_DFLOAT);
- vi = NA_PTR_TYPE(rb_vi, doublereal*);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (3th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of vr");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- wi = NUM2DBL(rb_wi);
- ldb = n+1;
- {
- int shape[1];
- shape[0] = n;
- rb_vr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, doublereal*);
- MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vi_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vi_out__ = NA_PTR_TYPE(rb_vi_out__, doublereal*);
- MEMCPY(vi_out__, vi, doublereal, NA_TOTAL(rb_vi));
- rb_vi = rb_vi_out__;
- vi = vi_out__;
- b = ALLOC_N(doublereal, (ldb)*(n));
- work = ALLOC_N(doublereal, (n));
-
- dlaein_(&rightv, &noinit, &n, h, &ldh, &wr, &wi, vr, vi, b, &ldb, work, &eps3, &smlnum, &bignum, &info);
-
- free(b);
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_vr, rb_vi);
-}
-
-void
-init_lapack_dlaein(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaein", rb_dlaein, -1);
-}
diff --git a/dlaev2.c b/dlaev2.c
deleted file mode 100644
index d839bda..0000000
--- a/dlaev2.c
+++ /dev/null
@@ -1,49 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaev2_(doublereal *a, doublereal *b, doublereal *c, doublereal *rt1, doublereal *rt2, doublereal *cs1, doublereal *sn1);
-
-static VALUE
-rb_dlaev2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal a;
- VALUE rb_b;
- doublereal b;
- VALUE rb_c;
- doublereal c;
- VALUE rb_rt1;
- doublereal rt1;
- VALUE rb_rt2;
- doublereal rt2;
- VALUE rb_cs1;
- doublereal cs1;
- VALUE rb_sn1;
- doublereal sn1;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.dlaev2( a, b, c)\n or\n NumRu::Lapack.dlaev2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) DOUBLE PRECISION\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) DOUBLE PRECISION\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) DOUBLE PRECISION\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) DOUBLE PRECISION\n* SN1 (output) DOUBLE PRECISION\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a = NUM2DBL(rb_a);
- b = NUM2DBL(rb_b);
- c = NUM2DBL(rb_c);
-
- dlaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
-
- rb_rt1 = rb_float_new((double)rt1);
- rb_rt2 = rb_float_new((double)rt2);
- rb_cs1 = rb_float_new((double)cs1);
- rb_sn1 = rb_float_new((double)sn1);
- return rb_ary_new3(4, rb_rt1, rb_rt2, rb_cs1, rb_sn1);
-}
-
-void
-init_lapack_dlaev2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaev2", rb_dlaev2, -1);
-}
diff --git a/dlaexc.c b/dlaexc.c
deleted file mode 100644
index 71e1e46..0000000
--- a/dlaexc.c
+++ /dev/null
@@ -1,99 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaexc_(logical *wantq, integer *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, integer *j1, integer *n1, integer *n2, doublereal *work, integer *info);
-
-static VALUE
-rb_dlaexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_j1;
- integer j1;
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- doublereal *t_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- doublereal *work;
-
- integer ldt;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.dlaexc( wantq, t, q, j1, n1, n2)\n or\n NumRu::Lapack.dlaexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n* an upper quasi-triangular matrix T by an orthogonal similarity\n* transformation.\n*\n* T must be in Schur canonical form, that is, block upper triangular\n* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n* has its diagonal elemnts equal and its off-diagonal elements of\n* opposite sign.\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* = .TRUE. : accumulate the transformation in the matrix Q;\n* = .FALSE.: do not accumulate the transformation.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, the updated matrix T, again in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n* On exit, if WANTQ is .TRUE., the updated matrix Q.\n* If WANTQ is .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n*\n* J1 (input) INTEGER\n* The index of the first row of the first block T11.\n*\n* N1 (input) INTEGER\n* The order of the first block T11. N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block T22. N2 = 0, 1 or 2.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: the transformed matrix T would be too far from Schur\n* form; the blocks are not swapped and T and Q are\n* unchanged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_wantq = argv[0];
- rb_t = argv[1];
- rb_q = argv[2];
- rb_j1 = argv[3];
- rb_n1 = argv[4];
- rb_n2 = argv[5];
-
- n1 = NUM2INT(rb_n1);
- wantq = (rb_wantq == Qtrue);
- n2 = NUM2INT(rb_n2);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- j1 = NUM2INT(rb_j1);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (2th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublereal*);
- MEMCPY(t_out__, t, doublereal, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(doublereal, (n));
-
- dlaexc_(&wantq, &n, t, &ldt, q, &ldq, &j1, &n1, &n2, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_dlaexc(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaexc", rb_dlaexc, -1);
-}
diff --git a/dlag2.c b/dlag2.c
deleted file mode 100644
index 032e4f7..0000000
--- a/dlag2.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlag2_(doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *safmin, doublereal *scale1, doublereal *scale2, doublereal *wr1, doublereal *wr2, doublereal *wi);
-
-static VALUE
-rb_dlag2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_safmin;
- doublereal safmin;
- VALUE rb_scale1;
- doublereal scale1;
- VALUE rb_scale2;
- doublereal scale2;
- VALUE rb_wr1;
- doublereal wr1;
- VALUE rb_wr2;
- doublereal wr2;
- VALUE rb_wi;
- doublereal wi;
-
- integer lda;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale1, scale2, wr1, wr2, wi = NumRu::Lapack.dlag2( a, b, safmin)\n or\n NumRu::Lapack.dlag2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n* Purpose\n* =======\n*\n* DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n* problem A - w B, with scaling as necessary to avoid over-/underflow.\n*\n* The scaling factor \"s\" results in a modified eigenvalue equation\n*\n* s A - w B\n*\n* where s is a non-negative scaling factor chosen so that w, w B,\n* and s A do not overflow and, if possible, do not underflow, either.\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm\n* is less than 1/SAFMIN. Entries less than\n* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= 2.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB, 2)\n* On entry, the 2 x 2 upper triangular matrix B. It is\n* assumed that the one-norm of B is less than 1/SAFMIN. The\n* diagonals should be at least sqrt(SAFMIN) times the largest\n* element of B (in absolute value); if a diagonal is smaller\n* than that, then +/- sqrt(SAFMIN) will be used instead of\n* that diagonal.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 2.\n*\n* SAFMIN (input) DOUBLE PRECISION\n* The smallest positive number s.t. 1/SAFMIN does not\n* overflow. (This should always be DLAMCH('S') -- it is an\n* argument in order to avoid having to call DLAMCH frequently.)\n*\n* SCALE1 (output) DOUBLE PRECISION\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the first eigenvalue. If\n* the eigenvalues are complex, then the eigenvalues are\n* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the\n* exponent range of the machine), SCALE1=SCALE2, and SCALE1\n* will always be positive. If the eigenvalues are real, then\n* the first (real) eigenvalue is WR1 / SCALE1 , but this may\n* overflow or underflow, and in fact, SCALE1 may be zero or\n* less than the underflow threshhold if the exact eigenvalue\n* is sufficiently large.\n*\n* SCALE2 (output) DOUBLE PRECISION\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the second eigenvalue. If\n* the eigenvalues are complex, then SCALE2=SCALE1. If the\n* eigenvalues are real, then the second (real) eigenvalue is\n* WR2 / SCALE2 , but this may overflow or underflow, and in\n* fact, SCALE2 may be zero or less than the underflow\n* threshhold if the exact eigenvalue is sufficiently large.\n*\n* WR1 (output) DOUBLE PRECISION\n* If the eigenvalue is real, then WR1 is SCALE1 times the\n* eigenvalue closest to the (2,2) element of A B**(-1). If the\n* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n* part of the eigenvalues.\n*\n* WR2 (output) DOUBLE PRECISION\n* If the eigenvalue is real, then WR2 is SCALE2 times the\n* other eigenvalue. If the eigenvalue is complex, then\n* WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n*\n* WI (output) DOUBLE PRECISION\n* If the eigenvalue is real, then WI is zero. If the\n* eigenvalue is complex, then WI is SCALE1 times the imaginary\n* part of the eigenvalues. WI will always be non-negative.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_safmin = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- safmin = NUM2DBL(rb_safmin);
-
- dlag2_(a, &lda, b, &ldb, &safmin, &scale1, &scale2, &wr1, &wr2, &wi);
-
- rb_scale1 = rb_float_new((double)scale1);
- rb_scale2 = rb_float_new((double)scale2);
- rb_wr1 = rb_float_new((double)wr1);
- rb_wr2 = rb_float_new((double)wr2);
- rb_wi = rb_float_new((double)wi);
- return rb_ary_new3(5, rb_scale1, rb_scale2, rb_wr1, rb_wr2, rb_wi);
-}
-
-void
-init_lapack_dlag2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlag2", rb_dlag2, -1);
-}
diff --git a/dlag2s.c b/dlag2s.c
deleted file mode 100644
index 85ab17f..0000000
--- a/dlag2s.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlag2s_(integer *m, integer *n, doublereal *a, integer *lda, real *sa, integer *ldsa, integer *info);
-
-static VALUE
-rb_dlag2s(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_sa;
- real *sa;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer ldsa;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.dlag2s( m, a)\n or\n NumRu::Lapack.dlag2s # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE\n* PRECISION matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* DLAG2S checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SA (output) REAL array, dimension (LDSA,N)\n* On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n* INFO>0, the content of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n* ..\n* .. External Functions ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- ldsa = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldsa;
- shape[1] = n;
- rb_sa = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- sa = NA_PTR_TYPE(rb_sa, real*);
-
- dlag2s_(&m, &n, a, &lda, sa, &ldsa, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_sa, rb_info);
-}
-
-void
-init_lapack_dlag2s(VALUE mLapack){
- rb_define_module_function(mLapack, "dlag2s", rb_dlag2s, -1);
-}
diff --git a/dlags2.c b/dlags2.c
deleted file mode 100644
index ca842c5..0000000
--- a/dlags2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlags2_(logical *upper, doublereal *a1, doublereal *a2, doublereal *a3, doublereal *b1, doublereal *b2, doublereal *b3, doublereal *csu, doublereal *snu, doublereal *csv, doublereal *snv, doublereal *csq, doublereal *snq);
-
-static VALUE
-rb_dlags2(int argc, VALUE *argv, VALUE self){
- VALUE rb_upper;
- logical upper;
- VALUE rb_a1;
- doublereal a1;
- VALUE rb_a2;
- doublereal a2;
- VALUE rb_a3;
- doublereal a3;
- VALUE rb_b1;
- doublereal b1;
- VALUE rb_b2;
- doublereal b2;
- VALUE rb_b3;
- doublereal b3;
- VALUE rb_csu;
- doublereal csu;
- VALUE rb_snu;
- doublereal snu;
- VALUE rb_csv;
- doublereal csv;
- VALUE rb_snv;
- doublereal snv;
- VALUE rb_csq;
- doublereal csq;
- VALUE rb_snq;
- doublereal snq;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.dlags2( upper, a1, a2, a3, b1, b2, b3)\n or\n NumRu::Lapack.dlags2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n*\n* The rows of the transformed A and B are parallel, where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )\n* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )\n*\n* Z' denotes the transpose of Z.\n*\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) DOUBLE PRECISION\n* A2 (input) DOUBLE PRECISION\n* A3 (input) DOUBLE PRECISION\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) DOUBLE PRECISION\n* B2 (input) DOUBLE PRECISION\n* B3 (input) DOUBLE PRECISION\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) DOUBLE PRECISION\n* SNU (output) DOUBLE PRECISION\n* The desired orthogonal matrix U.\n*\n* CSV (output) DOUBLE PRECISION\n* SNV (output) DOUBLE PRECISION\n* The desired orthogonal matrix V.\n*\n* CSQ (output) DOUBLE PRECISION\n* SNQ (output) DOUBLE PRECISION\n* The desired orthogonal matrix Q.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_upper = argv[0];
- rb_a1 = argv[1];
- rb_a2 = argv[2];
- rb_a3 = argv[3];
- rb_b1 = argv[4];
- rb_b2 = argv[5];
- rb_b3 = argv[6];
-
- b1 = NUM2DBL(rb_b1);
- upper = (rb_upper == Qtrue);
- b2 = NUM2DBL(rb_b2);
- a1 = NUM2DBL(rb_a1);
- b3 = NUM2DBL(rb_b3);
- a2 = NUM2DBL(rb_a2);
- a3 = NUM2DBL(rb_a3);
-
- dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
-
- rb_csu = rb_float_new((double)csu);
- rb_snu = rb_float_new((double)snu);
- rb_csv = rb_float_new((double)csv);
- rb_snv = rb_float_new((double)snv);
- rb_csq = rb_float_new((double)csq);
- rb_snq = rb_float_new((double)snq);
- return rb_ary_new3(6, rb_csu, rb_snu, rb_csv, rb_snv, rb_csq, rb_snq);
-}
-
-void
-init_lapack_dlags2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlags2", rb_dlags2, -1);
-}
diff --git a/dlagtf.c b/dlagtf.c
deleted file mode 100644
index 8ddef7a..0000000
--- a/dlagtf.c
+++ /dev/null
@@ -1,121 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlagtf_(integer *n, doublereal *a, doublereal *lambda, doublereal *b, doublereal *c, doublereal *tol, doublereal *d, integer *in, integer *info);
-
-static VALUE
-rb_dlagtf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lambda;
- doublereal lambda;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_in;
- integer *in;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, in, info, a, b, c = NumRu::Lapack.dlagtf( a, lambda, b, c, tol)\n or\n NumRu::Lapack.dlagtf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n* Purpose\n* =======\n*\n* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n* tridiagonal matrix and lambda is a scalar, as\n*\n* T - lambda*I = PLU,\n*\n* where P is a permutation matrix, L is a unit lower tridiagonal matrix\n* with at most one non-zero sub-diagonal elements per column and U is\n* an upper triangular matrix with at most two non-zero super-diagonal\n* elements per column.\n*\n* The factorization is obtained by Gaussian elimination with partial\n* pivoting and implicit row scaling.\n*\n* The parameter LAMBDA is included in the routine so that DLAGTF may\n* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by\n* inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, A must contain the diagonal elements of T.\n*\n* On exit, A is overwritten by the n diagonal elements of the\n* upper triangular matrix U of the factorization of T.\n*\n* LAMBDA (input) DOUBLE PRECISION\n* On entry, the scalar lambda.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, B must contain the (n-1) super-diagonal elements of\n* T.\n*\n* On exit, B is overwritten by the (n-1) super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* C (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, C must contain the (n-1) sub-diagonal elements of\n* T.\n*\n* On exit, C is overwritten by the (n-1) sub-diagonal elements\n* of the matrix L of the factorization of T.\n*\n* TOL (input) DOUBLE PRECISION\n* On entry, a relative tolerance used to indicate whether or\n* not the matrix (T - lambda*I) is nearly singular. TOL should\n* normally be chose as approximately the largest relative error\n* in the elements of T. For example, if the elements of T are\n* correct to about 4 significant figures, then TOL should be\n* set to about 5*10**(-4). If TOL is supplied as less than eps,\n* where eps is the relative machine precision, then the value\n* eps is used in place of TOL.\n*\n* D (output) DOUBLE PRECISION array, dimension (N-2)\n* On exit, D is overwritten by the (n-2) second super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* IN (output) INTEGER array, dimension (N)\n* On exit, IN contains details of the permutation matrix P. If\n* an interchange occurred at the kth step of the elimination,\n* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n* returns the smallest positive integer j such that\n*\n* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n*\n* where norm( A(j) ) denotes the sum of the absolute values of\n* the jth row of the matrix A. If no such j exists then IN(n)\n* is returned as zero. If IN(n) is returned as positive, then a\n* diagonal element of U is small, indicating that\n* (T - lambda*I) is singular or nearly singular,\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -k, the kth argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_lambda = argv[1];
- rb_b = argv[2];
- rb_c = argv[3];
- rb_tol = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- tol = NUM2DBL(rb_tol);
- lambda = NUM2DBL(rb_lambda);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 1)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_b) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- {
- int shape[1];
- shape[0] = n-2;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_in = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- in = NA_PTR_TYPE(rb_in, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_b_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dlagtf_(&n, a, &lambda, b, c, &tol, d, in, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_in, rb_info, rb_a, rb_b, rb_c);
-}
-
-void
-init_lapack_dlagtf(VALUE mLapack){
- rb_define_module_function(mLapack, "dlagtf", rb_dlagtf, -1);
-}
diff --git a/dlagtm.c b/dlagtm.c
deleted file mode 100644
index 1c38f02..0000000
--- a/dlagtm.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlagtm_(char *trans, integer *n, integer *nrhs, doublereal *alpha, doublereal *dl, doublereal *d, doublereal *du, doublereal *x, integer *ldx, doublereal *beta, doublereal *b, integer *ldb);
-
-static VALUE
-rb_dlagtm(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldx;
- integer nrhs;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.dlagtm( trans, alpha, dl, d, du, x, beta, b)\n or\n NumRu::Lapack.dlagtm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* DLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A'* X + beta * B\n* = 'C': 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 matrices X and B.\n*\n* ALPHA (input) DOUBLE PRECISION\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) DOUBLE PRECISION\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_alpha = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_x = argv[5];
- rb_beta = argv[6];
- rb_b = argv[7];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- beta = NUM2DBL(rb_beta);
- alpha = NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dlagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_dlagtm(VALUE mLapack){
- rb_define_module_function(mLapack, "dlagtm", rb_dlagtm, -1);
-}
diff --git a/dlagts.c b/dlagts.c
deleted file mode 100644
index 01a2b2f..0000000
--- a/dlagts.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlagts_(integer *job, integer *n, doublereal *a, doublereal *b, doublereal *c, doublereal *d, integer *in, doublereal *y, doublereal *tol, integer *info);
-
-static VALUE
-rb_dlagts(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- integer job;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_in;
- integer *in;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, y, tol = NumRu::Lapack.dlagts( job, a, b, c, d, in, y, tol)\n or\n NumRu::Lapack.dlagts # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n* Purpose\n* =======\n*\n* DLAGTS may be used to solve one of the systems of equations\n*\n* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,\n*\n* where T is an n by n tridiagonal matrix, for x, following the\n* factorization of (T - lambda*I) as\n*\n* (T - lambda*I) = P*L*U ,\n*\n* by routine DLAGTF. The choice of equation to be solved is\n* controlled by the argument JOB, and in each case there is an option\n* to perturb zero or very small diagonal elements of U, this option\n* being intended for use in applications such as inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* Specifies the job to be performed by DLAGTS as follows:\n* = 1: The equations (T - lambda*I)x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -1: The equations (T - lambda*I)x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n* = 2: The equations (T - lambda*I)'x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -2: The equations (T - lambda*I)'x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input) DOUBLE PRECISION array, dimension (N)\n* On entry, A must contain the diagonal elements of U as\n* returned from DLAGTF.\n*\n* B (input) DOUBLE PRECISION array, dimension (N-1)\n* On entry, B must contain the first super-diagonal elements of\n* U as returned from DLAGTF.\n*\n* C (input) DOUBLE PRECISION array, dimension (N-1)\n* On entry, C must contain the sub-diagonal elements of L as\n* returned from DLAGTF.\n*\n* D (input) DOUBLE PRECISION array, dimension (N-2)\n* On entry, D must contain the second super-diagonal elements\n* of U as returned from DLAGTF.\n*\n* IN (input) INTEGER array, dimension (N)\n* On entry, IN must contain details of the matrix P as returned\n* from DLAGTF.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side vector y.\n* On exit, Y is overwritten by the solution vector x.\n*\n* TOL (input/output) DOUBLE PRECISION\n* On entry, with JOB .lt. 0, TOL should be the minimum\n* perturbation to be made to very small diagonal elements of U.\n* TOL should normally be chosen as about eps*norm(U), where eps\n* is the relative machine precision, but if TOL is supplied as\n* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n* If JOB .gt. 0 then TOL is not referenced.\n*\n* On exit, TOL is changed as described above, only if TOL is\n* non-positive on entry. Otherwise TOL is unchanged.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -i, the i-th argument had an illegal value\n* .gt. 0: overflow would occur when computing the INFO(th)\n* element of the solution vector x. This can only occur\n* when JOB is supplied as positive and either means\n* that a diagonal element of U is very small, or that\n* the elements of the right-hand side vector y are very\n* large.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_c = argv[3];
- rb_d = argv[4];
- rb_in = argv[5];
- rb_y = argv[6];
- rb_tol = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- tol = NUM2DBL(rb_tol);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of a");
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_in))
- rb_raise(rb_eArgError, "in (6th argument) must be NArray");
- if (NA_RANK(rb_in) != 1)
- rb_raise(rb_eArgError, "rank of in (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_in) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of in must be the same as shape 0 of a");
- if (NA_TYPE(rb_in) != NA_LINT)
- rb_in = na_change_type(rb_in, NA_LINT);
- in = NA_PTR_TYPE(rb_in, integer*);
- job = NUM2INT(rb_job);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 1)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_b) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", n-2);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dlagts_(&job, &n, a, b, c, d, in, y, &tol, &info);
-
- rb_info = INT2NUM(info);
- rb_tol = rb_float_new((double)tol);
- return rb_ary_new3(3, rb_info, rb_y, rb_tol);
-}
-
-void
-init_lapack_dlagts(VALUE mLapack){
- rb_define_module_function(mLapack, "dlagts", rb_dlagts, -1);
-}
diff --git a/dlagv2.c b/dlagv2.c
deleted file mode 100644
index 4b78519..0000000
--- a/dlagv2.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlagv2_(doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *csl, doublereal *snl, doublereal *csr, doublereal *snr);
-
-static VALUE
-rb_dlagv2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_csl;
- doublereal csl;
- VALUE rb_snl;
- doublereal snl;
- VALUE rb_csr;
- doublereal csr;
- VALUE rb_snr;
- doublereal snr;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.dlagv2( a, b)\n or\n NumRu::Lapack.dlagv2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n* Purpose\n* =======\n*\n* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n* matrix pencil (A,B) where B is upper triangular. This routine\n* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n* SNR such that\n*\n* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n* types), then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],\n*\n* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n* then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]\n*\n* where b11 >= b22 > 0.\n*\n*\n\n* Arguments\n* =========\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A.\n* On exit, A is overwritten by the ``A-part'' of the\n* generalized Schur form.\n*\n* LDA (input) INTEGER\n* THe leading dimension of the array A. LDA >= 2.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2)\n* On entry, the upper triangular 2 x 2 matrix B.\n* On exit, B is overwritten by the ``B-part'' of the\n* generalized Schur form.\n*\n* LDB (input) INTEGER\n* THe leading dimension of the array B. LDB >= 2.\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (2)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (2)\n* BETA (output) DOUBLE PRECISION array, dimension (2)\n* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may\n* be zero.\n*\n* CSL (output) DOUBLE PRECISION\n* The cosine of the left rotation matrix.\n*\n* SNL (output) DOUBLE PRECISION\n* The sine of the left rotation matrix.\n*\n* CSR (output) DOUBLE PRECISION\n* The cosine of the right rotation matrix.\n*\n* SNR (output) DOUBLE PRECISION\n* The sine of the right rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = 2;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = 2;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dlagv2_(a, &lda, b, &ldb, alphar, alphai, beta, &csl, &snl, &csr, &snr);
-
- rb_csl = rb_float_new((double)csl);
- rb_snl = rb_float_new((double)snl);
- rb_csr = rb_float_new((double)csr);
- rb_snr = rb_float_new((double)snr);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_csl, rb_snl, rb_csr, rb_snr, rb_a, rb_b);
-}
-
-void
-init_lapack_dlagv2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlagv2", rb_dlagv2, -1);
-}
diff --git a/dlahqr.c b/dlahqr.c
deleted file mode 100644
index c066c16..0000000
--- a/dlahqr.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlahqr_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z, integer *ldz, integer *info);
-
-static VALUE
-rb_dlahqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, info, h, z = NumRu::Lapack.dlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz)\n or\n NumRu::Lapack.dlahqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* DLAHQR is an auxiliary routine called by DHSEQR to update the\n* eigenvalues and Schur decomposition already computed by DHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper quasi-triangular in\n* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n* ILO = 1). DLAHQR works primarily with the Hessenberg\n* submatrix in rows and columns ILO to IHI, but applies\n* transformations to all of H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n* quasi-triangular in rows and columns ILO:IHI, with any\n* 2-by-2 diagonal blocks in standard form. If INFO is zero\n* and WANTT is .FALSE., the contents of H are unspecified on\n* exit. The output state of H if INFO is nonzero is given\n* below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues ILO to IHI are stored in the corresponding\n* elements of WR and WI. If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with WR(i) = H(i,i), and, if\n* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by DHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: If INFO = i, DLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of WR and WI\n* contain those eigenvalues which have been\n* successfully computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix rows\n* and columns ILO thorugh INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of DLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_iloz = argv[5];
- rb_ihiz = argv[6];
- rb_z = argv[7];
- rb_ldz = argv[8];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- ldz = NUM2INT(rb_ldz);
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? n : 0;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dlahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_wr, rb_wi, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_dlahqr(VALUE mLapack){
- rb_define_module_function(mLapack, "dlahqr", rb_dlahqr, -1);
-}
diff --git a/dlahr2.c b/dlahr2.c
deleted file mode 100644
index b499790..0000000
--- a/dlahr2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlahr2_(integer *n, integer *k, integer *nb, doublereal *a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, doublereal *y, integer *ldy);
-
-static VALUE
-rb_dlahr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.dlahr2( n, k, nb, a)\n or\n NumRu::Lapack.dlahr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by DGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ldt = nb;
- ldy = n;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_dlahr2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlahr2", rb_dlahr2, -1);
-}
diff --git a/dlahrd.c b/dlahrd.c
deleted file mode 100644
index bf493e1..0000000
--- a/dlahrd.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlahrd_(integer *n, integer *k, integer *nb, doublereal *a, integer *lda, doublereal *tau, doublereal *t, integer *ldt, doublereal *y, integer *ldy);
-
-static VALUE
-rb_dlahrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.dlahrd( n, k, nb, a)\n or\n NumRu::Lapack.dlahrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine DLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ldt = nb;
- ldy = n;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_dlahrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dlahrd", rb_dlahrd, -1);
-}
diff --git a/dlaic1.c b/dlaic1.c
deleted file mode 100644
index c47033d..0000000
--- a/dlaic1.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaic1_(integer *job, integer *j, doublereal *x, doublereal *sest, doublereal *w, doublereal *gamma, doublereal *sestpr, doublereal *s, doublereal *c);
-
-static VALUE
-rb_dlaic1(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- integer job;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_sest;
- doublereal sest;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_gamma;
- doublereal gamma;
- VALUE rb_sestpr;
- doublereal sestpr;
- VALUE rb_s;
- doublereal s;
- VALUE rb_c;
- doublereal c;
-
- integer j;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.dlaic1( job, x, sest, w, gamma)\n or\n NumRu::Lapack.dlaic1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* DLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then DLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]\n* [ gamma ]\n*\n* where alpha = x'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) DOUBLE PRECISION array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) DOUBLE PRECISION\n* Estimated singular value of j by j matrix L\n*\n* W (input) DOUBLE PRECISION array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) DOUBLE PRECISION\n* The diagonal element gamma.\n*\n* SESTPR (output) DOUBLE PRECISION\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) DOUBLE PRECISION\n* Sine needed in forming xhat.\n*\n* C (output) DOUBLE PRECISION\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_job = argv[0];
- rb_x = argv[1];
- rb_sest = argv[2];
- rb_w = argv[3];
- rb_gamma = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (4th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
- j = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != j)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- gamma = NUM2DBL(rb_gamma);
- job = NUM2INT(rb_job);
- sest = NUM2DBL(rb_sest);
-
- dlaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
-
- rb_sestpr = rb_float_new((double)sestpr);
- rb_s = rb_float_new((double)s);
- rb_c = rb_float_new((double)c);
- return rb_ary_new3(3, rb_sestpr, rb_s, rb_c);
-}
-
-void
-init_lapack_dlaic1(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaic1", rb_dlaic1, -1);
-}
diff --git a/dlaln2.c b/dlaln2.c
deleted file mode 100644
index 5b0b0b9..0000000
--- a/dlaln2.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaln2_(logical *ltrans, integer *na, integer *nw, doublereal *smin, doublereal *ca, doublereal *a, integer *lda, doublereal *d1, doublereal *d2, doublereal *b, integer *ldb, doublereal *wr, doublereal *wi, doublereal *x, integer *ldx, doublereal *scale, doublereal *xnorm, integer *info);
-
-static VALUE
-rb_dlaln2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ltrans;
- logical ltrans;
- VALUE rb_smin;
- doublereal smin;
- VALUE rb_ca;
- doublereal ca;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_d1;
- doublereal d1;
- VALUE rb_d2;
- doublereal d2;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_wr;
- doublereal wr;
- VALUE rb_wi;
- doublereal wi;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_xnorm;
- doublereal xnorm;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer na;
- integer ldb;
- integer nw;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, scale, xnorm, info = NumRu::Lapack.dlaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi)\n or\n NumRu::Lapack.dlaln2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLALN2 solves a system of the form (ca A - w D ) X = s B\n* or (ca A' - w D) X = s B with possible scaling (\"s\") and\n* perturbation of A. (A' means A-transpose.)\n*\n* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n* real diagonal matrix, w is a real or complex value, and X and B are\n* NA x 1 matrices -- real if w is real, complex if w is complex. NA\n* may be 1 or 2.\n*\n* If w is complex, X and B are represented as NA x 2 matrices,\n* the first column of each being the real part and the second\n* being the imaginary part.\n*\n* \"s\" is a scaling factor (.LE. 1), computed by DLALN2, which is\n* so chosen that X can be computed without overflow. X is further\n* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n* than overflow.\n*\n* If both singular values of (ca A - w D) are less than SMIN,\n* SMIN*identity will be used instead of (ca A - w D). If only one\n* singular value is less than SMIN, one element of (ca A - w D) will be\n* perturbed enough to make the smallest singular value roughly SMIN.\n* If both singular values are at least SMIN, (ca A - w D) will not be\n* perturbed. In any case, the perturbation will be at most some small\n* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values\n* are computed by infinity-norm approximations, and thus will only be\n* correct to a factor of 2 or so.\n*\n* Note: all input quantities are assumed to be smaller than overflow\n* by a reasonable factor. (See BIGNUM.)\n*\n\n* Arguments\n* ==========\n*\n* LTRANS (input) LOGICAL\n* =.TRUE.: A-transpose will be used.\n* =.FALSE.: A will be used (not transposed.)\n*\n* NA (input) INTEGER\n* The size of the matrix A. It may (only) be 1 or 2.\n*\n* NW (input) INTEGER\n* 1 if \"w\" is real, 2 if \"w\" is complex. It may only be 1\n* or 2.\n*\n* SMIN (input) DOUBLE PRECISION\n* The desired lower bound on the singular values of A. This\n* should be a safe distance away from underflow or overflow,\n* say, between (underflow/machine precision) and (machine\n* precision * overflow ). (See BIGNUM and ULP.)\n*\n* CA (input) DOUBLE PRECISION\n* The coefficient c, which A is multiplied by.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,NA)\n* The NA x NA matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. It must be at least NA.\n*\n* D1 (input) DOUBLE PRECISION\n* The 1,1 element in the diagonal matrix D.\n*\n* D2 (input) DOUBLE PRECISION\n* The 2,2 element in the diagonal matrix D. Not used if NW=1.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NW)\n* The NA x NW matrix B (right-hand side). If NW=2 (\"w\" is\n* complex), column 1 contains the real part of B and column 2\n* contains the imaginary part.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. It must be at least NA.\n*\n* WR (input) DOUBLE PRECISION\n* The real part of the scalar \"w\".\n*\n* WI (input) DOUBLE PRECISION\n* The imaginary part of the scalar \"w\". Not used if NW=1.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NW)\n* The NA x NW matrix X (unknowns), as computed by DLALN2.\n* If NW=2 (\"w\" is complex), on exit, column 1 will contain\n* the real part of X and column 2 will contain the imaginary\n* part.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. It must be at least NA.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scale factor that B must be multiplied by to insure\n* that overflow does not occur when computing X. Thus,\n* (ca A - w D) X will be SCALE*B, not B (ignoring\n* perturbations of A.) It will be at most 1.\n*\n* XNORM (output) DOUBLE PRECISION\n* The infinity-norm of X, when X is regarded as an NA x NW\n* real matrix.\n*\n* INFO (output) INTEGER\n* An error flag. It will be set to zero if no error occurs,\n* a negative number if an argument is in error, or a positive\n* number if ca A - w D had to be perturbed.\n* The possible values are:\n* = 0: No error occurred, and (ca A - w D) did not have to be\n* perturbed.\n* = 1: (ca A - w D) had to be perturbed to make its smallest\n* (or only) singular value greater than SMIN.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_ltrans = argv[0];
- rb_smin = argv[1];
- rb_ca = argv[2];
- rb_a = argv[3];
- rb_d1 = argv[4];
- rb_d2 = argv[5];
- rb_b = argv[6];
- rb_wr = argv[7];
- rb_wi = argv[8];
-
- smin = NUM2DBL(rb_smin);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- na = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nw = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- d1 = NUM2DBL(rb_d1);
- d2 = NUM2DBL(rb_d2);
- ca = NUM2DBL(rb_ca);
- ltrans = (rb_ltrans == Qtrue);
- wi = NUM2DBL(rb_wi);
- wr = NUM2DBL(rb_wr);
- ldx = na;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nw;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
-
- dlaln2_(<rans, &na, &nw, &smin, &ca, a, &lda, &d1, &d2, b, &ldb, &wr, &wi, x, &ldx, &scale, &xnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_xnorm = rb_float_new((double)xnorm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_x, rb_scale, rb_xnorm, rb_info);
-}
-
-void
-init_lapack_dlaln2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaln2", rb_dlaln2, -1);
-}
diff --git a/dlals0.c b/dlals0.c
deleted file mode 100644
index 8176f36..0000000
--- a/dlals0.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *difr, doublereal *z, integer *k, doublereal *c, doublereal *s, doublereal *work, integer *info);
-
-static VALUE
-rb_dlals0(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_poles;
- doublereal *poles;
- VALUE rb_difl;
- doublereal *difl;
- VALUE rb_difr;
- doublereal *difr;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_c;
- doublereal c;
- VALUE rb_s;
- doublereal s;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
- doublereal *bx;
- doublereal *work;
-
- integer ldb;
- integer nrhs;
- integer n;
- integer ldgcol;
- integer ldgnum;
- integer k;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s)\n or\n NumRu::Lapack.dlals0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( K )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_b = argv[4];
- rb_perm = argv[5];
- rb_givptr = argv[6];
- rb_givcol = argv[7];
- rb_givnum = argv[8];
- rb_poles = argv[9];
- rb_difl = argv[10];
- rb_difr = argv[11];
- rb_z = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
- if (NA_RANK(rb_difl) != 1)
- rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
- k = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_DFLOAT)
- rb_difl = na_change_type(rb_difl, NA_DFLOAT);
- difl = NA_PTR_TYPE(rb_difl, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- c = NUM2DBL(rb_c);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
- ldgcol = NA_SHAPE0(rb_givcol);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (13th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- nr = NUM2INT(rb_nr);
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
- ldgnum = NA_SHAPE0(rb_poles);
- if (NA_TYPE(rb_poles) != NA_DFLOAT)
- rb_poles = na_change_type(rb_poles, NA_DFLOAT);
- poles = NA_PTR_TYPE(rb_poles, doublereal*);
- icompq = NUM2INT(rb_icompq);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
- if (NA_SHAPE0(rb_givnum) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of poles");
- if (NA_TYPE(rb_givnum) != NA_DFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_DFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- s = NUM2DBL(rb_s);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
- if (NA_SHAPE0(rb_difr) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of poles");
- if (NA_TYPE(rb_difr) != NA_DFLOAT)
- rb_difr = na_change_type(rb_difr, NA_DFLOAT);
- difr = NA_PTR_TYPE(rb_difr, doublereal*);
- givptr = NUM2INT(rb_givptr);
- ldbx = n;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- bx = ALLOC_N(doublereal, (ldbx)*(nrhs));
- work = ALLOC_N(doublereal, (k));
-
- dlals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, &info);
-
- free(bx);
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dlals0(VALUE mLapack){
- rb_define_module_function(mLapack, "dlals0", rb_dlals0, -1);
-}
diff --git a/dlalsa.c b/dlalsa.c
deleted file mode 100644
index b3f53fe..0000000
--- a/dlalsa.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlalsa_(integer *icompq, integer *smlsiz, integer *n, integer *nrhs, doublereal *b, integer *ldb, doublereal *bx, integer *ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr, doublereal *z, doublereal *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c, doublereal *s, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlalsa(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_k;
- integer *k;
- VALUE rb_difl;
- doublereal *difl;
- VALUE rb_difr;
- doublereal *difr;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_poles;
- doublereal *poles;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_bx;
- doublereal *bx;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldu;
- integer smlsiz;
- integer n;
- integer nlvl;
- integer ldgcol;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.dlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s)\n or\n NumRu::Lapack.dlalsa # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by DLALSA.\n*\n\n* Arguments\n* =========\n*\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) DOUBLE PRECISION array.\n* The dimension must be at least N.\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_b = argv[1];
- rb_u = argv[2];
- rb_vt = argv[3];
- rb_k = argv[4];
- rb_difl = argv[5];
- rb_difr = argv[6];
- rb_z = argv[7];
- rb_poles = argv[8];
- rb_givptr = argv[9];
- rb_givcol = argv[10];
- rb_perm = argv[11];
- rb_givnum = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (5th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
- if (NA_RANK(rb_difl) != 2)
- rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
- nlvl = NA_SHAPE1(rb_difl);
- if (nlvl != ((int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1))
- rb_raise(rb_eRuntimeError, "shape 1 of difl must be %d", (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
- ldu = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_DFLOAT)
- rb_difl = na_change_type(rb_difl, NA_DFLOAT);
- difl = NA_PTR_TYPE(rb_difl, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (14th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (3th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
- smlsiz = NA_SHAPE1(rb_u);
- if (NA_SHAPE0(rb_u) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of u must be the same as shape 0 of difl");
- if (NA_TYPE(rb_u) != NA_DFLOAT)
- rb_u = na_change_type(rb_u, NA_DFLOAT);
- u = NA_PTR_TYPE(rb_u, doublereal*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of difl");
- if (NA_SHAPE0(rb_z) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (15th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
- if (NA_RANK(rb_perm) != 2)
- rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_perm) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of perm must be the same as shape 1 of difl");
- ldgcol = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- ldbx = n;
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_poles) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of difl");
- if (NA_TYPE(rb_poles) != NA_DFLOAT)
- rb_poles = na_change_type(rb_poles, NA_DFLOAT);
- poles = NA_PTR_TYPE(rb_poles, doublereal*);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_difr) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of difl");
- if (NA_TYPE(rb_difr) != NA_DFLOAT)
- rb_difr = na_change_type(rb_difr, NA_DFLOAT);
- difr = NA_PTR_TYPE(rb_difr, doublereal*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vt) != (smlsiz+1))
- rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
- if (NA_SHAPE0(rb_vt) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of difl");
- if (NA_TYPE(rb_vt) != NA_DFLOAT)
- rb_vt = na_change_type(rb_vt, NA_DFLOAT);
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givnum) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of difl");
- if (NA_TYPE(rb_givnum) != NA_DFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_DFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givcol) != ldgcol)
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldbx;
- shape[1] = nrhs;
- rb_bx = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- bx = NA_PTR_TYPE(rb_bx, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, (n));
- iwork = ALLOC_N(integer, (3 * n));
-
- dlalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_bx, rb_info, rb_b);
-}
-
-void
-init_lapack_dlalsa(VALUE mLapack){
- rb_define_module_function(mLapack, "dlalsa", rb_dlalsa, -1);
-}
diff --git a/dlalsd.c b/dlalsd.c
deleted file mode 100644
index f3e5135..0000000
--- a/dlalsd.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, doublereal *d, doublereal *e, doublereal *b, integer *ldb, doublereal *rcond, integer *rank, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlalsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer nlvl;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.dlalsd( uplo, smlsiz, d, e, b, rcond)\n or\n NumRu::Lapack.dlalsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) DOUBLE PRECISION\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n*\n* IWORK (workspace) INTEGER array, dimension at least\n* (3*N*NLVL + 11*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_smlsiz = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_b = argv[4];
- rb_rcond = argv[5];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- smlsiz = NUM2INT(rb_smlsiz);
- uplo = StringValueCStr(rb_uplo)[0];
- nlvl = MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, (9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2)));
- iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
-
- dlalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_dlalsd(VALUE mLapack){
- rb_define_module_function(mLapack, "dlalsd", rb_dlalsd, -1);
-}
diff --git a/dlamrg.c b/dlamrg.c
deleted file mode 100644
index af8cf9c..0000000
--- a/dlamrg.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlamrg_(integer *n1, integer *n2, doublereal *a, integer *dtrd1, integer *dtrd2, integer *index);
-
-static VALUE
-rb_dlamrg(int argc, VALUE *argv, VALUE self){
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_dtrd1;
- integer dtrd1;
- VALUE rb_dtrd2;
- integer dtrd2;
- VALUE rb_index;
- integer *index;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n index = NumRu::Lapack.dlamrg( n1, n2, a, dtrd1, dtrd2)\n or\n NumRu::Lapack.dlamrg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )\n\n* Purpose\n* =======\n*\n* DLAMRG will create a permutation list which will merge the elements\n* of A (which is composed of two independently sorted sets) into a\n* single set which is sorted in ascending order.\n*\n\n* Arguments\n* =========\n*\n* N1 (input) INTEGER\n* N2 (input) INTEGER\n* These arguements contain the respective lengths of the two\n* sorted lists to be merged.\n*\n* A (input) DOUBLE PRECISION array, dimension (N1+N2)\n* The first N1 elements of A contain a list of numbers which\n* are sorted in either ascending or descending order. Likewise\n* for the final N2 elements.\n*\n* DTRD1 (input) INTEGER\n* DTRD2 (input) INTEGER\n* These are the strides to be taken through the array A.\n* Allowable strides are 1 and -1. They indicate whether a\n* subset of A is sorted in ascending (DTRDx = 1) or descending\n* (DTRDx = -1) order.\n*\n* INDEX (output) INTEGER array, dimension (N1+N2)\n* On exit this array will contain a permutation such that\n* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n* sorted in ascending order.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IND1, IND2, N1SV, N2SV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_n1 = argv[0];
- rb_n2 = argv[1];
- rb_a = argv[2];
- rb_dtrd1 = argv[3];
- rb_dtrd2 = argv[4];
-
- dtrd2 = NUM2INT(rb_dtrd2);
- n1 = NUM2INT(rb_n1);
- dtrd1 = NUM2INT(rb_dtrd1);
- n2 = NUM2INT(rb_n2);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n1+n2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n1+n2);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = n1+n2;
- rb_index = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- index = NA_PTR_TYPE(rb_index, integer*);
-
- dlamrg_(&n1, &n2, a, &dtrd1, &dtrd2, index);
-
- return rb_index;
-}
-
-void
-init_lapack_dlamrg(VALUE mLapack){
- rb_define_module_function(mLapack, "dlamrg", rb_dlamrg, -1);
-}
diff --git a/dlaneg.c b/dlaneg.c
deleted file mode 100644
index d453cca..0000000
--- a/dlaneg.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer dlaneg_(integer *n, doublereal *d, doublereal *lld, doublereal *sigma, doublereal *pivmin, integer *r);
-
-static VALUE
-rb_dlaneg(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_lld;
- doublereal *lld;
- VALUE rb_sigma;
- doublereal sigma;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_r;
- integer r;
- VALUE rb___out__;
- integer __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlaneg( d, lld, sigma, pivmin, r)\n or\n NumRu::Lapack.dlaneg # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n* Purpose\n* =======\n*\n* DLANEG computes the Sturm count, the number of negative pivots\n* encountered while factoring tridiagonal T - sigma I = L D L^T.\n* This implementation works directly on the factors without forming\n* the tridiagonal matrix T. The Sturm count is also the number of\n* eigenvalues of T less than sigma.\n*\n* This routine is called from DLARRB.\n*\n* The current routine does not use the PIVMIN parameter but rather\n* requires IEEE-754 propagation of Infinities and NaNs. This\n* routine also has no input range restrictions but does require\n* default exception handling such that x/0 produces Inf when x is\n* non-zero, and Inf/Inf produces NaN. For more information, see:\n*\n* Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n* Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624\n* (Tech report version in LAWN 172 with the same title.)\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* SIGMA (input) DOUBLE PRECISION\n* Shift amount in T - sigma I = L D L^T.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence. May be used\n* when zero pivots are encountered on non-IEEE-754\n* architectures.\n*\n* R (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, University of California, Berkeley, USA\n* Jason Riedy, University of California, Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_lld = argv[1];
- rb_sigma = argv[2];
- rb_pivmin = argv[3];
- rb_r = argv[4];
-
- pivmin = NUM2DBL(rb_pivmin);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- sigma = NUM2DBL(rb_sigma);
- r = NUM2INT(rb_r);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_DFLOAT)
- rb_lld = na_change_type(rb_lld, NA_DFLOAT);
- lld = NA_PTR_TYPE(rb_lld, doublereal*);
-
- __out__ = dlaneg_(&n, d, lld, &sigma, &pivmin, &r);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlaneg(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaneg", rb_dlaneg, -1);
-}
diff --git a/dlangb.c b/dlangb.c
deleted file mode 100644
index 0b5603c..0000000
--- a/dlangb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlangb_(char *norm, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *work);
-
-static VALUE
-rb_dlangb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlangb( norm, kl, ku, ab)\n or\n NumRu::Lapack.dlangb # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* DLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* DLANGB returns the value\n*\n* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlangb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlangb", rb_dlangb, -1);
-}
diff --git a/dlange.c b/dlange.c
deleted file mode 100644
index c5a8d8a..0000000
--- a/dlange.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_dlange(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlange( norm, m, a)\n or\n NumRu::Lapack.dlange # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real matrix A.\n*\n* Description\n* ===========\n*\n* DLANGE returns the value\n*\n* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* DLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* DLANGE is set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlange_(&norm, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlange(VALUE mLapack){
- rb_define_module_function(mLapack, "dlange", rb_dlange, -1);
-}
diff --git a/dlangt.c b/dlangt.c
deleted file mode 100644
index 51a1364..0000000
--- a/dlangt.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlangt_(char *norm, integer *n, doublereal *dl, doublereal *d, doublereal *du);
-
-static VALUE
-rb_dlangt(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- doublereal *dl;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_du;
- doublereal *du;
- VALUE rb___out__;
- doublereal __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlangt( norm, dl, d, du)\n or\n NumRu::Lapack.dlangt # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* DLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* DLANGT returns the value\n*\n* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANGT is\n* set to zero.\n*\n* DL (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) sub-diagonal elements of A.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DFLOAT)
- rb_du = na_change_type(rb_du, NA_DFLOAT);
- du = NA_PTR_TYPE(rb_du, doublereal*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DFLOAT)
- rb_dl = na_change_type(rb_dl, NA_DFLOAT);
- dl = NA_PTR_TYPE(rb_dl, doublereal*);
-
- __out__ = dlangt_(&norm, &n, dl, d, du);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlangt(VALUE mLapack){
- rb_define_module_function(mLapack, "dlangt", rb_dlangt, -1);
-}
diff --git a/dlanhs.c b/dlanhs.c
deleted file mode 100644
index 6d89f4c..0000000
--- a/dlanhs.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlanhs_(char *norm, integer *n, doublereal *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_dlanhs(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- doublereal *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlanhs( norm, a)\n or\n NumRu::Lapack.dlanhs # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* DLANHS returns the value\n*\n* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANHS is\n* set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlanhs_(&norm, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlanhs(VALUE mLapack){
- rb_define_module_function(mLapack, "dlanhs", rb_dlanhs, -1);
-}
diff --git a/dlansb.c b/dlansb.c
deleted file mode 100644
index 936ae0f..0000000
--- a/dlansb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlansb_(char *norm, char *uplo, integer *n, integer *k, doublereal *ab, integer *ldab, doublereal *work);
-
-static VALUE
-rb_dlansb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansb( norm, uplo, k, ab)\n or\n NumRu::Lapack.dlansb # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* DLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* DLANSB returns the value\n*\n* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_k = argv[2];
- rb_ab = argv[3];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlansb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlansb", rb_dlansb, -1);
-}
diff --git a/dlansf.c b/dlansf.c
deleted file mode 100644
index b2e58e2..0000000
--- a/dlansf.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlansf_(char *norm, char *transr, char *uplo, integer *n, doublereal *a, doublereal *work);
-
-static VALUE
-rb_dlansf(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublereal *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansf( norm, transr, uplo, n, a)\n or\n NumRu::Lapack.dlansf # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* DLANSF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* DLANSF returns the value\n*\n* DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSF as described\n* above.\n*\n* TRANSR (input) CHARACTER*1\n* Specifies whether the RFP format of A is normal or\n* transposed format.\n* = 'N': RFP format is Normal;\n* = 'T': RFP format is Transpose.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* = 'U': RFP A came from an upper triangular matrix;\n* = 'L': RFP A came from a lower triangular matrix.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSF is\n* set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* part of the symmetric matrix A stored in RFP format. See the\n* \"Notes\" below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_transr = argv[1];
- rb_uplo = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlansf_(&norm, &transr, &uplo, &n, a, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlansf(VALUE mLapack){
- rb_define_module_function(mLapack, "dlansf", rb_dlansf, -1);
-}
diff --git a/dlansp.c b/dlansp.c
deleted file mode 100644
index 3febfe5..0000000
--- a/dlansp.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlansp_(char *norm, char *uplo, integer *n, doublereal *ap, doublereal *work);
-
-static VALUE
-rb_dlansp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansp( norm, uplo, n, ap)\n or\n NumRu::Lapack.dlansp # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* DLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* DLANSP returns the value\n*\n* DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSP is\n* set to zero.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlansp_(&norm, &uplo, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlansp(VALUE mLapack){
- rb_define_module_function(mLapack, "dlansp", rb_dlansp, -1);
-}
diff --git a/dlanst.c b/dlanst.c
deleted file mode 100644
index d8e50f4..0000000
--- a/dlanst.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlanst_(char *norm, integer *n, doublereal *d, doublereal *e);
-
-static VALUE
-rb_dlanst(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb___out__;
- doublereal __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlanst( norm, d, e)\n or\n NumRu::Lapack.dlanst # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* DLANST returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* DLANST returns the value\n*\n* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANST as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANST is\n* set to zero.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
-
- __out__ = dlanst_(&norm, &n, d, e);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlanst(VALUE mLapack){
- rb_define_module_function(mLapack, "dlanst", rb_dlanst, -1);
-}
diff --git a/dlansy.c b/dlansy.c
deleted file mode 100644
index c97bdfd..0000000
--- a/dlansy.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlansy_(char *norm, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_dlansy(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansy( norm, uplo, a)\n or\n NumRu::Lapack.dlansy # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A.\n*\n* Description\n* ===========\n*\n* DLANSY returns the value\n*\n* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSY is\n* set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlansy_(&norm, &uplo, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlansy(VALUE mLapack){
- rb_define_module_function(mLapack, "dlansy", rb_dlansy, -1);
-}
diff --git a/dlantb.c b/dlantb.c
deleted file mode 100644
index 9e16b91..0000000
--- a/dlantb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, doublereal *ab, integer *ldab, doublereal *work);
-
-static VALUE
-rb_dlantb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlantb( norm, uplo, diag, k, ab)\n or\n NumRu::Lapack.dlantb # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* DLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* DLANTB returns the value\n*\n* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_k = argv[3];
- rb_ab = argv[4];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlantb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlantb", rb_dlantb, -1);
-}
diff --git a/dlantp.c b/dlantp.c
deleted file mode 100644
index cfac5e0..0000000
--- a/dlantp.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlantp_(char *norm, char *uplo, char *diag, integer *n, doublereal *ap, doublereal *work);
-
-static VALUE
-rb_dlantp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlantp( norm, uplo, diag, n, ap)\n or\n NumRu::Lapack.dlantp # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* DLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* DLANTP returns the value\n*\n* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANTP is\n* set to zero.\n*\n* AP (input) DOUBLE PRECISION 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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlantp_(&norm, &uplo, &diag, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlantp(VALUE mLapack){
- rb_define_module_function(mLapack, "dlantp", rb_dlantp, -1);
-}
diff --git a/dlantr.c b/dlantr.c
deleted file mode 100644
index 5aae2f9..0000000
--- a/dlantr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, doublereal *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_dlantr(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlantr( norm, uplo, diag, m, a)\n or\n NumRu::Lapack.dlantr # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* DLANTR returns the value\n*\n* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_m = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = dlantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlantr(VALUE mLapack){
- rb_define_module_function(mLapack, "dlantr", rb_dlantr, -1);
-}
diff --git a/dlanv2.c b/dlanv2.c
deleted file mode 100644
index dbcc335..0000000
--- a/dlanv2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlanv2_(doublereal *a, doublereal *b, doublereal *c, doublereal *d, doublereal *rt1r, doublereal *rt1i, doublereal *rt2r, doublereal *rt2i, doublereal *cs, doublereal *sn);
-
-static VALUE
-rb_dlanv2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal a;
- VALUE rb_b;
- doublereal b;
- VALUE rb_c;
- doublereal c;
- VALUE rb_d;
- doublereal d;
- VALUE rb_rt1r;
- doublereal rt1r;
- VALUE rb_rt1i;
- doublereal rt1i;
- VALUE rb_rt2r;
- doublereal rt2r;
- VALUE rb_rt2i;
- doublereal rt2i;
- VALUE rb_cs;
- doublereal cs;
- VALUE rb_sn;
- doublereal sn;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.dlanv2( a, b, c, d)\n or\n NumRu::Lapack.dlanv2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n* Purpose\n* =======\n*\n* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n* matrix in standard form:\n*\n* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]\n* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]\n*\n* where either\n* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n* conjugate eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* A (input/output) DOUBLE PRECISION\n* B (input/output) DOUBLE PRECISION\n* C (input/output) DOUBLE PRECISION\n* D (input/output) DOUBLE PRECISION\n* On entry, the elements of the input matrix.\n* On exit, they are overwritten by the elements of the\n* standardised Schur form.\n*\n* RT1R (output) DOUBLE PRECISION\n* RT1I (output) DOUBLE PRECISION\n* RT2R (output) DOUBLE PRECISION\n* RT2I (output) DOUBLE PRECISION\n* The real and imaginary parts of the eigenvalues. If the\n* eigenvalues are a complex conjugate pair, RT1I > 0.\n*\n* CS (output) DOUBLE PRECISION\n* SN (output) DOUBLE PRECISION\n* Parameters of the rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Modified by V. Sima, Research Institute for Informatics, Bucharest,\n* Romania, to reduce the risk of cancellation errors,\n* when computing real eigenvalues, and to ensure, if possible, that\n* abs(RT1R) >= abs(RT2R).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
-
- a = NUM2DBL(rb_a);
- b = NUM2DBL(rb_b);
- c = NUM2DBL(rb_c);
- d = NUM2DBL(rb_d);
-
- dlanv2_(&a, &b, &c, &d, &rt1r, &rt1i, &rt2r, &rt2i, &cs, &sn);
-
- rb_rt1r = rb_float_new((double)rt1r);
- rb_rt1i = rb_float_new((double)rt1i);
- rb_rt2r = rb_float_new((double)rt2r);
- rb_rt2i = rb_float_new((double)rt2i);
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- rb_a = rb_float_new((double)a);
- rb_b = rb_float_new((double)b);
- rb_c = rb_float_new((double)c);
- rb_d = rb_float_new((double)d);
- return rb_ary_new3(10, rb_rt1r, rb_rt1i, rb_rt2r, rb_rt2i, rb_cs, rb_sn, rb_a, rb_b, rb_c, rb_d);
-}
-
-void
-init_lapack_dlanv2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlanv2", rb_dlanv2, -1);
-}
diff --git a/dlapll.c b/dlapll.c
deleted file mode 100644
index 3f06e6f..0000000
--- a/dlapll.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlapll_(integer *n, doublereal *x, integer *incx, doublereal *y, integer *incy, doublereal *ssmin);
-
-static VALUE
-rb_dlapll(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_ssmin;
- doublereal ssmin;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.dlapll( n, x, incx, y, incy)\n or\n NumRu::Lapack.dlapll # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) DOUBLE PRECISION\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
-
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dlapll_(&n, x, &incx, y, &incy, &ssmin);
-
- rb_ssmin = rb_float_new((double)ssmin);
- return rb_ary_new3(3, rb_ssmin, rb_x, rb_y);
-}
-
-void
-init_lapack_dlapll(VALUE mLapack){
- rb_define_module_function(mLapack, "dlapll", rb_dlapll, -1);
-}
diff --git a/dlapmr.c b/dlapmr.c
deleted file mode 100644
index 5b5a84c..0000000
--- a/dlapmr.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlapmr_(logical *forwrd, integer *m, integer *n, doublereal *x, integer *ldx, integer *k);
-
-static VALUE
-rb_dlapmr(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.dlapmr( forwrd, x, k)\n or\n NumRu::Lapack.dlapmr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* DLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n DOUBLE PRECISION TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_forwrd = argv[0];
- rb_x = argv[1];
- rb_k = argv[2];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (3th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- dlapmr_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_dlapmr(VALUE mLapack){
- rb_define_module_function(mLapack, "dlapmr", rb_dlapmr, -1);
-}
diff --git a/dlapmt.c b/dlapmt.c
deleted file mode 100644
index 600314c..0000000
--- a/dlapmt.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlapmt_(logical *forwrd, integer *m, integer *n, doublereal *x, integer *ldx, integer *k);
-
-static VALUE
-rb_dlapmt(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_m;
- integer m;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.dlapmt( forwrd, m, x, k)\n or\n NumRu::Lapack.dlapmt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* DLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, IN, J\n DOUBLE PRECISION TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_forwrd = argv[0];
- rb_m = argv[1];
- rb_x = argv[2];
- rb_k = argv[3];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (4th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 0 of k");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- m = NUM2INT(rb_m);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- dlapmt_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_dlapmt(VALUE mLapack){
- rb_define_module_function(mLapack, "dlapmt", rb_dlapmt, -1);
-}
diff --git a/dlapy2.c b/dlapy2.c
deleted file mode 100644
index 45cfc9f..0000000
--- a/dlapy2.c
+++ /dev/null
@@ -1,36 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlapy2_(doublereal *x, doublereal *y);
-
-static VALUE
-rb_dlapy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublereal x;
- VALUE rb_y;
- doublereal y;
- VALUE rb___out__;
- doublereal __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlapy2( x, y)\n or\n NumRu::Lapack.dlapy2 # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLAPY2( X, Y )\n\n* Purpose\n* =======\n*\n* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n* overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) DOUBLE PRECISION\n* Y (input) DOUBLE PRECISION\n* X and Y specify the values x and y.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
-
- x = NUM2DBL(rb_x);
- y = NUM2DBL(rb_y);
-
- __out__ = dlapy2_(&x, &y);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlapy2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlapy2", rb_dlapy2, -1);
-}
diff --git a/dlapy3.c b/dlapy3.c
deleted file mode 100644
index f5f3955..0000000
--- a/dlapy3.c
+++ /dev/null
@@ -1,40 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dlapy3_(doublereal *x, doublereal *y, doublereal *z);
-
-static VALUE
-rb_dlapy3(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublereal x;
- VALUE rb_y;
- doublereal y;
- VALUE rb_z;
- doublereal z;
- VALUE rb___out__;
- doublereal __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlapy3( x, y, z)\n or\n NumRu::Lapack.dlapy3 # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )\n\n* Purpose\n* =======\n*\n* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n* unnecessary overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) DOUBLE PRECISION\n* Y (input) DOUBLE PRECISION\n* Z (input) DOUBLE PRECISION\n* X, Y and Z specify the values x, y and z.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_z = argv[2];
-
- x = NUM2DBL(rb_x);
- y = NUM2DBL(rb_y);
- z = NUM2DBL(rb_z);
-
- __out__ = dlapy3_(&x, &y, &z);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dlapy3(VALUE mLapack){
- rb_define_module_function(mLapack, "dlapy3", rb_dlapy3, -1);
-}
diff --git a/dlaqgb.c b/dlaqgb.c
deleted file mode 100644
index e662a70..0000000
--- a/dlaqgb.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqgb_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);
-
-static VALUE
-rb_dlaqgb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.dlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.dlaqgb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_r = argv[3];
- rb_c = argv[4];
- rb_rowcnd = argv[5];
- rb_colcnd = argv[6];
- rb_amax = argv[7];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- amax = NUM2DBL(rb_amax);
- colcnd = NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (4th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- rowcnd = NUM2DBL(rb_rowcnd);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dlaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_dlaqgb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqgb", rb_dlaqgb, -1);
-}
diff --git a/dlaqge.c b/dlaqge.c
deleted file mode 100644
index f702c8d..0000000
--- a/dlaqge.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqge_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);
-
-static VALUE
-rb_dlaqge(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.dlaqge( a, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.dlaqge # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_a = argv[0];
- rb_r = argv[1];
- rb_c = argv[2];
- rb_rowcnd = argv[3];
- rb_colcnd = argv[4];
- rb_amax = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- amax = NUM2DBL(rb_amax);
- colcnd = NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (2th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- rowcnd = NUM2DBL(rb_rowcnd);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_dlaqge(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqge", rb_dlaqge, -1);
-}
diff --git a/dlaqp2.c b/dlaqp2.c
deleted file mode 100644
index b6863c1..0000000
--- a/dlaqp2.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqp2_(integer *m, integer *n, integer *offset, doublereal *a, integer *lda, integer *jpvt, doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *work);
-
-static VALUE
-rb_dlaqp2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- doublereal *vn1;
- VALUE rb_vn2;
- doublereal *vn2;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- doublereal *vn1_out__;
- VALUE rb_vn2_out__;
- doublereal *vn2_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.dlaqp2( m, offset, a, jpvt, vn1, vn2)\n or\n NumRu::Lapack.dlaqp2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* DLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n* the triangular factor obtained; the elements in block\n* A(OFFSET+1:M,1:N) below the diagonal, together with the\n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_DFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_DFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, doublereal*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_DFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_DFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, doublereal*);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- offset = NUM2INT(rb_offset);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, doublereal*);
- MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, doublereal*);
- MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- work = ALLOC_N(doublereal, (n));
-
- dlaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
-
- free(work);
- return rb_ary_new3(5, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2);
-}
-
-void
-init_lapack_dlaqp2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqp2", rb_dlaqp2, -1);
-}
diff --git a/dlaqps.c b/dlaqps.c
deleted file mode 100644
index 1ecfc62..0000000
--- a/dlaqps.c
+++ /dev/null
@@ -1,189 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqps_(integer *m, integer *n, integer *offset, integer *nb, integer *kb, doublereal *a, integer *lda, integer *jpvt, doublereal *tau, doublereal *vn1, doublereal *vn2, doublereal *auxv, doublereal *f, integer *ldf);
-
-static VALUE
-rb_dlaqps(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- doublereal *vn1;
- VALUE rb_vn2;
- doublereal *vn2;
- VALUE rb_auxv;
- doublereal *auxv;
- VALUE rb_f;
- doublereal *f;
- VALUE rb_kb;
- integer kb;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- doublereal *vn1_out__;
- VALUE rb_vn2_out__;
- doublereal *vn2_out__;
- VALUE rb_auxv_out__;
- doublereal *auxv_out__;
- VALUE rb_f_out__;
- doublereal *f_out__;
-
- integer lda;
- integer n;
- integer nb;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.dlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f)\n or\n NumRu::Lapack.dlaqps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* DLAQPS computes a step of QR factorization with column pivoting\n* of a real M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) DOUBLE PRECISION array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
- rb_auxv = argv[6];
- rb_f = argv[7];
-
- if (!NA_IsNArray(rb_auxv))
- rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
- if (NA_RANK(rb_auxv) != 1)
- rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
- nb = NA_SHAPE0(rb_auxv);
- if (NA_TYPE(rb_auxv) != NA_DFLOAT)
- rb_auxv = na_change_type(rb_auxv, NA_DFLOAT);
- auxv = NA_PTR_TYPE(rb_auxv, doublereal*);
- offset = NUM2INT(rb_offset);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_DFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_DFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, doublereal*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != nb)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_DFLOAT)
- rb_f = na_change_type(rb_f, NA_DFLOAT);
- f = NA_PTR_TYPE(rb_f, doublereal*);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_DFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_DFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, doublereal*);
- kb = nb;
- {
- int shape[1];
- shape[0] = kb;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, doublereal*);
- MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, doublereal*);
- MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- {
- int shape[1];
- shape[0] = nb;
- rb_auxv_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- auxv_out__ = NA_PTR_TYPE(rb_auxv_out__, doublereal*);
- MEMCPY(auxv_out__, auxv, doublereal, NA_TOTAL(rb_auxv));
- rb_auxv = rb_auxv_out__;
- auxv = auxv_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = nb;
- rb_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, doublereal*);
- MEMCPY(f_out__, f, doublereal, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
-
- dlaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
-
- rb_kb = INT2NUM(kb);
- return rb_ary_new3(8, rb_kb, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2, rb_auxv, rb_f);
-}
-
-void
-init_lapack_dlaqps(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqps", rb_dlaqps, -1);
-}
diff --git a/dlaqr0.c b/dlaqr0.c
deleted file mode 100644
index 6cd617c..0000000
--- a/dlaqr0.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dlaqr0(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ihi;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.dlaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, lwork)\n or\n NumRu::Lapack.dlaqr0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to DGEBAL, and then passed to DGEHRD when the\n* matrix output by DGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (IHI)\n* WI (output) DOUBLE PRECISION array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then DLAQR0 does a workspace query.\n* In this case, DLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, DLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_h = argv[3];
- rb_iloz = argv[4];
- rb_ihiz = argv[5];
- rb_z = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- ihi = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (4th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = ihi;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dlaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_wr, rb_wi, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_dlaqr0(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqr0", rb_dlaqr0, -1);
-}
diff --git a/dlaqr1.c b/dlaqr1.c
deleted file mode 100644
index 08178a3..0000000
--- a/dlaqr1.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqr1_(integer *n, doublereal *h, integer *ldh, doublereal *sr1, doublereal *si1, doublereal *sr2, doublereal *si2, doublereal *v);
-
-static VALUE
-rb_dlaqr1(int argc, VALUE *argv, VALUE self){
- VALUE rb_h;
- doublereal *h;
- VALUE rb_sr1;
- doublereal sr1;
- VALUE rb_si1;
- doublereal si1;
- VALUE rb_sr2;
- doublereal sr2;
- VALUE rb_si2;
- doublereal si2;
- VALUE rb_v;
- doublereal *v;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n v = NumRu::Lapack.dlaqr1( h, sr1, si1, sr2, si2)\n or\n NumRu::Lapack.dlaqr1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n*\n* scaling to avoid overflows and most underflows. It\n* is assumed that either\n*\n* 1) sr1 = sr2 and si1 = -si2\n* or\n* 2) si1 = si2 = 0.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) DOUBLE PRECISION array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* SR1 (input) DOUBLE PRECISION\n* SI1 The shifts in (*).\n* SR2\n* SI2\n*\n* V (output) DOUBLE PRECISION array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_h = argv[0];
- rb_sr1 = argv[1];
- rb_si1 = argv[2];
- rb_sr2 = argv[3];
- rb_si2 = argv[4];
-
- si1 = NUM2DBL(rb_si1);
- si2 = NUM2DBL(rb_si2);
- sr1 = NUM2DBL(rb_sr1);
- sr2 = NUM2DBL(rb_sr2);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (1th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_v = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, doublereal*);
-
- dlaqr1_(&n, h, &ldh, &sr1, &si1, &sr2, &si2, v);
-
- return rb_v;
-}
-
-void
-init_lapack_dlaqr1(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqr1", rb_dlaqr1, -1);
-}
diff --git a/dlaqr2.c b/dlaqr2.c
deleted file mode 100644
index 7ca124a..0000000
--- a/dlaqr2.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublereal *h, integer *ldh, integer *iloz, integer *ihiz, doublereal *z, integer *ldz, integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork);
-
-static VALUE
-rb_dlaqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_nv;
- integer nv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sr;
- doublereal *sr;
- VALUE rb_si;
- doublereal *si;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
- doublereal *v;
- doublereal *t;
- doublereal *wv;
- doublereal *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
- integer ldt;
- integer ldwv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, lwork)\n or\n NumRu::Lapack.dlaqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to DLAQR3 except that it avoids\n* recursion by calling DLAHQR instead of DLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) DOUBLE PRECISION array, dimension (KBOT)\n* SI (output) DOUBLE PRECISION array, dimension (KBOT)\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; DLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_nv = argv[10];
- rb_lwork = argv[11];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- kbot = NUM2INT(rb_kbot);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sr = NA_PTR_TYPE(rb_sr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_si = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- si = NA_PTR_TYPE(rb_si, doublereal*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(doublereal, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(doublereal, (ldt)*(MAX(1,nw)));
- wv = ALLOC_N(doublereal, (ldwv)*(MAX(1,nw)));
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- dlaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(6, rb_ns, rb_nd, rb_sr, rb_si, rb_h, rb_z);
-}
-
-void
-init_lapack_dlaqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqr2", rb_dlaqr2, -1);
-}
diff --git a/dlaqr3.c b/dlaqr3.c
deleted file mode 100644
index 2e490fa..0000000
--- a/dlaqr3.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqr3_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublereal *h, integer *ldh, integer *iloz, integer *ihiz, doublereal *z, integer *ldz, integer *ns, integer *nd, doublereal *sr, doublereal *si, doublereal *v, integer *ldv, integer *nh, doublereal *t, integer *ldt, integer *nv, doublereal *wv, integer *ldwv, doublereal *work, integer *lwork);
-
-static VALUE
-rb_dlaqr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_nv;
- integer nv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sr;
- doublereal *sr;
- VALUE rb_si;
- doublereal *si;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
- doublereal *v;
- doublereal *t;
- doublereal *wv;
- doublereal *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
- integer ldt;
- integer ldwv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, lwork)\n or\n NumRu::Lapack.dlaqr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) DOUBLE PRECISION array, dimension (KBOT)\n* SI (output) DOUBLE PRECISION array, dimension (KBOT)\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; DLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_nv = argv[10];
- rb_lwork = argv[11];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- kbot = NUM2INT(rb_kbot);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sr = NA_PTR_TYPE(rb_sr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_si = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- si = NA_PTR_TYPE(rb_si, doublereal*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(doublereal, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(doublereal, (ldt)*(MAX(1,nw)));
- wv = ALLOC_N(doublereal, (ldwv)*(MAX(1,nw)));
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- dlaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(6, rb_ns, rb_nd, rb_sr, rb_si, rb_h, rb_z);
-}
-
-void
-init_lapack_dlaqr3(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqr3", rb_dlaqr3, -1);
-}
diff --git a/dlaqr4.c b/dlaqr4.c
deleted file mode 100644
index 0eabdd9..0000000
--- a/dlaqr4.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqr4_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublereal *h, integer *ldh, doublereal *wr, doublereal *wi, integer *iloz, integer *ihiz, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dlaqr4(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ihi;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.dlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, lwork)\n or\n NumRu::Lapack.dlaqr4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to DGEBAL, and then passed to DGEHRD when the\n* matrix output by DGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (IHI)\n* WI (output) DOUBLE PRECISION array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then DLAQR4 does a workspace query.\n* In this case, DLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, DLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_h = argv[3];
- rb_iloz = argv[4];
- rb_ihiz = argv[5];
- rb_z = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- ihi = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (4th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = ihi;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dlaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_wr, rb_wi, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_dlaqr4(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqr4", rb_dlaqr4, -1);
-}
diff --git a/dlaqr5.c b/dlaqr5.c
deleted file mode 100644
index b457856..0000000
--- a/dlaqr5.c
+++ /dev/null
@@ -1,183 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqr5_(logical *wantt, logical *wantz, integer *kacc22, integer *n, integer *ktop, integer *kbot, integer *nshfts, doublereal *sr, doublereal *si, doublereal *h, integer *ldh, integer *iloz, integer *ihiz, doublereal *z, integer *ldz, doublereal *v, integer *ldv, doublereal *u, integer *ldu, integer *nv, doublereal *wv, integer *ldwv, integer *nh, doublereal *wh, integer *ldwh);
-
-static VALUE
-rb_dlaqr5(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_kacc22;
- integer kacc22;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_sr;
- doublereal *sr;
- VALUE rb_si;
- doublereal *si;
- VALUE rb_h;
- doublereal *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_nv;
- integer nv;
- VALUE rb_nh;
- integer nh;
- VALUE rb_sr_out__;
- doublereal *sr_out__;
- VALUE rb_si_out__;
- doublereal *si_out__;
- VALUE rb_h_out__;
- doublereal *h_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
- doublereal *v;
- doublereal *u;
- doublereal *wv;
- doublereal *wh;
-
- integer nshfts;
- integer ldh;
- integer n;
- integer ldv;
- integer ldu;
- integer ldwv;
- integer ldwh;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sr, si, h, z = NumRu::Lapack.dlaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, ldz, nv, nh)\n or\n NumRu::Lapack.dlaqr5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by DLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the quasi-triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the orthogonal Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: DLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: DLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: DLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* SR (input/output) DOUBLE PRECISION array of size (NSHFTS)\n* SI (input/output) DOUBLE PRECISION array of size (NSHFTS)\n* SR contains the real parts and SI contains the imaginary\n* parts of the NSHFTS shifts of origin that define the\n* multi-shift QR sweep. On output SR and SI may be\n* reordered.\n*\n* H (input/output) DOUBLE PRECISION array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep orthogonal\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) DOUBLE PRECISION array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) DOUBLE PRECISION array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_kacc22 = argv[2];
- rb_ktop = argv[3];
- rb_kbot = argv[4];
- rb_sr = argv[5];
- rb_si = argv[6];
- rb_h = argv[7];
- rb_iloz = argv[8];
- rb_ihiz = argv[9];
- rb_z = argv[10];
- rb_ldz = argv[11];
- rb_nv = argv[12];
- rb_nh = argv[13];
-
- if (!NA_IsNArray(rb_si))
- rb_raise(rb_eArgError, "si (7th argument) must be NArray");
- if (NA_RANK(rb_si) != 1)
- rb_raise(rb_eArgError, "rank of si (7th argument) must be %d", 1);
- nshfts = NA_SHAPE0(rb_si);
- if (NA_TYPE(rb_si) != NA_DFLOAT)
- rb_si = na_change_type(rb_si, NA_DFLOAT);
- si = NA_PTR_TYPE(rb_si, doublereal*);
- kacc22 = NUM2INT(rb_kacc22);
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_sr))
- rb_raise(rb_eArgError, "sr (6th argument) must be NArray");
- if (NA_RANK(rb_sr) != 1)
- rb_raise(rb_eArgError, "rank of sr (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sr) != nshfts)
- rb_raise(rb_eRuntimeError, "shape 0 of sr must be the same as shape 0 of si");
- if (NA_TYPE(rb_sr) != NA_DFLOAT)
- rb_sr = na_change_type(rb_sr, NA_DFLOAT);
- sr = NA_PTR_TYPE(rb_sr, doublereal*);
- kbot = NUM2INT(rb_kbot);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (8th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DFLOAT)
- rb_h = na_change_type(rb_h, NA_DFLOAT);
- h = NA_PTR_TYPE(rb_h, doublereal*);
- nv = NUM2INT(rb_nv);
- ihiz = NUM2INT(rb_ihiz);
- wantt = (rb_wantt == Qtrue);
- ldv = 3;
- iloz = NUM2INT(rb_iloz);
- ldz = n;
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (11th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? ihiz : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- ldwv = nv;
- ldu = 3*nshfts-3;
- ldwh = 3*nshfts-3;
- {
- int shape[1];
- shape[0] = nshfts;
- rb_sr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sr_out__ = NA_PTR_TYPE(rb_sr_out__, doublereal*);
- MEMCPY(sr_out__, sr, doublereal, NA_TOTAL(rb_sr));
- rb_sr = rb_sr_out__;
- sr = sr_out__;
- {
- int shape[1];
- shape[0] = nshfts;
- rb_si_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- si_out__ = NA_PTR_TYPE(rb_si_out__, doublereal*);
- MEMCPY(si_out__, si, doublereal, NA_TOTAL(rb_si));
- rb_si = rb_si_out__;
- si = si_out__;
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublereal*);
- MEMCPY(h_out__, h, doublereal, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? ihiz : 0;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(doublereal, (ldv)*(nshfts/2));
- u = ALLOC_N(doublereal, (ldu)*(3*nshfts-3));
- wv = ALLOC_N(doublereal, (ldwv)*(3*nshfts-3));
- wh = ALLOC_N(doublereal, (ldwh)*(MAX(1,nh)));
-
- dlaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, sr, si, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
-
- free(v);
- free(u);
- free(wv);
- free(wh);
- return rb_ary_new3(4, rb_sr, rb_si, rb_h, rb_z);
-}
-
-void
-init_lapack_dlaqr5(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqr5", rb_dlaqr5, -1);
-}
diff --git a/dlaqsb.c b/dlaqsb.c
deleted file mode 100644
index 43f1d5e..0000000
--- a/dlaqsb.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqsb_(char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_dlaqsb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.dlaqsb( uplo, kd, ab, s, scond, amax)\n or\n NumRu::Lapack.dlaqsb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_s = argv[3];
- rb_scond = argv[4];
- rb_amax = argv[5];
-
- scond = NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kd = NUM2INT(rb_kd);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dlaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_dlaqsb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqsb", rb_dlaqsb, -1);
-}
diff --git a/dlaqsp.c b/dlaqsp.c
deleted file mode 100644
index 0ffcfed..0000000
--- a/dlaqsp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqsp_(char *uplo, integer *n, doublereal *ap, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_dlaqsp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ap = NumRu::Lapack.dlaqsp( uplo, ap, s, scond, amax)\n or\n NumRu::Lapack.dlaqsp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQSP 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* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = NUM2DBL(rb_scond);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dlaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ap);
-}
-
-void
-init_lapack_dlaqsp(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqsp", rb_dlaqsp, -1);
-}
diff --git a/dlaqsy.c b/dlaqsy.c
deleted file mode 100644
index 7d577a7..0000000
--- a/dlaqsy.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqsy_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_dlaqsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.dlaqsy( uplo, a, s, scond, amax)\n or\n NumRu::Lapack.dlaqsy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQSY 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) DOUBLE PRECISION 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_dlaqsy(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqsy", rb_dlaqsy, -1);
-}
diff --git a/dlaqtr.c b/dlaqtr.c
deleted file mode 100644
index 400aedd..0000000
--- a/dlaqtr.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaqtr_(logical *ltran, logical *lreal, integer *n, doublereal *t, integer *ldt, doublereal *b, doublereal *w, doublereal *scale, doublereal *x, doublereal *work, integer *info);
-
-static VALUE
-rb_dlaqtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_ltran;
- logical ltran;
- VALUE rb_lreal;
- logical lreal;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_w;
- doublereal w;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
-
- integer ldt;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x = NumRu::Lapack.dlaqtr( ltran, lreal, t, b, w, x)\n or\n NumRu::Lapack.dlaqtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAQTR solves the real quasi-triangular system\n*\n* op(T)*p = scale*c, if LREAL = .TRUE.\n*\n* or the complex quasi-triangular systems\n*\n* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.\n*\n* in real arithmetic, where T is upper quasi-triangular.\n* If LREAL = .FALSE., then the first diagonal block of T must be\n* 1 by 1, B is the specially structured matrix\n*\n* B = [ b(1) b(2) ... b(n) ]\n* [ w ]\n* [ w ]\n* [ . ]\n* [ w ]\n*\n* op(A) = A or A', A' denotes the conjugate transpose of\n* matrix A.\n*\n* On input, X = [ c ]. On output, X = [ p ].\n* [ d ] [ q ]\n*\n* This subroutine is designed for the condition number estimation\n* in routine DTRSNA.\n*\n\n* Arguments\n* =========\n*\n* LTRAN (input) LOGICAL\n* On entry, LTRAN specifies the option of conjugate transpose:\n* = .FALSE., op(T+i*B) = T+i*B,\n* = .TRUE., op(T+i*B) = (T+i*B)'.\n*\n* LREAL (input) LOGICAL\n* On entry, LREAL specifies the input matrix structure:\n* = .FALSE., the input is complex\n* = .TRUE., the input is real\n*\n* N (input) INTEGER\n* On entry, N specifies the order of T+i*B. N >= 0.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, T contains a matrix in Schur canonical form.\n* If LREAL = .FALSE., then the first diagonal block of T mu\n* be 1 by 1.\n*\n* LDT (input) INTEGER\n* The leading dimension of the matrix T. LDT >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (N)\n* On entry, B contains the elements to form the matrix\n* B as described above.\n* If LREAL = .TRUE., B is not referenced.\n*\n* W (input) DOUBLE PRECISION\n* On entry, W is the diagonal element of the matrix B.\n* If LREAL = .TRUE., W is not referenced.\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE is the scale factor.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (2*N)\n* On entry, X contains the right hand side of the system.\n* On exit, X is overwritten by the solution.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: the some diagonal 1 by 1 block has been perturbed by\n* a small number SMIN to keep nonsingularity.\n* 2: the some diagonal 2 by 2 block has been perturbed by\n* a small number in DLALN2 to keep nonsingularity.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_ltran = argv[0];
- rb_lreal = argv[1];
- rb_t = argv[2];
- rb_b = argv[3];
- rb_w = argv[4];
- rb_x = argv[5];
-
- w = NUM2DBL(rb_w);
- lreal = (rb_lreal == Qtrue);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (3th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- ltran = (rb_ltran == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 1)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 1 of t");
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 2*n);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 2*n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (n));
-
- dlaqtr_(<ran, &lreal, &n, t, &ldt, b, &w, &scale, x, work, &info);
-
- free(work);
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_scale, rb_info, rb_x);
-}
-
-void
-init_lapack_dlaqtr(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaqtr", rb_dlaqtr, -1);
-}
diff --git a/dlar1v.c b/dlar1v.c
deleted file mode 100644
index 5b1612b..0000000
--- a/dlar1v.c
+++ /dev/null
@@ -1,154 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlar1v_(integer *n, integer *b1, integer *bn, doublereal *lambda, doublereal *d, doublereal *l, doublereal *ld, doublereal *lld, doublereal *pivmin, doublereal *gaptol, doublereal *z, logical *wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma, integer *r, integer *isuppz, doublereal *nrminv, doublereal *resid, doublereal *rqcorr, doublereal *work);
-
-static VALUE
-rb_dlar1v(int argc, VALUE *argv, VALUE self){
- VALUE rb_b1;
- integer b1;
- VALUE rb_bn;
- integer bn;
- VALUE rb_lambda;
- doublereal lambda;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_l;
- doublereal *l;
- VALUE rb_ld;
- doublereal *ld;
- VALUE rb_lld;
- doublereal *lld;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_gaptol;
- doublereal gaptol;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_wantnc;
- logical wantnc;
- VALUE rb_r;
- integer r;
- VALUE rb_negcnt;
- integer negcnt;
- VALUE rb_ztz;
- doublereal ztz;
- VALUE rb_mingma;
- doublereal mingma;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_nrminv;
- doublereal nrminv;
- VALUE rb_resid;
- doublereal resid;
- VALUE rb_rqcorr;
- doublereal rqcorr;
- VALUE rb_z_out__;
- doublereal *z_out__;
- doublereal *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.dlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r)\n or\n NumRu::Lapack.dlar1v # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAR1V( 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* DLAR1V 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) DOUBLE PRECISION 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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_b1 = argv[0];
- rb_bn = argv[1];
- rb_lambda = argv[2];
- rb_d = argv[3];
- rb_l = argv[4];
- rb_ld = argv[5];
- rb_lld = argv[6];
- rb_pivmin = argv[7];
- rb_gaptol = argv[8];
- rb_z = argv[9];
- rb_wantnc = argv[10];
- rb_r = argv[11];
-
- pivmin = NUM2DBL(rb_pivmin);
- bn = NUM2INT(rb_bn);
- lambda = NUM2DBL(rb_lambda);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (10th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- wantnc = (rb_wantnc == Qtrue);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- r = NUM2INT(rb_r);
- gaptol = NUM2DBL(rb_gaptol);
- b1 = NUM2INT(rb_b1);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_DFLOAT)
- rb_lld = na_change_type(rb_lld, NA_DFLOAT);
- lld = NA_PTR_TYPE(rb_lld, doublereal*);
- if (!NA_IsNArray(rb_ld))
- rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
- if (NA_RANK(rb_ld) != 1)
- rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
- if (NA_TYPE(rb_ld) != NA_DFLOAT)
- rb_ld = na_change_type(rb_ld, NA_DFLOAT);
- ld = NA_PTR_TYPE(rb_ld, doublereal*);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (5th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
- if (NA_TYPE(rb_l) != NA_DFLOAT)
- rb_l = na_change_type(rb_l, NA_DFLOAT);
- l = NA_PTR_TYPE(rb_l, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(doublereal, (4*n));
-
- dlar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);
-
- free(work);
- rb_negcnt = INT2NUM(negcnt);
- rb_ztz = rb_float_new((double)ztz);
- rb_mingma = rb_float_new((double)mingma);
- rb_nrminv = rb_float_new((double)nrminv);
- rb_resid = rb_float_new((double)resid);
- rb_rqcorr = rb_float_new((double)rqcorr);
- rb_r = INT2NUM(r);
- return rb_ary_new3(9, rb_negcnt, rb_ztz, rb_mingma, rb_isuppz, rb_nrminv, rb_resid, rb_rqcorr, rb_z, rb_r);
-}
-
-void
-init_lapack_dlar1v(VALUE mLapack){
- rb_define_module_function(mLapack, "dlar1v", rb_dlar1v, -1);
-}
diff --git a/dlar2v.c b/dlar2v.c
deleted file mode 100644
index e721f79..0000000
--- a/dlar2v.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlar2v_(integer *n, doublereal *x, doublereal *y, doublereal *z, integer *incx, doublereal *c, doublereal *s, integer *incc);
-
-static VALUE
-rb_dlar2v(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_incx;
- integer incx;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_y_out__;
- doublereal *y_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.dlar2v( n, x, y, z, incx, c, s, incc)\n or\n NumRu::Lapack.dlar2v # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n* Purpose\n* =======\n*\n* DLAR2V applies a vector of real plane rotations from both sides to\n* a sequence of 2-by-2 real symmetric matrices, defined by the elements\n* of the vectors x, y and z. For i = 1,2,...,n\n*\n* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )\n* ( z(i) y(i) ) ( -s(i) c(i) ) ( 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) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* The vector y.\n*\n* Z (input/output) DOUBLE PRECISION array,\n* 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) DOUBLE PRECISION 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, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_y = argv[2];
- rb_z = argv[3];
- rb_incx = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- n = NUM2INT(rb_n);
- incc = NUM2INT(rb_incc);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (3th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dlar2v_(&n, x, y, z, &incx, c, s, &incc);
-
- return rb_ary_new3(3, rb_x, rb_y, rb_z);
-}
-
-void
-init_lapack_dlar2v(VALUE mLapack){
- rb_define_module_function(mLapack, "dlar2v", rb_dlar2v, -1);
-}
diff --git a/dlarf.c b/dlarf.c
deleted file mode 100644
index 6e917e0..0000000
--- a/dlarf.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarf_(char *side, integer *m, integer *n, doublereal *v, integer *incv, doublereal *tau, doublereal *c, integer *ldc, doublereal *work);
-
-static VALUE
-rb_dlarf(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarf( side, m, v, incv, tau, c)\n or\n NumRu::Lapack.dlarf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* DLARF applies a real elementary reflector H to a real m by n matrix\n* C, from either the left or the right. H is represented in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) DOUBLE PRECISION array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of H.\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 the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\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* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_v = argv[2];
- rb_incv = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- tau = NUM2DBL(rb_tau);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (3th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dlarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_dlarf(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarf", rb_dlarf, -1);
-}
diff --git a/dlarfb.c b/dlarfb.c
deleted file mode 100644
index 9b9200e..0000000
--- a/dlarfb.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, doublereal *v, integer *ldv, doublereal *t, integer *ldt, doublereal *c, integer *ldc, doublereal *work, integer *ldwork);
-
-static VALUE
-rb_dlarfb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer ldv;
- integer k;
- integer ldt;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarfb( side, trans, direct, storev, m, v, t, c)\n or\n NumRu::Lapack.dlarfb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* DLARFB applies a real block reflector H or its transpose H' to a\n* real m by n matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'T': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) DOUBLE PRECISION array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,K)\n* The triangular k by k matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\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 H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_v = argv[5];
- rb_t = argv[6];
- rb_c = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- k = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- direct = StringValueCStr(rb_direct)[0];
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != k)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of v");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (ldwork)*(k));
-
- dlarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_dlarfb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarfb", rb_dlarfb, -1);
-}
diff --git a/dlarfg.c b/dlarfg.c
deleted file mode 100644
index b41969e..0000000
--- a/dlarfg.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarfg_(integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *tau);
-
-static VALUE
-rb_dlarfg(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_x_out__;
- doublereal *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.dlarfg( n, alpha, x, incx)\n or\n NumRu::Lapack.dlarfg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* DLARFG generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, and x is an (n-1)-element real\n* vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n* Otherwise 1 <= tau <= 2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) DOUBLE PRECISION array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) DOUBLE PRECISION\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha = NUM2DBL(rb_alpha);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- dlarfg_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_float_new((double)tau);
- rb_alpha = rb_float_new((double)alpha);
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_dlarfg(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarfg", rb_dlarfg, -1);
-}
diff --git a/dlarfgp.c b/dlarfgp.c
deleted file mode 100644
index f019f55..0000000
--- a/dlarfgp.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarfgp_(integer *n, doublereal *alpha, doublereal *x, integer *incx, doublereal *tau);
-
-static VALUE
-rb_dlarfgp(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_x_out__;
- doublereal *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.dlarfgp( n, alpha, x, incx)\n or\n NumRu::Lapack.dlarfgp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* DLARFGP generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is non-negative, and x is\n* an (n-1)-element real vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) DOUBLE PRECISION array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) DOUBLE PRECISION\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha = NUM2DBL(rb_alpha);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- dlarfgp_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_float_new((double)tau);
- rb_alpha = rb_float_new((double)alpha);
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_dlarfgp(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarfgp", rb_dlarfgp, -1);
-}
diff --git a/dlarft.c b/dlarft.c
deleted file mode 100644
index f35440a..0000000
--- a/dlarft.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarft_(char *direct, char *storev, integer *n, integer *k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, integer *ldt);
-
-static VALUE
-rb_dlarft(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_v_out__;
- doublereal *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.dlarft( direct, storev, n, v, tau)\n or\n NumRu::Lapack.dlarft # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* DLARFT forms the triangular factor T of a real block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) DOUBLE PRECISION array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublereal*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- dlarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_dlarft(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarft", rb_dlarft, -1);
-}
diff --git a/dlarfx.c b/dlarfx.c
deleted file mode 100644
index b7538d3..0000000
--- a/dlarfx.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarfx_(char *side, integer *m, integer *n, doublereal *v, doublereal *tau, doublereal *c, integer *ldc, doublereal *work);
-
-static VALUE
-rb_dlarfx(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarfx( side, v, tau, c)\n or\n NumRu::Lapack.dlarfx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* DLARFX applies a real elementary reflector H to a real m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of H.\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 the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= (1,M).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_side = argv[0];
- rb_v = argv[1];
- rb_tau = argv[2];
- rb_c = argv[3];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (2th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- tau = NUM2DBL(rb_tau);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dlarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_dlarfx(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarfx", rb_dlarfx, -1);
-}
diff --git a/dlargv.c b/dlargv.c
deleted file mode 100644
index edace50..0000000
--- a/dlargv.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlargv_(integer *n, doublereal *x, integer *incx, doublereal *y, integer *incy, doublereal *c, integer *incc);
-
-static VALUE
-rb_dlargv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_incc;
- integer incc;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.dlargv( n, x, incx, y, incy, incc)\n or\n NumRu::Lapack.dlargv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* DLARGV generates a vector of real plane rotations, determined by\n* elements of the real vectors x and y. For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( a(i) )\n* ( -s(i) c(i) ) ( y(i) ) = ( 0 )\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_incc = argv[5];
-
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incc;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dlargv_(&n, x, &incx, y, &incy, c, &incc);
-
- return rb_ary_new3(3, rb_c, rb_x, rb_y);
-}
-
-void
-init_lapack_dlargv(VALUE mLapack){
- rb_define_module_function(mLapack, "dlargv", rb_dlargv, -1);
-}
diff --git a/dlarnv.c b/dlarnv.c
deleted file mode 100644
index 2439590..0000000
--- a/dlarnv.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarnv_(integer *idist, integer *iseed, integer *n, doublereal *x);
-
-static VALUE
-rb_dlarnv(int argc, VALUE *argv, VALUE self){
- VALUE rb_idist;
- integer idist;
- VALUE rb_iseed;
- integer *iseed;
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_iseed_out__;
- integer *iseed_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.dlarnv( idist, iseed, n)\n or\n NumRu::Lapack.dlarnv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* DLARNV returns a vector of n random real numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: uniform (0,1)\n* = 2: uniform (-1,1)\n* = 3: normal (0,1)\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) DOUBLE PRECISION array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine DLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_idist = argv[0];
- rb_iseed = argv[1];
- rb_n = argv[2];
-
- n = NUM2INT(rb_n);
- idist = NUM2INT(rb_idist);
- if (!NA_IsNArray(rb_iseed))
- rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
- if (NA_RANK(rb_iseed) != 1)
- rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iseed) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
- if (NA_TYPE(rb_iseed) != NA_LINT)
- rb_iseed = na_change_type(rb_iseed, NA_LINT);
- iseed = NA_PTR_TYPE(rb_iseed, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 4;
- rb_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iseed_out__ = NA_PTR_TYPE(rb_iseed_out__, integer*);
- MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rb_iseed));
- rb_iseed = rb_iseed_out__;
- iseed = iseed_out__;
-
- dlarnv_(&idist, iseed, &n, x);
-
- return rb_ary_new3(2, rb_x, rb_iseed);
-}
-
-void
-init_lapack_dlarnv(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarnv", rb_dlarnv, -1);
-}
diff --git a/dlarra.c b/dlarra.c
deleted file mode 100644
index 098f2fa..0000000
--- a/dlarra.c
+++ /dev/null
@@ -1,105 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarra_(integer *n, doublereal *d, doublereal *e, doublereal *e2, doublereal *spltol, doublereal *tnrm, integer *nsplit, integer *isplit, integer *info);
-
-static VALUE
-rb_dlarra(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_e2;
- doublereal *e2;
- VALUE rb_spltol;
- doublereal spltol;
- VALUE rb_tnrm;
- doublereal tnrm;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_info;
- integer info;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_e2_out__;
- doublereal *e2_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n nsplit, isplit, info, e, e2 = NumRu::Lapack.dlarra( d, e, e2, spltol, tnrm)\n or\n NumRu::Lapack.dlarra # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n* Purpose\n* =======\n*\n* Compute the splitting points with threshold SPLTOL.\n* DLARRA sets any \"small\" off-diagonal elements to zero.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n* are set to zero, the other entries of E are untouched.\n*\n* E2 (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* SPLTOL (input) DOUBLE PRECISION\n* The threshold for splitting. Two criteria can be used:\n* SPLTOL<0 : criterion based on absolute off-diagonal value\n* SPLTOL>0 : criterion that preserves relative accuracy\n*\n* TNRM (input) DOUBLE PRECISION\n* The norm of the matrix.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_e2 = argv[2];
- rb_spltol = argv[3];
- rb_tnrm = argv[4];
-
- tnrm = NUM2DBL(rb_tnrm);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (3th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e2);
- if (NA_TYPE(rb_e2) != NA_DFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_DFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, doublereal*);
- spltol = NUM2DBL(rb_spltol);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e2");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of e2");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e2_out__ = NA_PTR_TYPE(rb_e2_out__, doublereal*);
- MEMCPY(e2_out__, e2, doublereal, NA_TOTAL(rb_e2));
- rb_e2 = rb_e2_out__;
- e2 = e2_out__;
-
- dlarra_(&n, d, e, e2, &spltol, &tnrm, &nsplit, isplit, &info);
-
- rb_nsplit = INT2NUM(nsplit);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_nsplit, rb_isplit, rb_info, rb_e, rb_e2);
-}
-
-void
-init_lapack_dlarra(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarra", rb_dlarra, -1);
-}
diff --git a/dlarrb.c b/dlarrb.c
deleted file mode 100644
index a4ec2d6..0000000
--- a/dlarrb.c
+++ /dev/null
@@ -1,159 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrb_(integer *n, doublereal *d, doublereal *lld, integer *ifirst, integer *ilast, doublereal *rtol1, doublereal *rtol2, integer *offset, doublereal *w, doublereal *wgap, doublereal *werr, doublereal *work, integer *iwork, doublereal *pivmin, doublereal *spdiam, integer *twist, integer *info);
-
-static VALUE
-rb_dlarrb(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_lld;
- doublereal *lld;
- VALUE rb_ifirst;
- integer ifirst;
- VALUE rb_ilast;
- integer ilast;
- VALUE rb_rtol1;
- doublereal rtol1;
- VALUE rb_rtol2;
- doublereal rtol2;
- VALUE rb_offset;
- integer offset;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_wgap;
- doublereal *wgap;
- VALUE rb_werr;
- doublereal *werr;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_spdiam;
- doublereal spdiam;
- VALUE rb_twist;
- integer twist;
- VALUE rb_info;
- integer info;
- VALUE rb_w_out__;
- doublereal *w_out__;
- VALUE rb_wgap_out__;
- doublereal *wgap_out__;
- VALUE rb_werr_out__;
- doublereal *werr_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, w, wgap, werr = NumRu::Lapack.dlarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist)\n or\n NumRu::Lapack.dlarrb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n* Purpose\n* =======\n*\n* Given the relatively robust representation(RRR) L D L^T, DLARRB\n* does \"limited\" bisection to refine the eigenvalues of L D L^T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses and their gaps are input in WERR\n* and WGAP, respectively. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n* where GAP is the (estimated) distance to the nearest\n* eigenvalue.\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST throug\n* ILAST.\n* On output, these estimates are refined.\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On input, the (estimated) gaps between consecutive\n* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n* then WGAP(IFIRST-OFFSET) must be set to ZERO.\n* On output, these gaps are refined.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence.\n*\n* SPDIAM (input) DOUBLE PRECISION\n* The spectral diameter of the matrix.\n*\n* TWIST (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n*\n* INFO (output) INTEGER\n* Error flag.\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 (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_d = argv[0];
- rb_lld = argv[1];
- rb_ifirst = argv[2];
- rb_ilast = argv[3];
- rb_rtol1 = argv[4];
- rb_rtol2 = argv[5];
- rb_offset = argv[6];
- rb_w = argv[7];
- rb_wgap = argv[8];
- rb_werr = argv[9];
- rb_pivmin = argv[10];
- rb_spdiam = argv[11];
- rb_twist = argv[12];
-
- ilast = NUM2INT(rb_ilast);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (8th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- rtol2 = NUM2DBL(rb_rtol2);
- spdiam = NUM2DBL(rb_spdiam);
- offset = NUM2INT(rb_offset);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- pivmin = NUM2DBL(rb_pivmin);
- twist = NUM2INT(rb_twist);
- rtol1 = NUM2DBL(rb_rtol1);
- ifirst = NUM2INT(rb_ifirst);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (10th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_DFLOAT)
- rb_werr = na_change_type(rb_werr, NA_DFLOAT);
- werr = NA_PTR_TYPE(rb_werr, doublereal*);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_DFLOAT)
- rb_lld = na_change_type(rb_lld, NA_DFLOAT);
- lld = NA_PTR_TYPE(rb_lld, doublereal*);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (9th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", n-1);
- if (NA_TYPE(rb_wgap) != NA_DFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_DFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, doublereal*);
- MEMCPY(w_out__, w, doublereal, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, doublereal*);
- MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, doublereal*);
- MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- work = ALLOC_N(doublereal, (2*n));
- iwork = ALLOC_N(integer, (2*n));
-
- dlarrb_(&n, d, lld, &ifirst, &ilast, &rtol1, &rtol2, &offset, w, wgap, werr, work, iwork, &pivmin, &spdiam, &twist, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_w, rb_wgap, rb_werr);
-}
-
-void
-init_lapack_dlarrb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrb", rb_dlarrb, -1);
-}
diff --git a/dlarrc.c b/dlarrc.c
deleted file mode 100644
index 6b9d85b..0000000
--- a/dlarrc.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrc_(char *jobt, integer *n, doublereal *vl, doublereal *vu, doublereal *d, doublereal *e, doublereal *pivmin, integer *eigcnt, integer *lcnt, integer *rcnt, integer *info);
-
-static VALUE
-rb_dlarrc(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobt;
- char jobt;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_eigcnt;
- integer eigcnt;
- VALUE rb_lcnt;
- integer lcnt;
- VALUE rb_rcnt;
- integer rcnt;
- VALUE rb_info;
- integer info;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n eigcnt, lcnt, rcnt, info = NumRu::Lapack.dlarrc( jobt, vl, vu, d, e, pivmin)\n or\n NumRu::Lapack.dlarrc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n* Purpose\n* =======\n*\n* Find the number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n* if JOBT = 'L'.\n*\n\n* Arguments\n* =========\n*\n* JOBT (input) CHARACTER*1\n* = 'T': Compute Sturm count for matrix T.\n* = 'L': Compute Sturm count for matrix L D L^T.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* The lower and upper bounds for the eigenvalues.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n* JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n*\n* E (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence for T.\n*\n* EIGCNT (output) INTEGER\n* The number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU]\n*\n* LCNT (output) INTEGER\n* RCNT (output) INTEGER\n* The left and right negcounts of the interval.\n*\n* INFO (output) INTEGER\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobt = argv[0];
- rb_vl = argv[1];
- rb_vu = argv[2];
- rb_d = argv[3];
- rb_e = argv[4];
- rb_pivmin = argv[5];
-
- vl = NUM2DBL(rb_vl);
- jobt = StringValueCStr(rb_jobt)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (5th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- vu = NUM2DBL(rb_vu);
- pivmin = NUM2DBL(rb_pivmin);
-
- dlarrc_(&jobt, &n, &vl, &vu, d, e, &pivmin, &eigcnt, &lcnt, &rcnt, &info);
-
- rb_eigcnt = INT2NUM(eigcnt);
- rb_lcnt = INT2NUM(lcnt);
- rb_rcnt = INT2NUM(rcnt);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_eigcnt, rb_lcnt, rb_rcnt, rb_info);
-}
-
-void
-init_lapack_dlarrc(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrc", rb_dlarrc, -1);
-}
diff --git a/dlarrd.c b/dlarrd.c
deleted file mode 100644
index 334835b..0000000
--- a/dlarrd.c
+++ /dev/null
@@ -1,171 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrd_(char *range, char *order, integer *n, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *gers, doublereal *reltol, doublereal *d, doublereal *e, doublereal *e2, doublereal *pivmin, integer *nsplit, integer *isplit, integer *m, doublereal *w, doublereal *werr, doublereal *wl, doublereal *wu, integer *iblock, integer *indexw, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlarrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_range;
- char range;
- VALUE rb_order;
- char order;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_gers;
- doublereal *gers;
- VALUE rb_reltol;
- doublereal reltol;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_e2;
- doublereal *e2;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_werr;
- doublereal *werr;
- VALUE rb_wl;
- doublereal wl;
- VALUE rb_wu;
- doublereal wu;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.dlarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit)\n or\n NumRu::Lapack.dlarrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLARRD computes the eigenvalues of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from DSTEMR.\n* The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* GERS (input) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* RELTOL (input) DOUBLE PRECISION\n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* NSPLIT (input) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalue approximations. DLARRD computes an interval\n* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n* approximation is given as the interval midpoint\n* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n* WERR(j) = abs( a_j - b_j)/2\n*\n* WERR (output) DOUBLE PRECISION array, dimension (N)\n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* WL (output) DOUBLE PRECISION\n* WU (output) DOUBLE PRECISION\n* The interval (WL, WU] contains all the wanted eigenvalues.\n* If RANGE='V', then WL=VL and WU=VU.\n* If RANGE='A', then WL and WU are the global Gerschgorin bounds\n* on the spectrum.\n* If RANGE='I', then WL and WU are computed by DLAEBZ from the\n* index range specified.\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (DLARRD may use the remaining N-M elements as\n* workspace.)\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n* i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE DOUBLE PRECISION, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n* Based on contributions by\n* W. Kahan, University of California, Berkeley, USA\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\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_range = argv[0];
- rb_order = argv[1];
- rb_vl = argv[2];
- rb_vu = argv[3];
- rb_il = argv[4];
- rb_iu = argv[5];
- rb_gers = argv[6];
- rb_reltol = argv[7];
- rb_d = argv[8];
- rb_e = argv[9];
- rb_e2 = argv[10];
- rb_pivmin = argv[11];
- rb_nsplit = argv[12];
- rb_isplit = argv[13];
-
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- pivmin = NUM2DBL(rb_pivmin);
- vu = NUM2DBL(rb_vu);
- nsplit = NUM2INT(rb_nsplit);
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (9th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (14th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- range = StringValueCStr(rb_range)[0];
- order = StringValueCStr(rb_order)[0];
- reltol = NUM2DBL(rb_reltol);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (10th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- if (!NA_IsNArray(rb_gers))
- rb_raise(rb_eArgError, "gers (7th argument) must be NArray");
- if (NA_RANK(rb_gers) != 1)
- rb_raise(rb_eArgError, "rank of gers (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_gers) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
- if (NA_TYPE(rb_gers) != NA_DFLOAT)
- rb_gers = na_change_type(rb_gers, NA_DFLOAT);
- gers = NA_PTR_TYPE(rb_gers, doublereal*);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (11th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e2) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
- if (NA_TYPE(rb_e2) != NA_DFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_DFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- werr = NA_PTR_TYPE(rb_werr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (3*n));
-
- dlarrd_(&range, &order, &n, &vl, &vu, &il, &iu, gers, &reltol, d, e, e2, &pivmin, &nsplit, isplit, &m, w, werr, &wl, &wu, iblock, indexw, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_wl = rb_float_new((double)wl);
- rb_wu = rb_float_new((double)wu);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_werr, rb_wl, rb_wu, rb_iblock, rb_indexw, rb_info);
-}
-
-void
-init_lapack_dlarrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrd", rb_dlarrd, -1);
-}
diff --git a/dlarre.c b/dlarre.c
deleted file mode 100644
index 1bd6dc4..0000000
--- a/dlarre.c
+++ /dev/null
@@ -1,202 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarre_(char *range, integer *n, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *d, doublereal *e, doublereal *e2, doublereal *rtol1, doublereal *rtol2, doublereal *spltol, integer *nsplit, integer *isplit, integer *m, doublereal *w, doublereal *werr, doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers, doublereal *pivmin, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlarre(int argc, VALUE *argv, VALUE self){
- VALUE rb_range;
- char range;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_e2;
- doublereal *e2;
- VALUE rb_rtol1;
- doublereal rtol1;
- VALUE rb_rtol2;
- doublereal rtol2;
- VALUE rb_spltol;
- doublereal spltol;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_werr;
- doublereal *werr;
- VALUE rb_wgap;
- doublereal *wgap;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_gers;
- doublereal *gers;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_e2_out__;
- doublereal *e2_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.dlarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol)\n or\n NumRu::Lapack.dlarre # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* To find the desired eigenvalues of a given real symmetric\n* tridiagonal matrix T, DLARRE sets any \"small\" off-diagonal\n* elements to zero, and for each unreduced block T_i, it finds\n* (a) a suitable shift at one end of the block's spectrum,\n* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n* (c) eigenvalues of each L_i D_i L_i^T.\n* The representations and eigenvalues found are then used by\n* DSTEMR to compute the eigenvectors of T.\n* The accuracy varies depending on whether bisection is used to\n* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to\n* conpute all and then discard any unwanted one.\n* As an added benefit, DLARRE also outputs the n\n* Gerschgorin intervals for the matrices L_i D_i L_i^T.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input/output) DOUBLE PRECISION\n* VU (input/output) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds for the eigenvalues.\n* Eigenvalues less than or equal to VL, or greater than VU,\n* will not be returned. VL < VU.\n* If RANGE='I' or ='A', DLARRE computes bounds on the desired\n* part of the spectrum.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n* On exit, the N diagonal elements of the diagonal\n* matrices D_i.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, E contains the subdiagonal elements of the unit\n* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, contain the base points sigma_i on output.\n*\n* E2 (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* SPLTOL (input) DOUBLE PRECISION\n* The threshold for splitting.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n* M (output) INTEGER\n* The total number of eigenvalues (of all L_i D_i L_i^T)\n* found.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the eigenvalues. The\n* eigenvalues of each of the blocks, L_i D_i L_i^T, are\n* sorted in ascending order ( DLARRE may use the\n* remaining N-M elements as workspace).\n*\n* WERR (output) DOUBLE PRECISION array, dimension (N)\n* The error bound on the corresponding eigenvalue in W.\n*\n* WGAP (output) DOUBLE PRECISION array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n* The gap is only with respect to the eigenvalues of the same block\n* as each block has its own representation tree.\n* Exception: at the right end of a block we store the left gap\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n*\n* GERS (output) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* PIVMIN (output) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence for T.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: A problem occured in DLARRE.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in DLARRD.\n* = 2: No base representation could be found in MAXTRY iterations.\n* Increasing MAXTRY and recompilation might be a remedy.\n* =-3: Problem in DLARRB when computing the refined root\n* representation for DLASQ2.\n* =-4: Problem in DLARRB when preforming bisection on the\n* desired part of the spectrum.\n* =-5: Problem in DLASQ2.\n* =-6: Problem in DLASQ2.\n*\n\n* Further Details\n* The base representations are required to suffer very little\n* element growth and consequently define all their eigenvalues to\n* high relative accuracy.\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 (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_range = argv[0];
- rb_vl = argv[1];
- rb_vu = argv[2];
- rb_il = argv[3];
- rb_iu = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_e2 = argv[7];
- rb_rtol1 = argv[8];
- rb_rtol2 = argv[9];
- rb_spltol = argv[10];
-
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (8th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e2);
- if (NA_TYPE(rb_e2) != NA_DFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_DFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, doublereal*);
- il = NUM2INT(rb_il);
- spltol = NUM2DBL(rb_spltol);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e2");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of e2");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- range = StringValueCStr(rb_range)[0];
- rtol1 = NUM2DBL(rb_rtol1);
- vu = NUM2DBL(rb_vu);
- rtol2 = NUM2DBL(rb_rtol2);
- {
- int shape[1];
- shape[0] = n;
- rb_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- werr = NA_PTR_TYPE(rb_werr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wgap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wgap = NA_PTR_TYPE(rb_wgap, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- {
- int shape[1];
- shape[0] = 2*n;
- rb_gers = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- gers = NA_PTR_TYPE(rb_gers, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e2_out__ = NA_PTR_TYPE(rb_e2_out__, doublereal*);
- MEMCPY(e2_out__, e2, doublereal, NA_TOTAL(rb_e2));
- rb_e2 = rb_e2_out__;
- e2 = e2_out__;
- work = ALLOC_N(doublereal, (6*n));
- iwork = ALLOC_N(integer, (5*n));
-
- dlarre_(&range, &n, &vl, &vu, &il, &iu, d, e, e2, &rtol1, &rtol2, &spltol, &nsplit, isplit, &m, w, werr, wgap, iblock, indexw, gers, &pivmin, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_nsplit = INT2NUM(nsplit);
- rb_m = INT2NUM(m);
- rb_pivmin = rb_float_new((double)pivmin);
- rb_info = INT2NUM(info);
- rb_vl = rb_float_new((double)vl);
- rb_vu = rb_float_new((double)vu);
- return rb_ary_new3(16, rb_nsplit, rb_isplit, rb_m, rb_w, rb_werr, rb_wgap, rb_iblock, rb_indexw, rb_gers, rb_pivmin, rb_info, rb_vl, rb_vu, rb_d, rb_e, rb_e2);
-}
-
-void
-init_lapack_dlarre(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarre", rb_dlarre, -1);
-}
diff --git a/dlarrf.c b/dlarrf.c
deleted file mode 100644
index bd5903b..0000000
--- a/dlarrf.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrf_(integer *n, doublereal *d, doublereal *l, doublereal *ld, integer *clstrt, integer *clend, doublereal *w, doublereal *wgap, doublereal *werr, doublereal *spdiam, doublereal *clgapl, doublereal *clgapr, doublereal *pivmin, doublereal *sigma, doublereal *dplus, doublereal *lplus, doublereal *work, integer *info);
-
-static VALUE
-rb_dlarrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_l;
- doublereal *l;
- VALUE rb_ld;
- doublereal *ld;
- VALUE rb_clstrt;
- integer clstrt;
- VALUE rb_clend;
- integer clend;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_wgap;
- doublereal *wgap;
- VALUE rb_werr;
- doublereal *werr;
- VALUE rb_spdiam;
- doublereal spdiam;
- VALUE rb_clgapl;
- doublereal clgapl;
- VALUE rb_clgapr;
- doublereal clgapr;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_sigma;
- doublereal sigma;
- VALUE rb_dplus;
- doublereal *dplus;
- VALUE rb_lplus;
- doublereal *lplus;
- VALUE rb_info;
- integer info;
- VALUE rb_wgap_out__;
- doublereal *wgap_out__;
- doublereal *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sigma, dplus, lplus, info, wgap = NumRu::Lapack.dlarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin)\n or\n NumRu::Lapack.dlarrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial representation L D L^T and its cluster of close\n* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n* W( CLEND ), DLARRF finds a new relatively robust representation\n* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix (subblock, if the matrix splitted).\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* L (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) subdiagonal elements of the unit bidiagonal\n* matrix L.\n*\n* LD (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) elements L(i)*D(i).\n*\n* CLSTRT (input) INTEGER\n* The index of the first eigenvalue in the cluster.\n*\n* CLEND (input) INTEGER\n* The index of the last eigenvalue in the cluster.\n*\n* W (input) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n* W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n* close eigenalues.\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The separation from the right neighbor eigenvalue in W.\n*\n* WERR (input) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* WERR contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue APPROXIMATION in W\n*\n* SPDIAM (input) DOUBLE PRECISION\n* estimate of the spectral diameter obtained from the\n* Gerschgorin intervals\n*\n* CLGAPL (input) DOUBLE PRECISION\n*\n* CLGAPR (input) DOUBLE PRECISION\n* absolute gap on each end of the cluster.\n* Set by the calling routine to protect against shifts too close\n* to eigenvalues outside the cluster.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* SIGMA (output) DOUBLE PRECISION\n* The shift used to form L(+) D(+) L(+)^T.\n*\n* DPLUS (output) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D(+).\n*\n* LPLUS (output) DOUBLE PRECISION array, dimension (N-1)\n* The first (N-1) elements of LPLUS contain the subdiagonal\n* elements of the unit bidiagonal matrix L(+).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Workspace.\n*\n* INFO (output) INTEGER\n* Signals processing OK (=0) or failure (=1)\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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_d = argv[0];
- rb_l = argv[1];
- rb_ld = argv[2];
- rb_clstrt = argv[3];
- rb_clend = argv[4];
- rb_w = argv[5];
- rb_wgap = argv[6];
- rb_werr = argv[7];
- rb_spdiam = argv[8];
- rb_clgapl = argv[9];
- rb_clgapr = argv[10];
- rb_pivmin = argv[11];
-
- pivmin = NUM2DBL(rb_pivmin);
- clgapl = NUM2DBL(rb_clgapl);
- clend = NUM2INT(rb_clend);
- clgapr = NUM2DBL(rb_clgapr);
- spdiam = NUM2DBL(rb_spdiam);
- clstrt = NUM2INT(rb_clstrt);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_ld))
- rb_raise(rb_eArgError, "ld (3th argument) must be NArray");
- if (NA_RANK(rb_ld) != 1)
- rb_raise(rb_eArgError, "rank of ld (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
- if (NA_TYPE(rb_ld) != NA_DFLOAT)
- rb_ld = na_change_type(rb_ld, NA_DFLOAT);
- ld = NA_PTR_TYPE(rb_ld, doublereal*);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != (clend-clstrt+1))
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be %d", clend-clstrt+1);
- if (NA_TYPE(rb_werr) != NA_DFLOAT)
- rb_werr = na_change_type(rb_werr, NA_DFLOAT);
- werr = NA_PTR_TYPE(rb_werr, doublereal*);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (7th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != (clend-clstrt+1))
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", clend-clstrt+1);
- if (NA_TYPE(rb_wgap) != NA_DFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_DFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, doublereal*);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (2th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
- if (NA_TYPE(rb_l) != NA_DFLOAT)
- rb_l = na_change_type(rb_l, NA_DFLOAT);
- l = NA_PTR_TYPE(rb_l, doublereal*);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (6th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_w) != (clend-clstrt+1))
- rb_raise(rb_eRuntimeError, "shape 0 of w must be %d", clend-clstrt+1);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_dplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dplus = NA_PTR_TYPE(rb_dplus, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_lplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- lplus = NA_PTR_TYPE(rb_lplus, doublereal*);
- {
- int shape[1];
- shape[0] = clend-clstrt+1;
- rb_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, doublereal*);
- MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- dlarrf_(&n, d, l, ld, &clstrt, &clend, w, wgap, werr, &spdiam, &clgapl, &clgapr, &pivmin, &sigma, dplus, lplus, work, &info);
-
- free(work);
- rb_sigma = rb_float_new((double)sigma);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_sigma, rb_dplus, rb_lplus, rb_info, rb_wgap);
-}
-
-void
-init_lapack_dlarrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrf", rb_dlarrf, -1);
-}
diff --git a/dlarrj.c b/dlarrj.c
deleted file mode 100644
index 5ae8c65..0000000
--- a/dlarrj.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrj_(integer *n, doublereal *d, doublereal *e2, integer *ifirst, integer *ilast, doublereal *rtol, integer *offset, doublereal *w, doublereal *werr, doublereal *work, integer *iwork, doublereal *pivmin, doublereal *spdiam, integer *info);
-
-static VALUE
-rb_dlarrj(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e2;
- doublereal *e2;
- VALUE rb_ifirst;
- integer ifirst;
- VALUE rb_ilast;
- integer ilast;
- VALUE rb_rtol;
- doublereal rtol;
- VALUE rb_offset;
- integer offset;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_werr;
- doublereal *werr;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_spdiam;
- doublereal spdiam;
- VALUE rb_info;
- integer info;
- VALUE rb_w_out__;
- doublereal *w_out__;
- VALUE rb_werr_out__;
- doublereal *werr_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, w, werr = NumRu::Lapack.dlarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam)\n or\n NumRu::Lapack.dlarrj # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial eigenvalue approximations of T, DLARRJ\n* does bisection to refine the eigenvalues of T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses in WERR. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of T.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N-1)\n* The Squares of the (N-1) subdiagonal elements of T.\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL (input) DOUBLE PRECISION\n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST through\n* ILAST.\n* On output, these estimates are refined.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence for T.\n*\n* SPDIAM (input) DOUBLE PRECISION\n* The spectral diameter of T.\n*\n* INFO (output) INTEGER\n* Error flag.\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 (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_d = argv[0];
- rb_e2 = argv[1];
- rb_ifirst = argv[2];
- rb_ilast = argv[3];
- rb_rtol = argv[4];
- rb_offset = argv[5];
- rb_w = argv[6];
- rb_werr = argv[7];
- rb_pivmin = argv[8];
- rb_spdiam = argv[9];
-
- ilast = NUM2INT(rb_ilast);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (7th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- rtol = NUM2DBL(rb_rtol);
- offset = NUM2INT(rb_offset);
- spdiam = NUM2DBL(rb_spdiam);
- pivmin = NUM2DBL(rb_pivmin);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_DFLOAT)
- rb_werr = na_change_type(rb_werr, NA_DFLOAT);
- werr = NA_PTR_TYPE(rb_werr, doublereal*);
- ifirst = NUM2INT(rb_ifirst);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (2th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e2) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
- if (NA_TYPE(rb_e2) != NA_DFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_DFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, doublereal*);
- MEMCPY(w_out__, w, doublereal, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, doublereal*);
- MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- work = ALLOC_N(doublereal, (2*n));
- iwork = ALLOC_N(integer, (2*n));
-
- dlarrj_(&n, d, e2, &ifirst, &ilast, &rtol, &offset, w, werr, work, iwork, &pivmin, &spdiam, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_w, rb_werr);
-}
-
-void
-init_lapack_dlarrj(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrj", rb_dlarrj, -1);
-}
diff --git a/dlarrk.c b/dlarrk.c
deleted file mode 100644
index 17d3d6a..0000000
--- a/dlarrk.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrk_(integer *n, integer *iw, doublereal *gl, doublereal *gu, doublereal *d, doublereal *e2, doublereal *pivmin, doublereal *reltol, doublereal *w, doublereal *werr, integer *info);
-
-static VALUE
-rb_dlarrk(int argc, VALUE *argv, VALUE self){
- VALUE rb_iw;
- integer iw;
- VALUE rb_gl;
- doublereal gl;
- VALUE rb_gu;
- doublereal gu;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e2;
- doublereal *e2;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_reltol;
- doublereal reltol;
- VALUE rb_w;
- doublereal w;
- VALUE rb_werr;
- doublereal werr;
- VALUE rb_info;
- integer info;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, werr, info = NumRu::Lapack.dlarrk( iw, gl, gu, d, e2, pivmin, reltol)\n or\n NumRu::Lapack.dlarrk # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n* Purpose\n* =======\n*\n* DLARRK computes one eigenvalue of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from DSTEMR.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* IW (input) INTEGER\n* The index of the eigenvalues to be returned.\n*\n* GL (input) DOUBLE PRECISION\n* GU (input) DOUBLE PRECISION\n* An upper and a lower bound on the eigenvalue.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* RELTOL (input) DOUBLE PRECISION\n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* W (output) DOUBLE PRECISION\n*\n* WERR (output) DOUBLE PRECISION\n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* INFO (output) INTEGER\n* = 0: Eigenvalue converged\n* = -1: Eigenvalue did NOT converge\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE DOUBLE PRECISION, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_iw = argv[0];
- rb_gl = argv[1];
- rb_gu = argv[2];
- rb_d = argv[3];
- rb_e2 = argv[4];
- rb_pivmin = argv[5];
- rb_reltol = argv[6];
-
- pivmin = NUM2DBL(rb_pivmin);
- gu = NUM2DBL(rb_gu);
- iw = NUM2INT(rb_iw);
- gl = NUM2DBL(rb_gl);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- reltol = NUM2DBL(rb_reltol);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (5th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e2) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
- if (NA_TYPE(rb_e2) != NA_DFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_DFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, doublereal*);
-
- dlarrk_(&n, &iw, &gl, &gu, d, e2, &pivmin, &reltol, &w, &werr, &info);
-
- rb_w = rb_float_new((double)w);
- rb_werr = rb_float_new((double)werr);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_w, rb_werr, rb_info);
-}
-
-void
-init_lapack_dlarrk(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrk", rb_dlarrk, -1);
-}
diff --git a/dlarrr.c b/dlarrr.c
deleted file mode 100644
index d5dc612..0000000
--- a/dlarrr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrr_(integer *n, doublereal *d, doublereal *e, integer *info);
-
-static VALUE
-rb_dlarrr(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_info;
- integer info;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, e = NumRu::Lapack.dlarrr( d, e)\n or\n NumRu::Lapack.dlarrr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRR( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* Perform tests to decide whether the symmetric tridiagonal matrix T\n* warrants expensive computations which guarantee high relative accuracy\n* in the eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the tridiagonal matrix T.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) is set to ZERO.\n*\n* INFO (output) INTEGER\n* INFO = 0(default) : the matrix warrants computations preserving\n* relative accuracy.\n* INFO = 1 : the matrix warrants computations guaranteeing\n* only absolute accuracy.\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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- dlarrr_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_e);
-}
-
-void
-init_lapack_dlarrr(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrr", rb_dlarrr, -1);
-}
diff --git a/dlarrv.c b/dlarrv.c
deleted file mode 100644
index d5fd466..0000000
--- a/dlarrv.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarrv_(integer *n, doublereal *vl, doublereal *vu, doublereal *d, doublereal *l, doublereal *pivmin, integer *isplit, integer *m, integer *dol, integer *dou, doublereal *minrgp, doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr, doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers, doublereal *z, integer *ldz, integer *isuppz, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlarrv(int argc, VALUE *argv, VALUE self){
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_l;
- doublereal *l;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_dol;
- integer dol;
- VALUE rb_dou;
- integer dou;
- VALUE rb_minrgp;
- doublereal minrgp;
- VALUE rb_rtol1;
- doublereal rtol1;
- VALUE rb_rtol2;
- doublereal rtol2;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_werr;
- doublereal *werr;
- VALUE rb_wgap;
- doublereal *wgap;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_gers;
- doublereal *gers;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_l_out__;
- doublereal *l_out__;
- VALUE rb_w_out__;
- doublereal *w_out__;
- VALUE rb_werr_out__;
- doublereal *werr_out__;
- VALUE rb_wgap_out__;
- doublereal *wgap_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.dlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers)\n or\n NumRu::Lapack.dlarrv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by DLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by DLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) DOUBLE PRECISION\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from DLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in DLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in DLARRB when refining a child's eigenvalues.\n* =-2: Problem in DLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in DLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 (argc != 18)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
- rb_vl = argv[0];
- rb_vu = argv[1];
- rb_d = argv[2];
- rb_l = argv[3];
- rb_pivmin = argv[4];
- rb_isplit = argv[5];
- rb_m = argv[6];
- rb_dol = argv[7];
- rb_dou = argv[8];
- rb_minrgp = argv[9];
- rb_rtol1 = argv[10];
- rb_rtol2 = argv[11];
- rb_w = argv[12];
- rb_werr = argv[13];
- rb_wgap = argv[14];
- rb_iblock = argv[15];
- rb_indexw = argv[16];
- rb_gers = argv[17];
-
- vl = NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (13th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- dol = NUM2INT(rb_dol);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (4th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of w");
- if (NA_TYPE(rb_l) != NA_DFLOAT)
- rb_l = na_change_type(rb_l, NA_DFLOAT);
- l = NA_PTR_TYPE(rb_l, doublereal*);
- pivmin = NUM2DBL(rb_pivmin);
- dou = NUM2INT(rb_dou);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of w");
- if (NA_TYPE(rb_wgap) != NA_DFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_DFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, doublereal*);
- m = NUM2INT(rb_m);
- minrgp = NUM2DBL(rb_minrgp);
- rtol2 = NUM2DBL(rb_rtol2);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_indexw))
- rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
- if (NA_RANK(rb_indexw) != 1)
- rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
- if (NA_SHAPE0(rb_indexw) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of w");
- if (NA_TYPE(rb_indexw) != NA_LINT)
- rb_indexw = na_change_type(rb_indexw, NA_LINT);
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_DFLOAT)
- rb_werr = na_change_type(rb_werr, NA_DFLOAT);
- werr = NA_PTR_TYPE(rb_werr, doublereal*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- rtol1 = NUM2DBL(rb_rtol1);
- vu = NUM2DBL(rb_vu);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_gers))
- rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
- if (NA_RANK(rb_gers) != 1)
- rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_gers) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
- if (NA_TYPE(rb_gers) != NA_DFLOAT)
- rb_gers = na_change_type(rb_gers, NA_DFLOAT);
- gers = NA_PTR_TYPE(rb_gers, doublereal*);
- ldz = n;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_l_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- l_out__ = NA_PTR_TYPE(rb_l_out__, doublereal*);
- MEMCPY(l_out__, l, doublereal, NA_TOTAL(rb_l));
- rb_l = rb_l_out__;
- l = l_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, doublereal*);
- MEMCPY(w_out__, w, doublereal, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, doublereal*);
- MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, doublereal*);
- MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- work = ALLOC_N(doublereal, (12*n));
- iwork = ALLOC_N(integer, (7*n));
-
- dlarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_z, rb_isuppz, rb_info, rb_d, rb_l, rb_w, rb_werr, rb_wgap);
-}
-
-void
-init_lapack_dlarrv(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarrv", rb_dlarrv, -1);
-}
diff --git a/dlarscl2.c b/dlarscl2.c
deleted file mode 100644
index a534075..0000000
--- a/dlarscl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarscl2_(integer *m, integer *n, doublereal *d, doublereal *x, integer *ldx);
-
-static VALUE
-rb_dlarscl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_x_out__;
- doublereal *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.dlarscl2( d, x)\n or\n NumRu::Lapack.dlarscl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* DLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (M)\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- dlarscl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_dlarscl2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarscl2", rb_dlarscl2, -1);
-}
diff --git a/dlartg.c b/dlartg.c
deleted file mode 100644
index 1a67060..0000000
--- a/dlartg.c
+++ /dev/null
@@ -1,42 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlartg_(doublereal *f, doublereal *g, doublereal *cs, doublereal *sn, doublereal *r);
-
-static VALUE
-rb_dlartg(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- doublereal f;
- VALUE rb_g;
- doublereal g;
- VALUE rb_cs;
- doublereal cs;
- VALUE rb_sn;
- doublereal sn;
- VALUE rb_r;
- doublereal r;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.dlartg( f, g)\n or\n NumRu::Lapack.dlartg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* DLARTG generate a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the BLAS1 routine DROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n* floating point operations (saves work in DBDSQR when\n* there are zeros on the diagonal).\n*\n* If F exceeds G in magnitude, CS will be positive.\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The first component of vector to be rotated.\n*\n* G (input) DOUBLE PRECISION\n* The second component of vector to be rotated.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) DOUBLE PRECISION\n* The sine of the rotation.\n*\n* R (output) DOUBLE PRECISION\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
-
- f = NUM2DBL(rb_f);
- g = NUM2DBL(rb_g);
-
- dlartg_(&f, &g, &cs, &sn, &r);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- rb_r = rb_float_new((double)r);
- return rb_ary_new3(3, rb_cs, rb_sn, rb_r);
-}
-
-void
-init_lapack_dlartg(VALUE mLapack){
- rb_define_module_function(mLapack, "dlartg", rb_dlartg, -1);
-}
diff --git a/dlartgp.c b/dlartgp.c
deleted file mode 100644
index a9d5ff3..0000000
--- a/dlartgp.c
+++ /dev/null
@@ -1,42 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlartgp_(doublereal *f, doublereal *g, doublereal *cs, doublereal *sn, doublereal *r);
-
-static VALUE
-rb_dlartgp(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- doublereal f;
- VALUE rb_g;
- doublereal g;
- VALUE rb_cs;
- doublereal cs;
- VALUE rb_sn;
- doublereal sn;
- VALUE rb_r;
- doublereal r;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.dlartgp( f, g)\n or\n NumRu::Lapack.dlartgp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTGP( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* DLARTGP generates a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the Level 1 BLAS routine DROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=(+/-)1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n*\n* The sign is chosen so that R >= 0.\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The first component of vector to be rotated.\n*\n* G (input) DOUBLE PRECISION\n* The second component of vector to be rotated.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) DOUBLE PRECISION\n* The sine of the rotation.\n*\n* R (output) DOUBLE PRECISION\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
-
- f = NUM2DBL(rb_f);
- g = NUM2DBL(rb_g);
-
- dlartgp_(&f, &g, &cs, &sn, &r);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- rb_r = rb_float_new((double)r);
- return rb_ary_new3(3, rb_cs, rb_sn, rb_r);
-}
-
-void
-init_lapack_dlartgp(VALUE mLapack){
- rb_define_module_function(mLapack, "dlartgp", rb_dlartgp, -1);
-}
diff --git a/dlartgs.c b/dlartgs.c
deleted file mode 100644
index 71da5fe..0000000
--- a/dlartgs.c
+++ /dev/null
@@ -1,43 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlartgs_(doublereal *x, doublereal *y, doublereal *sigma, doublereal *cs, doublereal *sn);
-
-static VALUE
-rb_dlartgs(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublereal x;
- VALUE rb_y;
- doublereal y;
- VALUE rb_sigma;
- doublereal sigma;
- VALUE rb_cs;
- doublereal cs;
- VALUE rb_sn;
- doublereal sn;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn = NumRu::Lapack.dlartgs( x, y, sigma)\n or\n NumRu::Lapack.dlartgs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )\n\n* Purpose\n* =======\n*\n* DLARTGS generates a plane rotation designed to introduce a bulge in\n* Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n* problem. X and Y are the top-row entries, and SIGMA is the shift.\n* The computed CS and SN define a plane rotation satisfying\n*\n* [ CS SN ] . [ X^2 - SIGMA ] = [ R ],\n* [ -SN CS ] [ X * Y ] [ 0 ]\n*\n* with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the\n* rotation is by PI/2.\n*\n\n* Arguments\n* =========\n*\n* X (input) DOUBLE PRECISION\n* The (1,1) entry of an upper bidiagonal matrix.\n*\n* Y (input) DOUBLE PRECISION\n* The (1,2) entry of an upper bidiagonal matrix.\n*\n* SIGMA (input) DOUBLE PRECISION\n* The shift.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) DOUBLE PRECISION\n* The sine of the rotation.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_sigma = argv[2];
-
- x = NUM2DBL(rb_x);
- y = NUM2DBL(rb_y);
- sigma = NUM2DBL(rb_sigma);
-
- dlartgs_(&x, &y, &sigma, &cs, &sn);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- return rb_ary_new3(2, rb_cs, rb_sn);
-}
-
-void
-init_lapack_dlartgs(VALUE mLapack){
- rb_define_module_function(mLapack, "dlartgs", rb_dlartgs, -1);
-}
diff --git a/dlartv.c b/dlartv.c
deleted file mode 100644
index 06527a6..0000000
--- a/dlartv.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlartv_(integer *n, doublereal *x, integer *incx, doublereal *y, integer *incy, doublereal *c, doublereal *s, integer *incc);
-
-static VALUE
-rb_dlartv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.dlartv( n, x, incx, y, incy, c, s, incc)\n or\n NumRu::Lapack.dlartv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* DLARTV applies a vector of real plane rotations to elements of the\n* real vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -s(i) c(i) ) ( y(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) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) DOUBLE PRECISION 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, IY\n DOUBLE PRECISION XI, YI\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- dlartv_(&n, x, &incx, y, &incy, c, s, &incc);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_dlartv(VALUE mLapack){
- rb_define_module_function(mLapack, "dlartv", rb_dlartv, -1);
-}
diff --git a/dlaruv.c b/dlaruv.c
deleted file mode 100644
index 32e2a8d..0000000
--- a/dlaruv.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaruv_(integer *iseed, integer *n, doublereal *x);
-
-static VALUE
-rb_dlaruv(int argc, VALUE *argv, VALUE self){
- VALUE rb_iseed;
- integer *iseed;
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_iseed_out__;
- integer *iseed_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.dlaruv( iseed, n)\n or\n NumRu::Lapack.dlaruv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARUV( ISEED, N, X )\n\n* Purpose\n* =======\n*\n* DLARUV returns a vector of n random real numbers from a uniform (0,1)\n* distribution (n <= 128).\n*\n* This is an auxiliary routine called by DLARNV and ZLARNV.\n*\n\n* Arguments\n* =========\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated. N <= 128.\n*\n* X (output) DOUBLE PRECISION array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine uses a multiplicative congruential method with modulus\n* 2**48 and multiplier 33952834046453 (see G.S.Fishman,\n* 'Multiplicative congruential random number generators with modulus\n* 2**b: an exhaustive analysis for b = 32 and a partial analysis for\n* b = 48', Math. Comp. 189, pp 331-344, 1990).\n*\n* 48-bit integers are stored in 4 integer array elements with 12 bits\n* per element. Hence the routine is portable across machines with\n* integers of 32 bits or more.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_iseed = argv[0];
- rb_n = argv[1];
-
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_iseed))
- rb_raise(rb_eArgError, "iseed (1th argument) must be NArray");
- if (NA_RANK(rb_iseed) != 1)
- rb_raise(rb_eArgError, "rank of iseed (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iseed) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
- if (NA_TYPE(rb_iseed) != NA_LINT)
- rb_iseed = na_change_type(rb_iseed, NA_LINT);
- iseed = NA_PTR_TYPE(rb_iseed, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = 4;
- rb_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iseed_out__ = NA_PTR_TYPE(rb_iseed_out__, integer*);
- MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rb_iseed));
- rb_iseed = rb_iseed_out__;
- iseed = iseed_out__;
-
- dlaruv_(iseed, &n, x);
-
- return rb_ary_new3(2, rb_x, rb_iseed);
-}
-
-void
-init_lapack_dlaruv(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaruv", rb_dlaruv, -1);
-}
diff --git a/dlarz.c b/dlarz.c
deleted file mode 100644
index da77674..0000000
--- a/dlarz.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarz_(char *side, integer *m, integer *n, integer *l, doublereal *v, integer *incv, doublereal *tau, doublereal *c, integer *ldc, doublereal *work);
-
-static VALUE
-rb_dlarz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarz( side, m, l, v, incv, tau, c)\n or\n NumRu::Lapack.dlarz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* DLARZ applies a real elementary reflector H to a real M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n*\n* H is a product of k elementary reflectors as returned by DTZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* DTZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of H.\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 the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\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* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_l = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- tau = NUM2DBL(rb_tau);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1+(l-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dlarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_dlarz(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarz", rb_dlarz, -1);
-}
diff --git a/dlarzb.c b/dlarzb.c
deleted file mode 100644
index 1f75248..0000000
--- a/dlarzb.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarzb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, integer *l, doublereal *v, integer *ldv, doublereal *t, integer *ldt, doublereal *c, integer *ldc, doublereal *work, integer *ldwork);
-
-static VALUE
-rb_dlarzb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer ldv;
- integer nv;
- integer ldt;
- integer k;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarzb( side, trans, direct, storev, m, l, v, t, c)\n or\n NumRu::Lapack.dlarzb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* DLARZB applies a real block reflector H or its transpose H**T to\n* a real distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) DOUBLE PRECISION array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\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 H*C or H'*C or C*H or C*H'.\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 (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_l = argv[5];
- rb_v = argv[6];
- rb_t = argv[7];
- rb_c = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- nv = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- direct = StringValueCStr(rb_direct)[0];
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (8th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
- k = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (ldwork)*(k));
-
- dlarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_dlarzb(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarzb", rb_dlarzb, -1);
-}
diff --git a/dlarzt.c b/dlarzt.c
deleted file mode 100644
index 4bc1477..0000000
--- a/dlarzt.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlarzt_(char *direct, char *storev, integer *n, integer *k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, integer *ldt);
-
-static VALUE
-rb_dlarzt(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_v_out__;
- doublereal *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.dlarzt( direct, storev, n, v, tau)\n or\n NumRu::Lapack.dlarzt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* DLARZT forms the triangular factor T of a real block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) DOUBLE PRECISION array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublereal*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- dlarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_dlarzt(VALUE mLapack){
- rb_define_module_function(mLapack, "dlarzt", rb_dlarzt, -1);
-}
diff --git a/dlas2.c b/dlas2.c
deleted file mode 100644
index d81e663..0000000
--- a/dlas2.c
+++ /dev/null
@@ -1,43 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlas2_(doublereal *f, doublereal *g, doublereal *h, doublereal *ssmin, doublereal *ssmax);
-
-static VALUE
-rb_dlas2(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- doublereal f;
- VALUE rb_g;
- doublereal g;
- VALUE rb_h;
- doublereal h;
- VALUE rb_ssmin;
- doublereal ssmin;
- VALUE rb_ssmax;
- doublereal ssmax;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, ssmax = NumRu::Lapack.dlas2( f, g, h)\n or\n NumRu::Lapack.dlas2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )\n\n* Purpose\n* =======\n*\n* DLAS2 computes the singular values of the 2-by-2 matrix\n* [ F G ]\n* [ 0 H ].\n* On return, SSMIN is the smaller singular value and SSMAX is the\n* larger singular value.\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) DOUBLE PRECISION\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) DOUBLE PRECISION\n* The smaller singular value.\n*\n* SSMAX (output) DOUBLE PRECISION\n* The larger singular value.\n*\n\n* Further Details\n* ===============\n*\n* Barring over/underflow, all output quantities are correct to within\n* a few units in the last place (ulps), even in the absence of a guard\n* digit in addition/subtraction.\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows, or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* ====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
- rb_h = argv[2];
-
- f = NUM2DBL(rb_f);
- g = NUM2DBL(rb_g);
- h = NUM2DBL(rb_h);
-
- dlas2_(&f, &g, &h, &ssmin, &ssmax);
-
- rb_ssmin = rb_float_new((double)ssmin);
- rb_ssmax = rb_float_new((double)ssmax);
- return rb_ary_new3(2, rb_ssmin, rb_ssmax);
-}
-
-void
-init_lapack_dlas2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlas2", rb_dlas2, -1);
-}
diff --git a/dlascl.c b/dlascl.c
deleted file mode 100644
index 2a62e53..0000000
--- a/dlascl.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlascl_(char *type, integer *kl, integer *ku, doublereal *cfrom, doublereal *cto, integer *m, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dlascl(int argc, VALUE *argv, VALUE self){
- VALUE rb_type;
- char type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_cfrom;
- doublereal cfrom;
- VALUE rb_cto;
- doublereal cto;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dlascl( type, kl, ku, cfrom, cto, m, a)\n or\n NumRu::Lapack.dlascl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DLASCL multiplies the M by N real matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See DGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) DOUBLE PRECISION\n* CTO (input) DOUBLE PRECISION\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_type = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_cfrom = argv[3];
- rb_cto = argv[4];
- rb_m = argv[5];
- rb_a = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- cfrom = NUM2DBL(rb_cfrom);
- type = StringValueCStr(rb_type)[0];
- cto = NUM2DBL(rb_cto);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dlascl(VALUE mLapack){
- rb_define_module_function(mLapack, "dlascl", rb_dlascl, -1);
-}
diff --git a/dlascl2.c b/dlascl2.c
deleted file mode 100644
index 44ff6c1..0000000
--- a/dlascl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlascl2_(integer *m, integer *n, doublereal *d, doublereal *x, integer *ldx);
-
-static VALUE
-rb_dlascl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_x_out__;
- doublereal *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.dlascl2( d, x)\n or\n NumRu::Lapack.dlascl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* DLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- dlascl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_dlascl2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlascl2", rb_dlascl2, -1);
-}
diff --git a/dlasd0.c b/dlasd0.c
deleted file mode 100644
index 277e4fe..0000000
--- a/dlasd0.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd0_(integer *n, integer *sqre, doublereal *d, doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, integer *smlsiz, integer *iwork, doublereal *work, integer *info);
-
-static VALUE
-rb_dlasd0(int argc, VALUE *argv, VALUE self){
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- integer *iwork;
- doublereal *work;
-
- integer n;
- integer ldu;
- integer ldvt;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n u, vt, info, d = NumRu::Lapack.dlasd0( sqre, d, e, smlsiz)\n or\n NumRu::Lapack.dlasd0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, DLASD0 computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M\n* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n* The algorithm computes orthogonal matrices U and VT such that\n* B = U * S * VT. The singular values S are overwritten on D.\n*\n* A related subroutine, DLASDA, computes only the singular values,\n* and optionally, the singular vectors in compact form.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the row dimension of the upper bidiagonal matrix.\n* This is also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N+1;\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix.\n* On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) DOUBLE PRECISION array, dimension (M-1)\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N)\n* On exit, U contains the left singular vectors.\n*\n* LDU (input) INTEGER\n* On entry, leading dimension of U.\n*\n* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M)\n* On exit, VT' contains the right singular vectors.\n*\n* LDVT (input) INTEGER\n* On entry, leading dimension of VT.\n*\n* SMLSIZ (input) INTEGER\n* On entry, maximum size of the subproblems at the\n* bottom of the computation tree.\n*\n* IWORK (workspace) INTEGER work array.\n* Dimension must be at least (8 * N)\n*\n* WORK (workspace) DOUBLE PRECISION work array.\n* Dimension must be at least (3 * M**2 + 2 * M)\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n DOUBLE PRECISION ALPHA, BETA\n* ..\n* .. External Subroutines ..\n EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_sqre = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_smlsiz = argv[3];
-
- smlsiz = NUM2INT(rb_smlsiz);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- ldu = n;
- ldvt = n;
- m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- iwork = ALLOC_N(integer, ((8 * n)));
- work = ALLOC_N(doublereal, ((3 * pow(m,2) + 2 * m)));
-
- dlasd0_(&n, &sqre, d, e, u, &ldu, vt, &ldvt, &smlsiz, iwork, work, &info);
-
- free(iwork);
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_u, rb_vt, rb_info, rb_d);
-}
-
-void
-init_lapack_dlasd0(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd0", rb_dlasd0, -1);
-}
diff --git a/dlasd1.c b/dlasd1.c
deleted file mode 100644
index 1b12b04..0000000
--- a/dlasd1.c
+++ /dev/null
@@ -1,145 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd1_(integer *nl, integer *nr, integer *sqre, doublereal *d, doublereal *alpha, doublereal *beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, integer *idxq, integer *iwork, doublereal *work, integer *info);
-
-static VALUE
-rb_dlasd1(int argc, VALUE *argv, VALUE self){
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_u_out__;
- doublereal *u_out__;
- VALUE rb_vt_out__;
- doublereal *vt_out__;
- integer *iwork;
- doublereal *work;
-
- integer n;
- integer ldu;
- integer ldvt;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.dlasd1( nl, nr, sqre, d, alpha, beta, u, vt)\n or\n NumRu::Lapack.dlasd1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.\n*\n* A related subroutine DLASD7 handles the case in which the singular\n* values (and the singular vectors in factored form) are desired.\n*\n* DLASD1 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The left singular vectors of the original matrix are stored in U, and\n* the transpose of the right singular vectors are stored in VT, and the\n* singular values are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or when there are zeros in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLASD2.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the square roots of the\n* roots of the secular equation via the routine DLASD4 (as called\n* by DLASD3). This routine also calculates the singular vectors of\n* the current problem.\n*\n* The final stage consists of computing the updated singular vectors\n* directly using the updated singular values. The singular vectors\n* for the current problem are multiplied with the singular vectors\n* from the overall problem.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) DOUBLE PRECISION array,\n* dimension (N = NL+NR+1).\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block; and D(NL+2:N) contains the singular values of\n* the lower block. On exit D(1:N) contains the singular values\n* of the modified matrix.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n* On entry U(1:NL, 1:NL) contains the left singular vectors of\n* the upper block; U(NL+2:N, NL+2:N) contains the left singular\n* vectors of the lower block. On exit U contains the left\n* singular vectors of the bidiagonal matrix.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max( 1, N ).\n*\n* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n* where M = N + SQRE.\n* On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n* the right singular vectors of the lower block. On exit\n* VT' contains the right singular vectors of the\n* bidiagonal matrix.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= max( 1, M ).\n*\n* IDXQ (output) INTEGER array, dimension(N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension( 4 * N )\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_nl = argv[0];
- rb_nr = argv[1];
- rb_sqre = argv[2];
- rb_d = argv[3];
- rb_alpha = argv[4];
- rb_beta = argv[5];
- rb_u = argv[6];
- rb_vt = argv[7];
-
- alpha = NUM2DBL(rb_alpha);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (7th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_u);
- if (n != (nl+nr+1))
- rb_raise(rb_eRuntimeError, "shape 1 of u must be %d", nl+nr+1);
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_DFLOAT)
- rb_u = na_change_type(rb_u, NA_DFLOAT);
- u = NA_PTR_TYPE(rb_u, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of u");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- nr = NUM2INT(rb_nr);
- beta = NUM2DBL(rb_beta);
- nl = NUM2INT(rb_nl);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vt);
- if (m != (n + sqre))
- rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", n + sqre);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_DFLOAT)
- rb_vt = na_change_type(rb_vt, NA_DFLOAT);
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- sqre = NUM2INT(rb_sqre);
- n = nl+nr+1;
- m = n + sqre;
- {
- int shape[1];
- shape[0] = n;
- rb_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, doublereal*);
- MEMCPY(u_out__, u, doublereal, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, doublereal*);
- MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- iwork = ALLOC_N(integer, (4 * n));
- work = ALLOC_N(doublereal, (3*pow(m,2) + 2*m));
-
- dlasd1_(&nl, &nr, &sqre, d, &alpha, &beta, u, &ldu, vt, &ldvt, idxq, iwork, work, &info);
-
- free(iwork);
- free(work);
- rb_info = INT2NUM(info);
- rb_alpha = rb_float_new((double)alpha);
- rb_beta = rb_float_new((double)beta);
- return rb_ary_new3(7, rb_idxq, rb_info, rb_d, rb_alpha, rb_beta, rb_u, rb_vt);
-}
-
-void
-init_lapack_dlasd1(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd1", rb_dlasd1, -1);
-}
diff --git a/dlasd2.c b/dlasd2.c
deleted file mode 100644
index cb7d925..0000000
--- a/dlasd2.c
+++ /dev/null
@@ -1,209 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd2_(integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d, doublereal *z, doublereal *alpha, doublereal *beta, doublereal *u, integer *ldu, doublereal *vt, integer *ldvt, doublereal *dsigma, doublereal *u2, integer *ldu2, doublereal *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *idxq, integer *coltyp, integer *info);
-
-static VALUE
-rb_dlasd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_k;
- integer k;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_dsigma;
- doublereal *dsigma;
- VALUE rb_u2;
- doublereal *u2;
- VALUE rb_vt2;
- doublereal *vt2;
- VALUE rb_idxc;
- integer *idxc;
- VALUE rb_coltyp;
- integer *coltyp;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_u_out__;
- doublereal *u_out__;
- VALUE rb_vt_out__;
- doublereal *vt_out__;
- VALUE rb_idxq_out__;
- integer *idxq_out__;
- integer *idxp;
- integer *idx;
-
- integer n;
- integer ldu;
- integer ldvt;
- integer m;
- integer ldu2;
- integer ldvt2;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.dlasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq)\n or\n NumRu::Lapack.dlasd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* DLASD2 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* singular values are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n* DLASD2 is called from DLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) DOUBLE PRECISION array, dimension(N)\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) DOUBLE PRECISION array, dimension(N)\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ALPHA (input) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n* On entry U contains the left singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL, NL), and (NL+2, NL+2), (N,N).\n* On exit U contains the trailing (N-K) updated left singular\n* vectors (those which were deflated) in its last N-K columns.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n* On entry VT' contains the right singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n* On exit VT' contains the trailing (N-K) updated right singular\n* vectors (those which were deflated) in its last N-K columns.\n* In case SQRE =1, the last row of VT spans the right null\n* space.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= M.\n*\n* DSIGMA (output) DOUBLE PRECISION array, dimension (N)\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N)\n* Contains a copy of the first K-1 left singular vectors which\n* will be used by DLASD3 in a matrix multiply (DGEMM) to solve\n* for the new left singular vectors. U2 is arranged into four\n* blocks. The first block contains a column with 1 at NL+1 and\n* zero everywhere else; the second block contains non-zero\n* entries only at and above NL; the third contains non-zero\n* entries only below NL+1; and the fourth is dense.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N)\n* VT2' contains a copy of the first K right singular vectors\n* which will be used by DLASD3 in a matrix multiply (DGEMM) to\n* solve for the new right singular vectors. VT2 is arranged into\n* three blocks. The first block contains a row that corresponds\n* to the special 0 diagonal element in SIGMA; the second block\n* contains non-zeros only at and before NL +1; the third block\n* contains non-zeros only at and after NL +2.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= M.\n*\n* IDXP (workspace) INTEGER array dimension(N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDX (workspace) INTEGER array dimension(N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXC (output) INTEGER array dimension(N)\n* This will contain the permutation used to arrange the columns\n* of the deflated U matrix into three groups: the first group\n* contains non-zero entries only at and above NL, the second\n* contains non-zero entries only below NL+2, and the third is\n* dense.\n*\n* IDXQ (input/output) INTEGER array dimension(N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first hlaf of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* COLTYP (workspace/output) INTEGER array dimension(N)\n* As workspace, this will contain a label which will indicate\n* which of the following types a column in the U2 matrix or a\n* row in the VT2 matrix is:\n* 1 : non-zero in the upper half only\n* 2 : non-zero in the lower half only\n* 3 : dense\n* 4 : deflated\n*\n* On exit, it is an array of dimension 4, with COLTYP(I) being\n* the dimension of the I-th type columns.\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* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_nl = argv[0];
- rb_nr = argv[1];
- rb_sqre = argv[2];
- rb_d = argv[3];
- rb_alpha = argv[4];
- rb_beta = argv[5];
- rb_u = argv[6];
- rb_vt = argv[7];
- rb_idxq = argv[8];
-
- if (!NA_IsNArray(rb_idxq))
- rb_raise(rb_eArgError, "idxq (9th argument) must be NArray");
- if (NA_RANK(rb_idxq) != 1)
- rb_raise(rb_eArgError, "rank of idxq (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_idxq);
- if (NA_TYPE(rb_idxq) != NA_LINT)
- rb_idxq = na_change_type(rb_idxq, NA_LINT);
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (7th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of idxq");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_DFLOAT)
- rb_u = na_change_type(rb_u, NA_DFLOAT);
- u = NA_PTR_TYPE(rb_u, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of idxq");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- nr = NUM2INT(rb_nr);
- beta = NUM2DBL(rb_beta);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_DFLOAT)
- rb_vt = na_change_type(rb_vt, NA_DFLOAT);
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- alpha = NUM2DBL(rb_alpha);
- ldu2 = n;
- ldvt2 = m;
- {
- int shape[1];
- shape[0] = n;
- rb_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dsigma = NA_PTR_TYPE(rb_dsigma, doublereal*);
- {
- int shape[2];
- shape[0] = ldu2;
- shape[1] = n;
- rb_u2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u2 = NA_PTR_TYPE(rb_u2, doublereal*);
- {
- int shape[2];
- shape[0] = ldvt2;
- shape[1] = n;
- rb_vt2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt2 = NA_PTR_TYPE(rb_vt2, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_idxc = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxc = NA_PTR_TYPE(rb_idxc, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- coltyp = NA_PTR_TYPE(rb_coltyp, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, doublereal*);
- MEMCPY(u_out__, u, doublereal, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, doublereal*);
- MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_idxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxq_out__ = NA_PTR_TYPE(rb_idxq_out__, integer*);
- MEMCPY(idxq_out__, idxq, integer, NA_TOTAL(rb_idxq));
- rb_idxq = rb_idxq_out__;
- idxq = idxq_out__;
- idxp = ALLOC_N(integer, (n));
- idx = ALLOC_N(integer, (n));
-
- dlasd2_(&nl, &nr, &sqre, &k, d, z, &alpha, &beta, u, &ldu, vt, &ldvt, dsigma, u2, &ldu2, vt2, &ldvt2, idxp, idx, idxc, idxq, coltyp, &info);
-
- free(idxp);
- free(idx);
- rb_k = INT2NUM(k);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_k, rb_z, rb_dsigma, rb_u2, rb_vt2, rb_idxc, rb_coltyp, rb_info, rb_d, rb_u, rb_vt, rb_idxq);
-}
-
-void
-init_lapack_dlasd2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd2", rb_dlasd2, -1);
-}
diff --git a/dlasd3.c b/dlasd3.c
deleted file mode 100644
index 392da6e..0000000
--- a/dlasd3.c
+++ /dev/null
@@ -1,187 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd3_(integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d, doublereal *q, integer *ldq, doublereal *dsigma, doublereal *u, integer *ldu, doublereal *u2, integer *ldu2, doublereal *vt, integer *ldvt, doublereal *vt2, integer *ldvt2, integer *idxc, integer *ctot, doublereal *z, integer *info);
-
-static VALUE
-rb_dlasd3(int argc, VALUE *argv, VALUE self){
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_dsigma;
- doublereal *dsigma;
- VALUE rb_u2;
- doublereal *u2;
- VALUE rb_vt2;
- doublereal *vt2;
- VALUE rb_idxc;
- integer *idxc;
- VALUE rb_ctot;
- integer *ctot;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_info;
- integer info;
- VALUE rb_u2_out__;
- doublereal *u2_out__;
- VALUE rb_vt2_out__;
- doublereal *vt2_out__;
- doublereal *q;
-
- integer k;
- integer ldu2;
- integer n;
- integer ldvt2;
- integer ldu;
- integer ldvt;
- integer m;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, u, vt, info, u2, vt2 = NumRu::Lapack.dlasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z)\n or\n NumRu::Lapack.dlasd3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n* Purpose\n* =======\n*\n* DLASD3 finds all the square roots of the roots of the secular\n* equation, as defined by the values in D and Z. It makes the\n* appropriate calls to DLASD4 and then updates the singular\n* vectors by matrix multiplication.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* DLASD3 is called from DLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (input) INTEGER\n* The size of the secular equation, 1 =< K = < N.\n*\n* D (output) DOUBLE PRECISION array, dimension(K)\n* On exit the square roots of the roots of the secular equation,\n* in ascending order.\n*\n* Q (workspace) DOUBLE PRECISION array,\n* dimension at least (LDQ,K).\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= K.\n*\n* DSIGMA (input) DOUBLE PRECISION array, dimension(K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU, N)\n* The last N - K columns of this matrix contain the deflated\n* left singular vectors.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N)\n* The first K columns of this matrix contain the non-deflated\n* left singular vectors for the split problem.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT, M)\n* The last M - K columns of VT' contain the deflated\n* right singular vectors.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= N.\n*\n* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)\n* The first K columns of VT2' contain the non-deflated\n* right singular vectors for the split problem.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= N.\n*\n* IDXC (input) INTEGER array, dimension ( N )\n* The permutation used to arrange the columns of U (and rows of\n* VT) into three groups: the first group contains non-zero\n* entries only at and above (or before) NL +1; the second\n* contains non-zero entries only at and below (or after) NL+2;\n* and the third is dense. The first column of U and the row of\n* VT are treated separately, however.\n*\n* The rows of the singular vectors found by DLASD4\n* must be likewise permuted before the matrix multiplies can\n* take place.\n*\n* CTOT (input) INTEGER array, dimension ( 4 )\n* A count of the total number of the various types of columns\n* in U (or rows in VT), as described in IDXC. The fourth column\n* type is any column which has been deflated.\n*\n* Z (input) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_nl = argv[0];
- rb_nr = argv[1];
- rb_sqre = argv[2];
- rb_dsigma = argv[3];
- rb_u2 = argv[4];
- rb_vt2 = argv[5];
- rb_idxc = argv[6];
- rb_ctot = argv[7];
- rb_z = argv[8];
-
- if (!NA_IsNArray(rb_ctot))
- rb_raise(rb_eArgError, "ctot (8th argument) must be NArray");
- if (NA_RANK(rb_ctot) != 1)
- rb_raise(rb_eArgError, "rank of ctot (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ctot) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
- if (NA_TYPE(rb_ctot) != NA_LINT)
- rb_ctot = na_change_type(rb_ctot, NA_LINT);
- ctot = NA_PTR_TYPE(rb_ctot, integer*);
- if (!NA_IsNArray(rb_vt2))
- rb_raise(rb_eArgError, "vt2 (6th argument) must be NArray");
- if (NA_RANK(rb_vt2) != 2)
- rb_raise(rb_eArgError, "rank of vt2 (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_vt2);
- if (n != (nl + nr + 1))
- rb_raise(rb_eRuntimeError, "shape 1 of vt2 must be %d", nl + nr + 1);
- ldvt2 = NA_SHAPE0(rb_vt2);
- if (ldvt2 != (n))
- rb_raise(rb_eRuntimeError, "shape 0 of vt2 must be %d", n);
- n = ldvt2;
- if (NA_TYPE(rb_vt2) != NA_DFLOAT)
- rb_vt2 = na_change_type(rb_vt2, NA_DFLOAT);
- vt2 = NA_PTR_TYPE(rb_vt2, doublereal*);
- nl = NUM2INT(rb_nl);
- if (!NA_IsNArray(rb_idxc))
- rb_raise(rb_eArgError, "idxc (7th argument) must be NArray");
- if (NA_RANK(rb_idxc) != 1)
- rb_raise(rb_eArgError, "rank of idxc (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_idxc) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of idxc must be n");
- if (NA_TYPE(rb_idxc) != NA_LINT)
- rb_idxc = na_change_type(rb_idxc, NA_LINT);
- idxc = NA_PTR_TYPE(rb_idxc, integer*);
- if (!NA_IsNArray(rb_u2))
- rb_raise(rb_eArgError, "u2 (5th argument) must be NArray");
- if (NA_RANK(rb_u2) != 2)
- rb_raise(rb_eArgError, "rank of u2 (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u2) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u2 must be n");
- ldu2 = NA_SHAPE0(rb_u2);
- if (ldu2 != (n))
- rb_raise(rb_eRuntimeError, "shape 0 of u2 must be %d", n);
- n = ldu2;
- if (NA_TYPE(rb_u2) != NA_DFLOAT)
- rb_u2 = na_change_type(rb_u2, NA_DFLOAT);
- u2 = NA_PTR_TYPE(rb_u2, doublereal*);
- if (!NA_IsNArray(rb_dsigma))
- rb_raise(rb_eArgError, "dsigma (4th argument) must be NArray");
- if (NA_RANK(rb_dsigma) != 1)
- rb_raise(rb_eArgError, "rank of dsigma (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_dsigma);
- if (NA_TYPE(rb_dsigma) != NA_DFLOAT)
- rb_dsigma = na_change_type(rb_dsigma, NA_DFLOAT);
- dsigma = NA_PTR_TYPE(rb_dsigma, doublereal*);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of dsigma");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- nr = NUM2INT(rb_nr);
- ldu2 = n;
- ldu = n;
- ldvt = n;
- ldvt2 = n;
- ldq = k;
- m = n + sqre;
- {
- int shape[1];
- shape[0] = k;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- {
- int shape[2];
- shape[0] = ldu2;
- shape[1] = n;
- rb_u2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u2_out__ = NA_PTR_TYPE(rb_u2_out__, doublereal*);
- MEMCPY(u2_out__, u2, doublereal, NA_TOTAL(rb_u2));
- rb_u2 = rb_u2_out__;
- u2 = u2_out__;
- {
- int shape[2];
- shape[0] = ldvt2;
- shape[1] = n;
- rb_vt2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt2_out__ = NA_PTR_TYPE(rb_vt2_out__, doublereal*);
- MEMCPY(vt2_out__, vt2, doublereal, NA_TOTAL(rb_vt2));
- rb_vt2 = rb_vt2_out__;
- vt2 = vt2_out__;
- q = ALLOC_N(doublereal, (ldq)*(k));
-
- dlasd3_(&nl, &nr, &sqre, &k, d, q, &ldq, dsigma, u, &ldu, u2, &ldu2, vt, &ldvt, vt2, &ldvt2, idxc, ctot, z, &info);
-
- free(q);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_u, rb_vt, rb_info, rb_u2, rb_vt2);
-}
-
-void
-init_lapack_dlasd3(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd3", rb_dlasd3, -1);
-}
diff --git a/dlasd4.c b/dlasd4.c
deleted file mode 100644
index dc1b3c9..0000000
--- a/dlasd4.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd4_(integer *n, integer *i, doublereal *d, doublereal *z, doublereal *delta, doublereal *rho, doublereal *sigma, doublereal *work, integer *info);
-
-static VALUE
-rb_dlasd4(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_delta;
- doublereal *delta;
- VALUE rb_sigma;
- doublereal sigma;
- VALUE rb_info;
- integer info;
- doublereal *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, sigma, info = NumRu::Lapack.dlasd4( i, d, z, rho)\n or\n NumRu::Lapack.dlasd4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th updated\n* eigenvalue of a positive symmetric rank-one modification to\n* a positive diagonal matrix whose entries are given as the squares\n* of the corresponding entries in the array d, and that\n*\n* 0 <= D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) * diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) DOUBLE PRECISION array, dimension ( N )\n* The original eigenvalues. It is assumed that they are in\n* order, 0 <= D(I) < D(J) for I < J.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( N )\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension ( N )\n* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. The vector DELTA\n* contains the information necessary to construct the\n* (singular) eigenvectors.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* SIGMA (output) DOUBLE PRECISION\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( N )\n* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th\n* component. If N = 1, then WORK( 1 ) = 1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = n;
- rb_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, doublereal*);
- work = ALLOC_N(doublereal, (n));
-
- dlasd4_(&n, &i, d, z, delta, &rho, &sigma, work, &info);
-
- free(work);
- rb_sigma = rb_float_new((double)sigma);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_delta, rb_sigma, rb_info);
-}
-
-void
-init_lapack_dlasd4(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd4", rb_dlasd4, -1);
-}
diff --git a/dlasd5.c b/dlasd5.c
deleted file mode 100644
index 8e958e3..0000000
--- a/dlasd5.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd5_(integer *i, doublereal *d, doublereal *z, doublereal *delta, doublereal *rho, doublereal *dsigma, doublereal *work);
-
-static VALUE
-rb_dlasd5(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_delta;
- doublereal *delta;
- VALUE rb_dsigma;
- doublereal dsigma;
- doublereal *work;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, dsigma = NumRu::Lapack.dlasd5( i, d, z, rho)\n or\n NumRu::Lapack.dlasd5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th eigenvalue\n* of a positive symmetric rank-one modification of a 2-by-2 diagonal\n* matrix\n*\n* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal entries in the array D are assumed to satisfy\n*\n* 0 <= D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) DOUBLE PRECISION array, dimension ( 2 )\n* The original eigenvalues. We assume 0 <= D(1) < D(2).\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 2 )\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension ( 2 )\n* Contains (D(j) - sigma_I) in its j-th component.\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* DSIGMA (output) DOUBLE PRECISION\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 )\n* WORK contains (D(j) + sigma_I) in its j-th component.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = 2;
- rb_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, doublereal*);
- work = ALLOC_N(doublereal, (2));
-
- dlasd5_(&i, d, z, delta, &rho, &dsigma, work);
-
- free(work);
- rb_dsigma = rb_float_new((double)dsigma);
- return rb_ary_new3(2, rb_delta, rb_dsigma);
-}
-
-void
-init_lapack_dlasd5(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd5", rb_dlasd5, -1);
-}
diff --git a/dlasd6.c b/dlasd6.c
deleted file mode 100644
index 89dd454..0000000
--- a/dlasd6.c
+++ /dev/null
@@ -1,218 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd6_(integer *icompq, integer *nl, integer *nr, integer *sqre, doublereal *d, doublereal *vf, doublereal *vl, doublereal *alpha, doublereal *beta, integer *idxq, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *difr, doublereal *z, integer *k, doublereal *c, doublereal *s, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlasd6(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_vf;
- doublereal *vf;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_poles;
- doublereal *poles;
- VALUE rb_difl;
- doublereal *difl;
- VALUE rb_difr;
- doublereal *difr;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_k;
- integer k;
- VALUE rb_c;
- doublereal c;
- VALUE rb_s;
- doublereal s;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_vf_out__;
- doublereal *vf_out__;
- VALUE rb_vl_out__;
- doublereal *vl_out__;
- doublereal *work;
- integer *iwork;
-
- integer m;
- integer n;
- integer ldgcol;
- integer ldgnum;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta)\n or\n NumRu::Lapack.dlasd6 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASD6 computes the SVD of an updated upper bidiagonal matrix B\n* obtained by merging two smaller ones by appending a row. This\n* routine is used only for the problem which requires all singular\n* values and optionally singular vector matrices in factored form.\n* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n* A related subroutine, DLASD1, handles the case in which all singular\n* values and singular vectors of the bidiagonal matrix are desired.\n*\n* DLASD6 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The singular values of B can be computed using D1, D2, the first\n* components of all the right singular vectors of the lower block, and\n* the last components of all the right singular vectors of the upper\n* block. These components are stored and updated in VF and VL,\n* respectively, in DLASD6. Hence U and VT are not explicitly\n* referenced.\n*\n* The singular values are stored in D. The algorithm consists of two\n* stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or if there is a zero\n* in the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLASD7.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the roots of the\n* secular equation via the routine DLASD4 (as called by DLASD8).\n* This routine also updates VF and VL and computes the distances\n* between the updated singular values and the old singular\n* values.\n*\n* DLASD6 is called from DLASDA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block, and D(NL+2:N) contains the singular values\n* of the lower block. On exit D(1:N) contains the singular\n* values of the modified matrix.\n*\n* VF (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors of\n* the lower block. On exit, VL contains the last components of\n* all right singular vectors of the bidiagonal matrix.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* IDXQ (output) INTEGER array, dimension ( N )\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM and POLES, must be at least N.\n*\n* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* On exit, POLES(1,*) is an array containing the new singular\n* values obtained from solving the secular equation, and\n* POLES(2,*) is an array containing the poles in the secular\n* equation. Not referenced if ICOMPQ = 0.\n*\n* DIFL (output) DOUBLE PRECISION array, dimension ( N )\n* On exit, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (output) DOUBLE PRECISION array,\n* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* On exit, DIFR(I, 1) is the distance between I-th updated\n* (undeflated) singular value and the I+1-th (undeflated) old\n* singular value.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* See DLASD8 for details on DIFL and DIFR.\n*\n* Z (output) DOUBLE PRECISION array, dimension ( M )\n* The first elements of this array contain the components\n* of the deflation-adjusted updating row vector.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (output) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M )\n*\n* IWORK (workspace) INTEGER array, dimension ( 3 * N )\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_d = argv[4];
- rb_vf = argv[5];
- rb_vl = argv[6];
- rb_alpha = argv[7];
- rb_beta = argv[8];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
- if (NA_RANK(rb_vl) != 1)
- rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
- m = NA_SHAPE0(rb_vl);
- if (m != (n + sqre))
- rb_raise(rb_eRuntimeError, "shape 0 of vl must be %d", n + sqre);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- alpha = NUM2DBL(rb_alpha);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- nr = NUM2INT(rb_nr);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_vf))
- rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
- if (NA_RANK(rb_vf) != 1)
- rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vf) != m)
- rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
- if (NA_TYPE(rb_vf) != NA_DFLOAT)
- rb_vf = na_change_type(rb_vf, NA_DFLOAT);
- vf = NA_PTR_TYPE(rb_vf, doublereal*);
- beta = NUM2DBL(rb_beta);
- n = nl + nr + 1;
- ldgnum = n;
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (nl+nr+1))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- ldgcol = n;
- m = n + sqre;
- {
- int shape[1];
- shape[0] = n;
- rb_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = 2;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldgnum;
- shape[1] = 2;
- rb_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- {
- int shape[2];
- shape[0] = ldgnum;
- shape[1] = 2;
- rb_poles = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- poles = NA_PTR_TYPE(rb_poles, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- difl = NA_PTR_TYPE(rb_difl, doublereal*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? ldgnum : icompq == 0 ? n : 0;
- shape[1] = icompq == 1 ? 2 : 0;
- rb_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- difr = NA_PTR_TYPE(rb_difr, doublereal*);
- {
- int shape[1];
- shape[0] = m;
- rb_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = nl+nr+1;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vf_out__ = NA_PTR_TYPE(rb_vf_out__, doublereal*);
- MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rb_vf));
- rb_vf = rb_vf_out__;
- vf = vf_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublereal*);
- MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- work = ALLOC_N(doublereal, (4 * m));
- iwork = ALLOC_N(integer, (3 * n));
-
- dlasd6_(&icompq, &nl, &nr, &sqre, d, vf, vl, &alpha, &beta, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_givptr = INT2NUM(givptr);
- rb_k = INT2NUM(k);
- rb_c = rb_float_new((double)c);
- rb_s = rb_float_new((double)s);
- rb_info = INT2NUM(info);
- rb_alpha = rb_float_new((double)alpha);
- rb_beta = rb_float_new((double)beta);
- return rb_ary_new3(18, rb_idxq, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_poles, rb_difl, rb_difr, rb_z, rb_k, rb_c, rb_s, rb_info, rb_d, rb_vf, rb_vl, rb_alpha, rb_beta);
-}
-
-void
-init_lapack_dlasd6(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd6", rb_dlasd6, -1);
-}
diff --git a/dlasd7.c b/dlasd7.c
deleted file mode 100644
index 0188c97..0000000
--- a/dlasd7.c
+++ /dev/null
@@ -1,206 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd7_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *k, doublereal *d, doublereal *z, doublereal *zw, doublereal *vf, doublereal *vfw, doublereal *vl, doublereal *vlw, doublereal *alpha, doublereal *beta, doublereal *dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *c, doublereal *s, integer *info);
-
-static VALUE
-rb_dlasd7(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_vf;
- doublereal *vf;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_k;
- integer k;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_dsigma;
- doublereal *dsigma;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_c;
- doublereal c;
- VALUE rb_s;
- doublereal s;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_vf_out__;
- doublereal *vf_out__;
- VALUE rb_vl_out__;
- doublereal *vl_out__;
- doublereal *zw;
- doublereal *vfw;
- doublereal *vlw;
- integer *idx;
- integer *idxp;
-
- integer n;
- integer m;
- integer ldgcol;
- integer ldgnum;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.dlasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq)\n or\n NumRu::Lapack.dlasd7 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n* Purpose\n* =======\n*\n* DLASD7 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem. There\n* are two ways in which deflation can occur: when two or more singular\n* values are close together or if there is a tiny entry in the Z\n* vector. For each such occurrence the order of the related\n* secular equation problem is reduced by one.\n*\n* DLASD7 is called from DLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper\n* bidiagonal matrix in compact form.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix, this is\n* the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) DOUBLE PRECISION array, dimension ( N )\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) DOUBLE PRECISION array, dimension ( M )\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ZW (workspace) DOUBLE PRECISION array, dimension ( M )\n* Workspace for Z.\n*\n* VF (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VFW (workspace) DOUBLE PRECISION array, dimension ( M )\n* Workspace for VF.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors\n* of the lower block. On exit, VL contains the last components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VLW (workspace) DOUBLE PRECISION array, dimension ( M )\n* Workspace for VL.\n*\n* ALPHA (input) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* DSIGMA (output) DOUBLE PRECISION array, dimension ( N )\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* IDX (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXP (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDXQ (input) INTEGER array, dimension ( N )\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first half of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each singular block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM, must be at least N.\n*\n* C (output) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_d = argv[4];
- rb_vf = argv[5];
- rb_vl = argv[6];
- rb_alpha = argv[7];
- rb_beta = argv[8];
- rb_idxq = argv[9];
-
- if (!NA_IsNArray(rb_idxq))
- rb_raise(rb_eArgError, "idxq (10th argument) must be NArray");
- if (NA_RANK(rb_idxq) != 1)
- rb_raise(rb_eArgError, "rank of idxq (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_idxq);
- if (NA_TYPE(rb_idxq) != NA_LINT)
- rb_idxq = na_change_type(rb_idxq, NA_LINT);
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
- if (NA_RANK(rb_vl) != 1)
- rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
- m = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of idxq");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- nr = NUM2INT(rb_nr);
- alpha = NUM2DBL(rb_alpha);
- beta = NUM2DBL(rb_beta);
- nl = NUM2INT(rb_nl);
- icompq = NUM2INT(rb_icompq);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_vf))
- rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
- if (NA_RANK(rb_vf) != 1)
- rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vf) != m)
- rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
- if (NA_TYPE(rb_vf) != NA_DFLOAT)
- rb_vf = na_change_type(rb_vf, NA_DFLOAT);
- vf = NA_PTR_TYPE(rb_vf, doublereal*);
- ldgcol = n;
- ldgnum = n;
- {
- int shape[1];
- shape[0] = m;
- rb_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dsigma = NA_PTR_TYPE(rb_dsigma, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = 2;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldgnum;
- shape[1] = 2;
- rb_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vf_out__ = NA_PTR_TYPE(rb_vf_out__, doublereal*);
- MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rb_vf));
- rb_vf = rb_vf_out__;
- vf = vf_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublereal*);
- MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- zw = ALLOC_N(doublereal, (m));
- vfw = ALLOC_N(doublereal, (m));
- vlw = ALLOC_N(doublereal, (m));
- idx = ALLOC_N(integer, (n));
- idxp = ALLOC_N(integer, (n));
-
- dlasd7_(&icompq, &nl, &nr, &sqre, &k, d, z, zw, vf, vfw, vl, vlw, &alpha, &beta, dsigma, idx, idxp, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, &c, &s, &info);
-
- free(zw);
- free(vfw);
- free(vlw);
- free(idx);
- free(idxp);
- rb_k = INT2NUM(k);
- rb_givptr = INT2NUM(givptr);
- rb_c = rb_float_new((double)c);
- rb_s = rb_float_new((double)s);
- rb_info = INT2NUM(info);
- return rb_ary_new3(13, rb_k, rb_z, rb_dsigma, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_c, rb_s, rb_info, rb_d, rb_vf, rb_vl);
-}
-
-void
-init_lapack_dlasd7(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd7", rb_dlasd7, -1);
-}
diff --git a/dlasd8.c b/dlasd8.c
deleted file mode 100644
index 69b96b7..0000000
--- a/dlasd8.c
+++ /dev/null
@@ -1,156 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasd8_(integer *icompq, integer *k, doublereal *d, doublereal *z, doublereal *vf, doublereal *vl, doublereal *difl, doublereal *difr, integer *lddifr, doublereal *dsigma, doublereal *work, integer *info);
-
-static VALUE
-rb_dlasd8(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_vf;
- doublereal *vf;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_lddifr;
- integer lddifr;
- VALUE rb_dsigma;
- doublereal *dsigma;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_difl;
- doublereal *difl;
- VALUE rb_difr;
- doublereal *difr;
- VALUE rb_info;
- integer info;
- VALUE rb_z_out__;
- doublereal *z_out__;
- VALUE rb_vf_out__;
- doublereal *vf_out__;
- VALUE rb_vl_out__;
- doublereal *vl_out__;
- VALUE rb_dsigma_out__;
- doublereal *dsigma_out__;
- doublereal *work;
-
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.dlasd8( icompq, z, vf, vl, lddifr, dsigma)\n or\n NumRu::Lapack.dlasd8 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASD8 finds the square roots of the roots of the secular equation,\n* as defined by the values in DSIGMA and Z. It makes the appropriate\n* calls to DLASD4, and stores, for each element in D, the distance\n* to its two nearest poles (elements in DSIGMA). It also updates\n* the arrays VF and VL, the first and last components of all the\n* right singular vectors of the original bidiagonal matrix.\n*\n* DLASD8 is called from DLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form in the calling routine:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved\n* by DLASD4. K >= 1.\n*\n* D (output) DOUBLE PRECISION array, dimension ( K )\n* On output, D contains the updated singular values.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, the first K elements of this array contain the\n* components of the deflation-adjusted updating row vector.\n* On exit, Z is updated.\n*\n* VF (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, VF contains information passed through DBEDE8.\n* On exit, VF contains the first K components of the first\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, VL contains information passed through DBEDE8.\n* On exit, VL contains the first K components of the last\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* DIFL (output) DOUBLE PRECISION array, dimension ( K )\n* On exit, DIFL(I) = D(I) - DSIGMA(I).\n*\n* DIFR (output) DOUBLE PRECISION array,\n* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n* dimension ( K ) if ICOMPQ = 0.\n* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n* defined and will not be referenced.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* LDDIFR (input) INTEGER\n* The leading dimension of DIFR, must be at least K.\n*\n* DSIGMA (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, the first K elements of this array contain the old\n* roots of the deflated updating problem. These are the poles\n* of the secular equation.\n* On exit, the elements of DSIGMA may be very slightly altered\n* in value.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_icompq = argv[0];
- rb_z = argv[1];
- rb_vf = argv[2];
- rb_vl = argv[3];
- rb_lddifr = argv[4];
- rb_dsigma = argv[5];
-
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (4th argument) must be NArray");
- if (NA_RANK(rb_vl) != 1)
- rb_raise(rb_eArgError, "rank of vl (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- if (!NA_IsNArray(rb_dsigma))
- rb_raise(rb_eArgError, "dsigma (6th argument) must be NArray");
- if (NA_RANK(rb_dsigma) != 1)
- rb_raise(rb_eArgError, "rank of dsigma (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dsigma) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of vl");
- if (NA_TYPE(rb_dsigma) != NA_DFLOAT)
- rb_dsigma = na_change_type(rb_dsigma, NA_DFLOAT);
- dsigma = NA_PTR_TYPE(rb_dsigma, doublereal*);
- if (!NA_IsNArray(rb_vf))
- rb_raise(rb_eArgError, "vf (3th argument) must be NArray");
- if (NA_RANK(rb_vf) != 1)
- rb_raise(rb_eArgError, "rank of vf (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vf) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
- if (NA_TYPE(rb_vf) != NA_DFLOAT)
- rb_vf = na_change_type(rb_vf, NA_DFLOAT);
- vf = NA_PTR_TYPE(rb_vf, doublereal*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of vl");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- lddifr = k;
- {
- int shape[1];
- shape[0] = k;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = k;
- rb_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- difl = NA_PTR_TYPE(rb_difl, doublereal*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? lddifr : icompq == 0 ? k : 0;
- shape[1] = icompq == 1 ? 2 : 0;
- rb_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- difr = NA_PTR_TYPE(rb_difr, doublereal*);
- {
- int shape[1];
- shape[0] = k;
- rb_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vf_out__ = NA_PTR_TYPE(rb_vf_out__, doublereal*);
- MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rb_vf));
- rb_vf = rb_vf_out__;
- vf = vf_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublereal*);
- MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_dsigma_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dsigma_out__ = NA_PTR_TYPE(rb_dsigma_out__, doublereal*);
- MEMCPY(dsigma_out__, dsigma, doublereal, NA_TOTAL(rb_dsigma));
- rb_dsigma = rb_dsigma_out__;
- dsigma = dsigma_out__;
- work = ALLOC_N(doublereal, (3 * k));
-
- dlasd8_(&icompq, &k, d, z, vf, vl, difl, difr, &lddifr, dsigma, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_d, rb_difl, rb_difr, rb_info, rb_z, rb_vf, rb_vl, rb_dsigma);
-}
-
-void
-init_lapack_dlasd8(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasd8", rb_dlasd8, -1);
-}
diff --git a/dlasda.c b/dlasda.c
deleted file mode 100644
index f01f745..0000000
--- a/dlasda.c
+++ /dev/null
@@ -1,202 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasda_(integer *icompq, integer *smlsiz, integer *n, integer *sqre, doublereal *d, doublereal *e, doublereal *u, integer *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr, doublereal *z, doublereal *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c, doublereal *s, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dlasda(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_k;
- integer *k;
- VALUE rb_difl;
- doublereal *difl;
- VALUE rb_difr;
- doublereal *difr;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_poles;
- doublereal *poles;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldu;
- integer nlvl;
- integer ldgcol;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.dlasda( icompq, smlsiz, sqre, d, e)\n or\n NumRu::Lapack.dlasda # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, DLASDA computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n* B with diagonal D and offdiagonal E, where M = N + SQRE. The\n* algorithm computes the singular values in the SVD B = U * S * VT.\n* The orthogonal matrices U and VT are optionally computed in\n* compact form.\n*\n* A related subroutine, DLASD0, computes the singular values and\n* the singular vectors in explicit form.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper bidiagonal\n* matrix in compact form.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row dimension of the upper bidiagonal matrix. This is\n* also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N + 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension ( N )\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) DOUBLE PRECISION array, dimension ( M-1 )\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) DOUBLE PRECISION array,\n* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n* GIVNUM, and Z.\n*\n* VT (output) DOUBLE PRECISION array,\n* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* K (output) INTEGER array,\n* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n* secular equation on the computation tree.\n*\n* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),\n* where NLVL = floor(log_2 (N/SMLSIZ))).\n*\n* DIFR (output) DOUBLE PRECISION array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n* record distances between singular values on the I-th\n* level and singular values on the (I -1)-th level, and\n* DIFR(1:N, 2 * I ) contains the normalizing factors for\n* the right singular vector matrix. See DLASD8 for details.\n*\n* Z (output) DOUBLE PRECISION array,\n* dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* The first K elements of Z(1, I) contain the components of\n* the deflation-adjusted updating row vector for subproblems\n* on the I-th level.\n*\n* POLES (output) DOUBLE PRECISION array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n* POLES(1, 2*I) contain the new and old singular values\n* involved in the secular equations on the I-th level.\n*\n* GIVPTR (output) INTEGER array,\n* dimension ( N ) if ICOMPQ = 1, and not referenced if\n* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n* the number of Givens rotations performed on the I-th\n* problem on the computation tree.\n*\n* GIVCOL (output) INTEGER array,\n* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n* of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (output) INTEGER array,\n* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n* permutations done on the I-th level of the computation tree.\n*\n* GIVNUM (output) DOUBLE PRECISION array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n* values of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* C (output) DOUBLE PRECISION array,\n* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (output) DOUBLE PRECISION array, dimension ( N ) if\n* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n* and the I-th subproblem is not square, on exit, S( I )\n* contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n*\n* IWORK (workspace) INTEGER array.\n* Dimension must be at least (7 * N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_icompq = argv[0];
- rb_smlsiz = argv[1];
- rb_sqre = argv[2];
- rb_d = argv[3];
- rb_e = argv[4];
-
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- smlsiz = NUM2INT(rb_smlsiz);
- icompq = NUM2INT(rb_icompq);
- m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
- ldu = n;
- nlvl = floor(1.0/log(2.0)*log((double)n/smlsiz));
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (5th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- ldgcol = n;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = MAX(1,smlsiz);
- rb_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = smlsiz+1;
- rb_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- {
- int shape[1];
- shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
- rb_k = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k = NA_PTR_TYPE(rb_k, integer*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = nlvl;
- rb_difl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- difl = NA_PTR_TYPE(rb_difl, doublereal*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
- shape[1] = icompq == 1 ? 2 * nlvl : 0;
- rb_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- difr = NA_PTR_TYPE(rb_difr, doublereal*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
- shape[1] = icompq == 1 ? nlvl : 0;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = 2 * nlvl;
- rb_poles = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- poles = NA_PTR_TYPE(rb_poles, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_givptr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = 2 * nlvl;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = nlvl;
- rb_perm = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = 2 * nlvl;
- rb_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- {
- int shape[1];
- shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
- {
- int shape[1];
- shape[0] = icompq==1 ? n : icompq==0 ? 1 : 0;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- work = ALLOC_N(doublereal, (6 * n + (smlsiz + 1)*(smlsiz + 1)));
- iwork = ALLOC_N(integer, ((7 * n)));
-
- dlasda_(&icompq, &smlsiz, &n, &sqre, d, e, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(15, rb_u, rb_vt, rb_k, rb_difl, rb_difr, rb_z, rb_poles, rb_givptr, rb_givcol, rb_perm, rb_givnum, rb_c, rb_s, rb_info, rb_d);
-}
-
-void
-init_lapack_dlasda(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasda", rb_dlasda, -1);
-}
diff --git a/dlasdq.c b/dlasdq.c
deleted file mode 100644
index ba35a6a..0000000
--- a/dlasdq.c
+++ /dev/null
@@ -1,167 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasdq_(char *uplo, integer *sqre, integer *n, integer *ncvt, integer *nru, integer *ncc, doublereal *d, doublereal *e, doublereal *vt, integer *ldvt, doublereal *u, integer *ldu, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dlasdq(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_nru;
- integer nru;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_vt_out__;
- doublereal *vt_out__;
- VALUE rb_u_out__;
- doublereal *u_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer n;
- integer ldvt;
- integer ncvt;
- integer ldu;
- integer ldc;
- integer ncc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.dlasdq( uplo, sqre, nru, d, e, vt, u, c)\n or\n NumRu::Lapack.dlasdq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASDQ computes the singular value decomposition (SVD) of a real\n* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n* E, accumulating the transformations if desired. Letting B denote\n* the input bidiagonal matrix, the algorithm computes orthogonal\n* matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n* of P). The singular values S are overwritten on D.\n*\n* The input matrix U is changed to U * Q if desired.\n* The input matrix VT is changed to P' * VT if desired.\n* The input matrix C is changed to Q' * C if desired.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3, for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the input bidiagonal matrix\n* is upper or lower bidiagonal, and wether it is square are\n* not.\n* UPLO = 'U' or 'u' B is upper bidiagonal.\n* UPLO = 'L' or 'l' B is lower bidiagonal.\n*\n* SQRE (input) INTEGER\n* = 0: then the input matrix is N-by-N.\n* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n* (N+1)-by-N if UPLU = 'L'.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of rows and columns\n* in the matrix. N must be at least 0.\n*\n* NCVT (input) INTEGER\n* On entry, NCVT specifies the number of columns of\n* the matrix VT. NCVT must be at least 0.\n*\n* NRU (input) INTEGER\n* On entry, NRU specifies the number of rows of\n* the matrix U. NRU must be at least 0.\n*\n* NCC (input) INTEGER\n* On entry, NCC specifies the number of columns of\n* the matrix C. NCC must be at least 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the diagonal entries of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array.\n* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n* On entry, the entries of E contain the offdiagonal entries\n* of the bidiagonal matrix whose SVD is desired. On normal\n* exit, E will contain 0. If the algorithm does not converge,\n* D and E will contain the diagonal and superdiagonal entries\n* of a bidiagonal matrix orthogonally equivalent to the one\n* given as input.\n*\n* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n* On entry, contains a matrix which on exit has been\n* premultiplied by P', dimension N-by-NCVT if SQRE = 0\n* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n*\n* LDVT (input) INTEGER\n* On entry, LDVT specifies the leading dimension of VT as\n* declared in the calling (sub) program. LDVT must be at\n* least 1. If NCVT is nonzero LDVT must also be at least N.\n*\n* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n* On entry, contains a matrix which on exit has been\n* postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n*\n* LDU (input) INTEGER\n* On entry, LDU specifies the leading dimension of U as\n* declared in the calling (sub) program. LDU must be at\n* least max( 1, NRU ) .\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n* On entry, contains an N-by-NCC matrix which on exit\n* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0\n* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n*\n* LDC (input) INTEGER\n* On entry, LDC specifies the leading dimension of C as\n* declared in the calling (sub) program. LDC must be at\n* least 1. If NCC is nonzero, LDC must also be at least N.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n* Workspace. Only referenced if one of NCVT, NRU, or NCC is\n* nonzero, and if N is at least 2.\n*\n* INFO (output) INTEGER\n* On exit, a value of 0 indicates a successful exit.\n* If INFO < 0, argument number -INFO is illegal.\n* If INFO > 0, the algorithm did not converge, and INFO\n* specifies how many superdiagonals did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_sqre = argv[1];
- rb_nru = argv[2];
- rb_d = argv[3];
- rb_e = argv[4];
- rb_vt = argv[5];
- rb_u = argv[6];
- rb_c = argv[7];
-
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- nru = NUM2INT(rb_nru);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (7th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_DFLOAT)
- rb_u = na_change_type(rb_u, NA_DFLOAT);
- u = NA_PTR_TYPE(rb_u, doublereal*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (6th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (6th argument) must be %d", 2);
- ncvt = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_DFLOAT)
- rb_vt = na_change_type(rb_vt, NA_DFLOAT);
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (5th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (sqre==0 ? n-1 : sqre==1 ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", sqre==0 ? n-1 : sqre==1 ? n : 0);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = sqre==0 ? n-1 : sqre==1 ? n : 0;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = ncvt;
- rb_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, doublereal*);
- MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, doublereal*);
- MEMCPY(u_out__, u, doublereal, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (4*n));
-
- dlasdq_(&uplo, &sqre, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_info, rb_d, rb_e, rb_vt, rb_u, rb_c);
-}
-
-void
-init_lapack_dlasdq(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasdq", rb_dlasdq, -1);
-}
diff --git a/dlasdt.c b/dlasdt.c
deleted file mode 100644
index fbe8303..0000000
--- a/dlasdt.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasdt_(integer *n, integer *lvl, integer *nd, integer *inode, integer *ndiml, integer *ndimr, integer *msub);
-
-static VALUE
-rb_dlasdt(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_msub;
- integer msub;
- VALUE rb_lvl;
- integer lvl;
- VALUE rb_nd;
- integer nd;
- VALUE rb_inode;
- integer *inode;
- VALUE rb_ndiml;
- integer *ndiml;
- VALUE rb_ndimr;
- integer *ndimr;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.dlasdt( n, msub)\n or\n NumRu::Lapack.dlasdt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n* Purpose\n* =======\n*\n* DLASDT creates a tree of subproblems for bidiagonal divide and\n* conquer.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the number of diagonal elements of the\n* bidiagonal matrix.\n*\n* LVL (output) INTEGER\n* On exit, the number of levels on the computation tree.\n*\n* ND (output) INTEGER\n* On exit, the number of nodes on the tree.\n*\n* INODE (output) INTEGER array, dimension ( N )\n* On exit, centers of subproblems.\n*\n* NDIML (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of left children.\n*\n* NDIMR (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of right children.\n*\n* MSUB (input) INTEGER\n* On entry, the maximum row dimension each subproblem at the\n* bottom of the tree can be of.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_n = argv[0];
- rb_msub = argv[1];
-
- n = NUM2INT(rb_n);
- msub = NUM2INT(rb_msub);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_inode = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- inode = NA_PTR_TYPE(rb_inode, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_ndiml = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ndiml = NA_PTR_TYPE(rb_ndiml, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_ndimr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ndimr = NA_PTR_TYPE(rb_ndimr, integer*);
-
- dlasdt_(&n, &lvl, &nd, inode, ndiml, ndimr, &msub);
-
- rb_lvl = INT2NUM(lvl);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(5, rb_lvl, rb_nd, rb_inode, rb_ndiml, rb_ndimr);
-}
-
-void
-init_lapack_dlasdt(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasdt", rb_dlasdt, -1);
-}
diff --git a/dlaset.c b/dlaset.c
deleted file mode 100644
index 9da641e..0000000
--- a/dlaset.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaset_(char *uplo, integer *m, integer *n, doublereal *alpha, doublereal *beta, doublereal *a, integer *lda);
-
-static VALUE
-rb_dlaset(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.dlaset( uplo, m, alpha, beta, a)\n or\n NumRu::Lapack.dlaset # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* DLASET initializes an m-by-n matrix A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set; the strictly lower\n* triangular part of A is not changed.\n* = 'L': Lower triangular part is set; the strictly upper\n* triangular part of A is not changed.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* ALPHA (input) DOUBLE PRECISION\n* The constant to which the offdiagonal elements are to be set.\n*\n* BETA (input) DOUBLE PRECISION\n* The constant to which the diagonal elements are to be set.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the leading m-by-n submatrix of A is set as follows:\n*\n* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n*\n* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_beta = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- beta = NUM2DBL(rb_beta);
- alpha = NUM2DBL(rb_alpha);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_dlaset(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaset", rb_dlaset, -1);
-}
diff --git a/dlasq1.c b/dlasq1.c
deleted file mode 100644
index 738ce6f..0000000
--- a/dlasq1.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasq1_(integer *n, doublereal *d, doublereal *e, doublereal *work, integer *info);
-
-static VALUE
-rb_dlasq1(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- doublereal *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.dlasq1( d, e)\n or\n NumRu::Lapack.dlasq1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ1( N, D, E, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASQ1 computes the singular values of a real N-by-N bidiagonal\n* matrix with diagonal D and off-diagonal E. The singular values\n* are computed to high relative accuracy, in the absence of\n* denormalization, underflow and overflow. The algorithm was first\n* presented in\n*\n* \"Accurate singular values and differential qd algorithms\" by K. V.\n* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n* 1994,\n*\n* and the present implementation is described in \"An implementation of\n* the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the diagonal elements of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in decreasing order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, elements E(1:N-1) contain the off-diagonal elements\n* of the bidiagonal matrix whose SVD is desired.\n* On exit, E is overwritten.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(doublereal, (4*n));
-
- dlasq1_(&n, d, e, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dlasq1(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasq1", rb_dlasq1, -1);
-}
diff --git a/dlasq2.c b/dlasq2.c
deleted file mode 100644
index 1de2282..0000000
--- a/dlasq2.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasq2_(integer *n, doublereal *z, integer *info);
-
-static VALUE
-rb_dlasq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, z = NumRu::Lapack.dlasq2( n, z)\n or\n NumRu::Lapack.dlasq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ2( N, Z, INFO )\n\n* Purpose\n* =======\n*\n* DLASQ2 computes all the eigenvalues of the symmetric positive \n* definite tridiagonal matrix associated with the qd array Z to high\n* relative accuracy are computed to high relative accuracy, in the\n* absence of denormalization, underflow and overflow.\n*\n* To see the relation of Z to the tridiagonal matrix, let L be a\n* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n* let U be an upper bidiagonal matrix with 1's above and diagonal\n* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n* symmetric tridiagonal to which it is similar.\n*\n* Note : DLASQ2 defines a logical variable, IEEE, which is true\n* on machines which follow ieee-754 floating-point standard in their\n* handling of infinities and NaNs, and false otherwise. This variable\n* is passed to DLASQ3.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N )\n* On entry Z holds the qd array. On exit, entries 1 to N hold\n* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n* shifts that failed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if the i-th argument is a scalar and had an illegal\n* value, then INFO = -i, if the i-th argument is an\n* array and the j-entry had an illegal value, then\n* INFO = -(i*100+j)\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* Further Details\n* ===============\n* Local Variables: I0:N0 defines a current unreduced segment of Z.\n* The shifts are accumulated in SIGMA. Iteration count is in ITER.\n* Ping-pong is controlled by PP (alternates between 0 and 1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_n = argv[0];
- rb_z = argv[1];
-
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = 4*n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dlasq2_(&n, z, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_z);
-}
-
-void
-init_lapack_dlasq2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasq2", rb_dlasq2, -1);
-}
diff --git a/dlasq3.c b/dlasq3.c
deleted file mode 100644
index 0f8fb1b..0000000
--- a/dlasq3.c
+++ /dev/null
@@ -1,119 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasq3_(integer *i0, integer *n0, doublereal *z, integer *pp, doublereal *dmin, doublereal *sigma, doublereal *desig, doublereal *qmax, integer *nfail, integer *iter, integer *ndiv, logical *ieee, integer *ttype, doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *g, doublereal *tau);
-
-static VALUE
-rb_dlasq3(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_desig;
- doublereal desig;
- VALUE rb_qmax;
- doublereal qmax;
- VALUE rb_ieee;
- logical ieee;
- VALUE rb_ttype;
- integer ttype;
- VALUE rb_dmin1;
- doublereal dmin1;
- VALUE rb_dmin2;
- doublereal dmin2;
- VALUE rb_dn;
- doublereal dn;
- VALUE rb_dn1;
- doublereal dn1;
- VALUE rb_dn2;
- doublereal dn2;
- VALUE rb_g;
- doublereal g;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_dmin;
- doublereal dmin;
- VALUE rb_sigma;
- doublereal sigma;
- VALUE rb_nfail;
- integer nfail;
- VALUE rb_iter;
- integer iter;
- VALUE rb_ndiv;
- integer ndiv;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.dlasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau)\n or\n NumRu::Lapack.dlasq3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n* Purpose\n* =======\n*\n* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n* In case of failure it changes shifts, and tries again until output\n* is positive.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input/output) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input/output) INTEGER\n* PP=0 for ping, PP=1 for pong.\n* PP=2 indicates that flipping was applied to the Z array \n* and that the initial tests for deflation should not be \n* performed.\n*\n* DMIN (output) DOUBLE PRECISION\n* Minimum value of d.\n*\n* SIGMA (output) DOUBLE PRECISION\n* Sum of shifts used in current segment.\n*\n* DESIG (input/output) DOUBLE PRECISION\n* Lower order part of SIGMA\n*\n* QMAX (input) DOUBLE PRECISION\n* Maximum value of q.\n*\n* NFAIL (output) INTEGER\n* Number of times shift was too big.\n*\n* ITER (output) INTEGER\n* Number of iterations.\n*\n* NDIV (output) INTEGER\n* Number of divisions.\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).\n*\n* TTYPE (input/output) INTEGER\n* Shift type.\n*\n* DMIN1 (input/output) DOUBLE PRECISION\n*\n* DMIN2 (input/output) DOUBLE PRECISION\n*\n* DN (input/output) DOUBLE PRECISION\n*\n* DN1 (input/output) DOUBLE PRECISION\n*\n* DN2 (input/output) DOUBLE PRECISION\n*\n* G (input/output) DOUBLE PRECISION\n*\n* TAU (input/output) DOUBLE PRECISION\n*\n* These are passed as arguments in order to save their values\n* between calls to DLASQ3.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
- rb_desig = argv[4];
- rb_qmax = argv[5];
- rb_ieee = argv[6];
- rb_ttype = argv[7];
- rb_dmin1 = argv[8];
- rb_dmin2 = argv[9];
- rb_dn = argv[10];
- rb_dn1 = argv[11];
- rb_dn2 = argv[12];
- rb_g = argv[13];
- rb_tau = argv[14];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- ttype = NUM2INT(rb_ttype);
- qmax = NUM2DBL(rb_qmax);
- dmin1 = NUM2DBL(rb_dmin1);
- desig = NUM2DBL(rb_desig);
- dmin2 = NUM2DBL(rb_dmin2);
- dn = NUM2DBL(rb_dn);
- dn1 = NUM2DBL(rb_dn1);
- i0 = NUM2INT(rb_i0);
- tau = NUM2DBL(rb_tau);
- dn2 = NUM2DBL(rb_dn2);
- ieee = (rb_ieee == Qtrue);
- g = NUM2DBL(rb_g);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
-
- dlasq3_(&i0, &n0, z, &pp, &dmin, &sigma, &desig, &qmax, &nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau);
-
- rb_dmin = rb_float_new((double)dmin);
- rb_sigma = rb_float_new((double)sigma);
- rb_nfail = INT2NUM(nfail);
- rb_iter = INT2NUM(iter);
- rb_ndiv = INT2NUM(ndiv);
- rb_n0 = INT2NUM(n0);
- rb_pp = INT2NUM(pp);
- rb_desig = rb_float_new((double)desig);
- rb_ttype = INT2NUM(ttype);
- rb_dmin1 = rb_float_new((double)dmin1);
- rb_dmin2 = rb_float_new((double)dmin2);
- rb_dn = rb_float_new((double)dn);
- rb_dn1 = rb_float_new((double)dn1);
- rb_dn2 = rb_float_new((double)dn2);
- rb_g = rb_float_new((double)g);
- rb_tau = rb_float_new((double)tau);
- return rb_ary_new3(16, rb_dmin, rb_sigma, rb_nfail, rb_iter, rb_ndiv, rb_n0, rb_pp, rb_desig, rb_ttype, rb_dmin1, rb_dmin2, rb_dn, rb_dn1, rb_dn2, rb_g, rb_tau);
-}
-
-void
-init_lapack_dlasq3(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasq3", rb_dlasq3, -1);
-}
diff --git a/dlasq4.c b/dlasq4.c
deleted file mode 100644
index ba143f6..0000000
--- a/dlasq4.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasq4_(integer *i0, integer *n0, doublereal *z, integer *pp, integer *n0in, doublereal *dmin, doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2, doublereal *tau, integer *ttype, real *g);
-
-static VALUE
-rb_dlasq4(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_n0in;
- integer n0in;
- VALUE rb_dmin;
- doublereal dmin;
- VALUE rb_dmin1;
- doublereal dmin1;
- VALUE rb_dmin2;
- doublereal dmin2;
- VALUE rb_dn;
- doublereal dn;
- VALUE rb_dn1;
- doublereal dn1;
- VALUE rb_dn2;
- doublereal dn2;
- VALUE rb_g;
- real g;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_ttype;
- integer ttype;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, ttype, g = NumRu::Lapack.dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g)\n or\n NumRu::Lapack.dlasq4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n* Purpose\n* =======\n*\n* DLASQ4 computes an approximation TAU to the smallest eigenvalue\n* using values of d from the previous transform.\n*\n\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* NOIN (input) INTEGER\n* The value of N0 at start of EIGTEST.\n*\n* DMIN (input) DOUBLE PRECISION\n* Minimum value of d.\n*\n* DMIN1 (input) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (input) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (input) DOUBLE PRECISION\n* d(N)\n*\n* DN1 (input) DOUBLE PRECISION\n* d(N-1)\n*\n* DN2 (input) DOUBLE PRECISION\n* d(N-2)\n*\n* TAU (output) DOUBLE PRECISION\n* This is the shift.\n*\n* TTYPE (output) INTEGER\n* Shift type.\n*\n* G (input/output) REAL\n* G is passed as an argument in order to save its value between\n* calls to DLASQ4.\n*\n\n* Further Details\n* ===============\n* CNST1 = 9/16\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
- rb_n0in = argv[4];
- rb_dmin = argv[5];
- rb_dmin1 = argv[6];
- rb_dmin2 = argv[7];
- rb_dn = argv[8];
- rb_dn1 = argv[9];
- rb_dn2 = argv[10];
- rb_g = argv[11];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- dn = NUM2DBL(rb_dn);
- dmin1 = NUM2DBL(rb_dmin1);
- dmin = NUM2DBL(rb_dmin);
- dmin2 = NUM2DBL(rb_dmin2);
- dn2 = NUM2DBL(rb_dn2);
- dn1 = NUM2DBL(rb_dn1);
- n0in = NUM2INT(rb_n0in);
- i0 = NUM2INT(rb_i0);
- g = (real)NUM2DBL(rb_g);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
-
- dlasq4_(&i0, &n0, z, &pp, &n0in, &dmin, &dmin1, &dmin2, &dn, &dn1, &dn2, &tau, &ttype, &g);
-
- rb_tau = rb_float_new((double)tau);
- rb_ttype = INT2NUM(ttype);
- rb_g = rb_float_new((double)g);
- return rb_ary_new3(3, rb_tau, rb_ttype, rb_g);
-}
-
-void
-init_lapack_dlasq4(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasq4", rb_dlasq4, -1);
-}
diff --git a/dlasq5.c b/dlasq5.c
deleted file mode 100644
index b6162a6..0000000
--- a/dlasq5.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasq5_(integer *i0, integer *n0, doublereal *z, integer *pp, doublereal *tau, doublereal *dmin, doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2, logical *ieee);
-
-static VALUE
-rb_dlasq5(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_ieee;
- logical ieee;
- VALUE rb_dmin;
- doublereal dmin;
- VALUE rb_dmin1;
- doublereal dmin1;
- VALUE rb_dmin2;
- doublereal dmin2;
- VALUE rb_dn;
- doublereal dn;
- VALUE rb_dnm1;
- doublereal dnm1;
- VALUE rb_dnm2;
- doublereal dnm2;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq5( i0, n0, z, pp, tau, ieee)\n or\n NumRu::Lapack.dlasq5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n* Purpose\n* =======\n*\n* DLASQ5 computes one dqds transform in ping-pong form, one\n* version for IEEE machines another for non IEEE machines.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* TAU (input) DOUBLE PRECISION\n* This is the shift.\n*\n* DMIN (output) DOUBLE PRECISION\n* Minimum value of d.\n*\n* DMIN1 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) DOUBLE PRECISION\n* d(N0), the last value of d.\n*\n* DNM1 (output) DOUBLE PRECISION\n* d(N0-1).\n*\n* DNM2 (output) DOUBLE PRECISION\n* d(N0-2).\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic.\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n DOUBLE PRECISION D, EMIN, TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
- rb_tau = argv[4];
- rb_ieee = argv[5];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- tau = NUM2DBL(rb_tau);
- ieee = (rb_ieee == Qtrue);
- i0 = NUM2INT(rb_i0);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
-
- dlasq5_(&i0, &n0, z, &pp, &tau, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2, &ieee);
-
- rb_dmin = rb_float_new((double)dmin);
- rb_dmin1 = rb_float_new((double)dmin1);
- rb_dmin2 = rb_float_new((double)dmin2);
- rb_dn = rb_float_new((double)dn);
- rb_dnm1 = rb_float_new((double)dnm1);
- rb_dnm2 = rb_float_new((double)dnm2);
- return rb_ary_new3(6, rb_dmin, rb_dmin1, rb_dmin2, rb_dn, rb_dnm1, rb_dnm2);
-}
-
-void
-init_lapack_dlasq5(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasq5", rb_dlasq5, -1);
-}
diff --git a/dlasq6.c b/dlasq6.c
deleted file mode 100644
index f501b33..0000000
--- a/dlasq6.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasq6_(integer *i0, integer *n0, doublereal *z, integer *pp, doublereal *dmin, doublereal *dmin1, doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2);
-
-static VALUE
-rb_dlasq6(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_dmin;
- doublereal dmin;
- VALUE rb_dmin1;
- doublereal dmin1;
- VALUE rb_dmin2;
- doublereal dmin2;
- VALUE rb_dn;
- doublereal dn;
- VALUE rb_dnm1;
- doublereal dnm1;
- VALUE rb_dnm2;
- doublereal dnm2;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq6( i0, n0, z, pp)\n or\n NumRu::Lapack.dlasq6 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n* Purpose\n* =======\n*\n* DLASQ6 computes one dqd (shift equal to zero) transform in\n* ping-pong form, with protection against underflow and overflow.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* DMIN (output) DOUBLE PRECISION\n* Minimum value of d.\n*\n* DMIN1 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) DOUBLE PRECISION\n* d(N0), the last value of d.\n*\n* DNM1 (output) DOUBLE PRECISION\n* d(N0-1).\n*\n* DNM2 (output) DOUBLE PRECISION\n* d(N0-2).\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n DOUBLE PRECISION D, EMIN, SAFMIN, TEMP\n* ..\n* .. External Function ..\n DOUBLE PRECISION DLAMCH\n EXTERNAL DLAMCH\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- i0 = NUM2INT(rb_i0);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
-
- dlasq6_(&i0, &n0, z, &pp, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2);
-
- rb_dmin = rb_float_new((double)dmin);
- rb_dmin1 = rb_float_new((double)dmin1);
- rb_dmin2 = rb_float_new((double)dmin2);
- rb_dn = rb_float_new((double)dn);
- rb_dnm1 = rb_float_new((double)dnm1);
- rb_dnm2 = rb_float_new((double)dnm2);
- return rb_ary_new3(6, rb_dmin, rb_dmin1, rb_dmin2, rb_dn, rb_dnm1, rb_dnm2);
-}
-
-void
-init_lapack_dlasq6(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasq6", rb_dlasq6, -1);
-}
diff --git a/dlasr.c b/dlasr.c
deleted file mode 100644
index 8c01fd2..0000000
--- a/dlasr.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasr_(char *side, char *pivot, char *direct, integer *m, integer *n, doublereal *c, doublereal *s, doublereal *a, integer *lda);
-
-static VALUE
-rb_dlasr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_pivot;
- char pivot;
- VALUE rb_direct;
- char direct;
- VALUE rb_m;
- integer m;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.dlasr( side, pivot, direct, m, c, s, a)\n or\n NumRu::Lapack.dlasr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* DLASR applies a sequence of plane rotations to a real matrix A,\n* from either the left or the right.\n* \n* When SIDE = 'L', the transformation takes the form\n* \n* A := P*A\n* \n* and when SIDE = 'R', the transformation takes the form\n* \n* A := A*P**T\n* \n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_pivot = argv[1];
- rb_direct = argv[2];
- rb_m = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
- rb_a = argv[6];
-
- direct = StringValueCStr(rb_direct)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- pivot = StringValueCStr(rb_pivot)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_dlasr(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasr", rb_dlasr, -1);
-}
diff --git a/dlasrt.c b/dlasrt.c
deleted file mode 100644
index 18d4c79..0000000
--- a/dlasrt.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasrt_(char *id, integer *n, doublereal *d, integer *info);
-
-static VALUE
-rb_dlasrt(int argc, VALUE *argv, VALUE self){
- VALUE rb_id;
- char id;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d = NumRu::Lapack.dlasrt( id, d)\n or\n NumRu::Lapack.dlasrt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASRT( ID, N, D, INFO )\n\n* Purpose\n* =======\n*\n* Sort the numbers in D in increasing order (if ID = 'I') or\n* in decreasing order (if ID = 'D' ).\n*\n* Use Quick Sort, reverting to Insertion sort on arrays of\n* size <= 20. Dimension of STACK limits N to about 2**32.\n*\n\n* Arguments\n* =========\n*\n* ID (input) CHARACTER*1\n* = 'I': sort D in increasing order;\n* = 'D': sort D in decreasing order.\n*\n* N (input) INTEGER\n* The length of the array D.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the array to be sorted.\n* On exit, D has been sorted into increasing order\n* (D(1) <= ... <= D(N) ) or into decreasing order\n* (D(1) >= ... >= D(N) ), depending on ID.\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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_id = argv[0];
- rb_d = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- id = StringValueCStr(rb_id)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- dlasrt_(&id, &n, d, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_d);
-}
-
-void
-init_lapack_dlasrt(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasrt", rb_dlasrt, -1);
-}
diff --git a/dlassq.c b/dlassq.c
deleted file mode 100644
index 529dfa0..0000000
--- a/dlassq.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlassq_(integer *n, doublereal *x, integer *incx, doublereal *scale, doublereal *sumsq);
-
-static VALUE
-rb_dlassq(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_sumsq;
- doublereal sumsq;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.dlassq( x, incx, scale, sumsq)\n or\n NumRu::Lapack.dlassq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* DLASSQ returns the values scl and smsq such that\n*\n* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is\n* assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( x( i ) ) ).\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ and\n* scl and smsq are overwritten on SCALE and SUMSQ respectively.\n*\n* The routine makes only one pass through the vector x.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) DOUBLE PRECISION array, dimension (N)\n* The vector for which a scaled sum of squares is computed.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) DOUBLE PRECISION\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with scl , the scaling factor\n* for the sum of squares.\n*\n* SUMSQ (input/output) DOUBLE PRECISION\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with smsq , the basic sum of\n* squares from which scl has been factored out.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_incx = argv[1];
- rb_scale = argv[2];
- rb_sumsq = argv[3];
-
- scale = NUM2DBL(rb_scale);
- sumsq = NUM2DBL(rb_sumsq);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- incx = NUM2INT(rb_incx);
-
- dlassq_(&n, x, &incx, &scale, &sumsq);
-
- rb_scale = rb_float_new((double)scale);
- rb_sumsq = rb_float_new((double)sumsq);
- return rb_ary_new3(2, rb_scale, rb_sumsq);
-}
-
-void
-init_lapack_dlassq(VALUE mLapack){
- rb_define_module_function(mLapack, "dlassq", rb_dlassq, -1);
-}
diff --git a/dlasv2.c b/dlasv2.c
deleted file mode 100644
index 9645b0d..0000000
--- a/dlasv2.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasv2_(doublereal *f, doublereal *g, doublereal *h, doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal *csr, doublereal *snl, doublereal *csl);
-
-static VALUE
-rb_dlasv2(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- doublereal f;
- VALUE rb_g;
- doublereal g;
- VALUE rb_h;
- doublereal h;
- VALUE rb_ssmin;
- doublereal ssmin;
- VALUE rb_ssmax;
- doublereal ssmax;
- VALUE rb_snr;
- doublereal snr;
- VALUE rb_csr;
- doublereal csr;
- VALUE rb_snl;
- doublereal snl;
- VALUE rb_csl;
- doublereal csl;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.dlasv2( f, g, h)\n or\n NumRu::Lapack.dlasv2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n* Purpose\n* =======\n*\n* DLASV2 computes the singular value decomposition of a 2-by-2\n* triangular matrix\n* [ F G ]\n* [ 0 H ].\n* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n* right singular vectors for abs(SSMAX), giving the decomposition\n*\n* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]\n* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) DOUBLE PRECISION\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) DOUBLE PRECISION\n* abs(SSMIN) is the smaller singular value.\n*\n* SSMAX (output) DOUBLE PRECISION\n* abs(SSMAX) is the larger singular value.\n*\n* SNL (output) DOUBLE PRECISION\n* CSL (output) DOUBLE PRECISION\n* The vector (CSL, SNL) is a unit left singular vector for the\n* singular value abs(SSMAX).\n*\n* SNR (output) DOUBLE PRECISION\n* CSR (output) DOUBLE PRECISION\n* The vector (CSR, SNR) is a unit right singular vector for the\n* singular value abs(SSMAX).\n*\n\n* Further Details\n* ===============\n*\n* Any input parameter may be aliased with any output parameter.\n*\n* Barring over/underflow and assuming a guard digit in subtraction, all\n* output quantities are correct to within a few units in the last\n* place (ulps).\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
- rb_h = argv[2];
-
- f = NUM2DBL(rb_f);
- g = NUM2DBL(rb_g);
- h = NUM2DBL(rb_h);
-
- dlasv2_(&f, &g, &h, &ssmin, &ssmax, &snr, &csr, &snl, &csl);
-
- rb_ssmin = rb_float_new((double)ssmin);
- rb_ssmax = rb_float_new((double)ssmax);
- rb_snr = rb_float_new((double)snr);
- rb_csr = rb_float_new((double)csr);
- rb_snl = rb_float_new((double)snl);
- rb_csl = rb_float_new((double)csl);
- return rb_ary_new3(6, rb_ssmin, rb_ssmax, rb_snr, rb_csr, rb_snl, rb_csl);
-}
-
-void
-init_lapack_dlasv2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasv2", rb_dlasv2, -1);
-}
diff --git a/dlaswp.c b/dlaswp.c
deleted file mode 100644
index b19ac6f..0000000
--- a/dlaswp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlaswp_(integer *n, doublereal *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx);
-
-static VALUE
-rb_dlaswp(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_k1;
- integer k1;
- VALUE rb_k2;
- integer k2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_incx;
- integer incx;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.dlaswp( a, k1, k2, ipiv, incx)\n or\n NumRu::Lapack.dlaswp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* DLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n DOUBLE PRECISION TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_k1 = argv[1];
- rb_k2 = argv[2];
- rb_ipiv = argv[3];
- rb_incx = argv[4];
-
- k2 = NUM2INT(rb_k2);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- k1 = NUM2INT(rb_k1);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != (k2*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
-
- return rb_a;
-}
-
-void
-init_lapack_dlaswp(VALUE mLapack){
- rb_define_module_function(mLapack, "dlaswp", rb_dlaswp, -1);
-}
diff --git a/dlasy2.c b/dlasy2.c
deleted file mode 100644
index 413a477..0000000
--- a/dlasy2.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasy2_(logical *ltranl, logical *ltranr, integer *isgn, integer *n1, integer *n2, doublereal *tl, integer *ldtl, doublereal *tr, integer *ldtr, doublereal *b, integer *ldb, doublereal *scale, doublereal *x, integer *ldx, doublereal *xnorm, integer *info);
-
-static VALUE
-rb_dlasy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ltranl;
- logical ltranl;
- VALUE rb_ltranr;
- logical ltranr;
- VALUE rb_isgn;
- integer isgn;
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_tl;
- doublereal *tl;
- VALUE rb_tr;
- doublereal *tr;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_xnorm;
- doublereal xnorm;
- VALUE rb_info;
- integer info;
-
- integer ldtl;
- integer ldtr;
- integer ldb;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, x, xnorm, info = NumRu::Lapack.dlasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b)\n or\n NumRu::Lapack.dlasy2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n*\n* op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n*\n* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n* -1. op(T) = T or T', where T' denotes the transpose of T.\n*\n\n* Arguments\n* =========\n*\n* LTRANL (input) LOGICAL\n* On entry, LTRANL specifies the op(TL):\n* = .FALSE., op(TL) = TL,\n* = .TRUE., op(TL) = TL'.\n*\n* LTRANR (input) LOGICAL\n* On entry, LTRANR specifies the op(TR):\n* = .FALSE., op(TR) = TR,\n* = .TRUE., op(TR) = TR'.\n*\n* ISGN (input) INTEGER\n* On entry, ISGN specifies the sign of the equation\n* as described before. ISGN may only be 1 or -1.\n*\n* N1 (input) INTEGER\n* On entry, N1 specifies the order of matrix TL.\n* N1 may only be 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* On entry, N2 specifies the order of matrix TR.\n* N2 may only be 0, 1 or 2.\n*\n* TL (input) DOUBLE PRECISION array, dimension (LDTL,2)\n* On entry, TL contains an N1 by N1 matrix.\n*\n* LDTL (input) INTEGER\n* The leading dimension of the matrix TL. LDTL >= max(1,N1).\n*\n* TR (input) DOUBLE PRECISION array, dimension (LDTR,2)\n* On entry, TR contains an N2 by N2 matrix.\n*\n* LDTR (input) INTEGER\n* The leading dimension of the matrix TR. LDTR >= max(1,N2).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,2)\n* On entry, the N1 by N2 matrix B contains the right-hand\n* side of the equation.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1,N1).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* less than or equal to 1 to prevent the solution overflowing.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,2)\n* On exit, X contains the N1 by N2 solution.\n*\n* LDX (input) INTEGER\n* The leading dimension of the matrix X. LDX >= max(1,N1).\n*\n* XNORM (output) DOUBLE PRECISION\n* On exit, XNORM is the infinity-norm of the solution.\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: TL and TR have too close eigenvalues, so TL or\n* TR is perturbed to get a nonsingular equation.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_ltranl = argv[0];
- rb_ltranr = argv[1];
- rb_isgn = argv[2];
- rb_n1 = argv[3];
- rb_n2 = argv[4];
- rb_tl = argv[5];
- rb_tr = argv[6];
- rb_b = argv[7];
-
- ltranl = (rb_ltranl == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_tl))
- rb_raise(rb_eArgError, "tl (6th argument) must be NArray");
- if (NA_RANK(rb_tl) != 2)
- rb_raise(rb_eArgError, "rank of tl (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_tl) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of tl must be %d", 2);
- ldtl = NA_SHAPE0(rb_tl);
- if (NA_TYPE(rb_tl) != NA_DFLOAT)
- rb_tl = na_change_type(rb_tl, NA_DFLOAT);
- tl = NA_PTR_TYPE(rb_tl, doublereal*);
- n1 = NUM2INT(rb_n1);
- isgn = NUM2INT(rb_isgn);
- ltranr = (rb_ltranr == Qtrue);
- if (!NA_IsNArray(rb_tr))
- rb_raise(rb_eArgError, "tr (7th argument) must be NArray");
- if (NA_RANK(rb_tr) != 2)
- rb_raise(rb_eArgError, "rank of tr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_tr) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of tr must be %d", 2);
- ldtr = NA_SHAPE0(rb_tr);
- if (NA_TYPE(rb_tr) != NA_DFLOAT)
- rb_tr = na_change_type(rb_tr, NA_DFLOAT);
- tr = NA_PTR_TYPE(rb_tr, doublereal*);
- n2 = NUM2INT(rb_n2);
- ldx = MAX(1,n1);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = 2;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
-
- dlasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &ldtl, tr, &ldtr, b, &ldb, &scale, x, &ldx, &xnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_xnorm = rb_float_new((double)xnorm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_x, rb_xnorm, rb_info);
-}
-
-void
-init_lapack_dlasy2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasy2", rb_dlasy2, -1);
-}
diff --git a/dlasyf.c b/dlasyf.c
deleted file mode 100644
index 394b118..0000000
--- a/dlasyf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlasyf_(char *uplo, integer *n, integer *nb, integer *kb, doublereal *a, integer *lda, integer *ipiv, doublereal *w, integer *ldw, integer *info);
-
-static VALUE
-rb_dlasyf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *w;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.dlasyf( uplo, nb, a)\n or\n NumRu::Lapack.dlasyf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* DLASYF computes a partial factorization of a real symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n*\n* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) DOUBLE PRECISION 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- w = ALLOC_N(doublereal, (ldw)*(MAX(1,nb)));
-
- dlasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
-
- free(w);
- rb_kb = INT2NUM(kb);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_kb, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_dlasyf(VALUE mLapack){
- rb_define_module_function(mLapack, "dlasyf", rb_dlasyf, -1);
-}
diff --git a/dlat2s.c b/dlat2s.c
deleted file mode 100644
index e4ca53f..0000000
--- a/dlat2s.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlat2s_(char *uplo, integer *n, doublereal *a, integer *lda, real *sa, integer *ldsa, integer *info);
-
-static VALUE
-rb_dlat2s(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_sa;
- real *sa;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer ldsa;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.dlat2s( uplo, a)\n or\n NumRu::Lapack.dlat2s # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE\n* PRECISION triangular matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* DLAS2S checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\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* N (input) INTEGER\n* The number of rows and columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N triangular coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SA (output) REAL array, dimension (LDSA,N)\n* Only the UPLO part of SA is referenced. On exit, if INFO=0,\n* the N-by-N coefficient matrix SA; if INFO>0, the content of\n* the UPLO part of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of the UPLO part of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n LOGICAL UPPER\n* ..\n* .. External Functions ..\n REAL SLAMCH\n LOGICAL LSAME\n EXTERNAL SLAMCH, LSAME\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- ldsa = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldsa;
- shape[1] = n;
- rb_sa = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- sa = NA_PTR_TYPE(rb_sa, real*);
-
- dlat2s_(&uplo, &n, a, &lda, sa, &ldsa, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_sa, rb_info);
-}
-
-void
-init_lapack_dlat2s(VALUE mLapack){
- rb_define_module_function(mLapack, "dlat2s", rb_dlat2s, -1);
-}
diff --git a/dlatbs.c b/dlatbs.c
deleted file mode 100644
index d26ae85..0000000
--- a/dlatbs.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlatbs_(char *uplo, char *trans, char *diag, char *normin, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *x, doublereal *scale, doublereal *cnorm, integer *info);
-
-static VALUE
-rb_dlatbs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_cnorm;
- doublereal *cnorm;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_cnorm_out__;
- doublereal *cnorm_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.dlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm)\n or\n NumRu::Lapack.dlatbs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLATBS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, DTBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_kd = argv[4];
- rb_ab = argv[5];
- rb_x = argv[6];
- rb_cnorm = argv[7];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_DFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_DFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, doublereal*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of cnorm");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, doublereal*);
- MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- dlatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_dlatbs(VALUE mLapack){
- rb_define_module_function(mLapack, "dlatbs", rb_dlatbs, -1);
-}
diff --git a/dlatdf.c b/dlatdf.c
deleted file mode 100644
index a8361ca..0000000
--- a/dlatdf.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlatdf_(integer *ijob, integer *n, doublereal *z, integer *ldz, doublereal *rhs, doublereal *rdsum, doublereal *rdscal, integer *ipiv, integer *jpiv);
-
-static VALUE
-rb_dlatdf(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_rhs;
- doublereal *rhs;
- VALUE rb_rdsum;
- doublereal rdsum;
- VALUE rb_rdscal;
- doublereal rdscal;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_rhs_out__;
- doublereal *rhs_out__;
-
- integer ldz;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.dlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv)\n or\n NumRu::Lapack.dlatdf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* DLATDF uses the LU factorization of the n-by-n matrix Z computed by\n* DGETC2 and computes a contribution to the reciprocal Dif-estimate\n* by solving Z * x = b for x, and choosing the r.h.s. b such that\n* the norm of x is as large as possible. On entry RHS = b holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,\n* where P and Q are permutation matrices. L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using DGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value\n* of 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where all entries of\n* the r.h.s. b is choosen as either +1 or -1 (Default).\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by DGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries acoording to the value of IJOB (see above).\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by DTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when DTGSY2 is called by\n* DTGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report IMINF-95.05, Departement of\n* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_ijob = argv[0];
- rb_z = argv[1];
- rb_rhs = argv[2];
- rb_rdsum = argv[3];
- rb_rdscal = argv[4];
- rb_ipiv = argv[5];
- rb_jpiv = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- rdscal = NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of ipiv");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- rdsum = NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_DFLOAT)
- rb_rhs = na_change_type(rb_rhs, NA_DFLOAT);
- rhs = NA_PTR_TYPE(rb_rhs, doublereal*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, doublereal*);
- MEMCPY(rhs_out__, rhs, doublereal, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- dlatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
-
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(3, rb_rhs, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_dlatdf(VALUE mLapack){
- rb_define_module_function(mLapack, "dlatdf", rb_dlatdf, -1);
-}
diff --git a/dlatps.c b/dlatps.c
deleted file mode 100644
index a949dc7..0000000
--- a/dlatps.c
+++ /dev/null
@@ -1,105 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlatps_(char *uplo, char *trans, char *diag, char *normin, integer *n, doublereal *ap, doublereal *x, doublereal *scale, doublereal *cnorm, integer *info);
-
-static VALUE
-rb_dlatps(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_cnorm;
- doublereal *cnorm;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_cnorm_out__;
- doublereal *cnorm_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.dlatps( uplo, trans, diag, normin, ap, x, cnorm)\n or\n NumRu::Lapack.dlatps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLATPS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A' denotes the\n* transpose of A, x and b are n-element vectors, and s is a scaling\n* factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION 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*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, DTPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_ap = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_DFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_DFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- normin = StringValueCStr(rb_normin)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, doublereal*);
- MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- dlatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_dlatps(VALUE mLapack){
- rb_define_module_function(mLapack, "dlatps", rb_dlatps, -1);
-}
diff --git a/dlatrd.c b/dlatrd.c
deleted file mode 100644
index 5f1998f..0000000
--- a/dlatrd.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlatrd_(char *uplo, integer *n, integer *nb, doublereal *a, integer *lda, doublereal *e, doublereal *tau, doublereal *w, integer *ldw);
-
-static VALUE
-rb_dlatrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.dlatrd( uplo, nb, a)\n or\n NumRu::Lapack.dlatrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* DLATRD reduces NB rows and columns of a real symmetric matrix A to\n* symmetric tridiagonal form by an orthogonal similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by DSYTRD.\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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) DOUBLE PRECISION 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= (1,N).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) DOUBLE PRECISION array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a symmetric rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = ldw;
- shape[1] = MAX(n,nb);
- rb_w = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
-
- return rb_ary_new3(4, rb_e, rb_tau, rb_w, rb_a);
-}
-
-void
-init_lapack_dlatrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dlatrd", rb_dlatrd, -1);
-}
diff --git a/dlatrs.c b/dlatrs.c
deleted file mode 100644
index 72e9ec8..0000000
--- a/dlatrs.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlatrs_(char *uplo, char *trans, char *diag, char *normin, integer *n, doublereal *a, integer *lda, doublereal *x, doublereal *scale, doublereal *cnorm, integer *info);
-
-static VALUE
-rb_dlatrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_cnorm;
- doublereal *cnorm;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_cnorm_out__;
- doublereal *cnorm_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.dlatrs( uplo, trans, diag, normin, a, x, cnorm)\n or\n NumRu::Lapack.dlatrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLATRS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A' denotes the transpose of A, x and b are\n* n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, DTRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_a = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_DFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_DFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, doublereal*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of cnorm");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, doublereal*);
- MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- dlatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_dlatrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dlatrs", rb_dlatrs, -1);
-}
diff --git a/dlatrz.c b/dlatrz.c
deleted file mode 100644
index 2146888..0000000
--- a/dlatrz.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlatrz_(integer *m, integer *n, integer *l, doublereal *a, integer *lda, doublereal *tau, doublereal *work);
-
-static VALUE
-rb_dlatrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.dlatrz( l, a)\n or\n NumRu::Lapack.dlatrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means\n* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_l = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- l = NUM2INT(rb_l);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (m));
-
- dlatrz_(&m, &n, &l, a, &lda, tau, work);
-
- free(work);
- return rb_ary_new3(2, rb_tau, rb_a);
-}
-
-void
-init_lapack_dlatrz(VALUE mLapack){
- rb_define_module_function(mLapack, "dlatrz", rb_dlatrz, -1);
-}
diff --git a/dlatzm.c b/dlatzm.c
deleted file mode 100644
index 3c3b53f..0000000
--- a/dlatzm.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlatzm_(char *side, integer *m, integer *n, doublereal *v, integer *incv, doublereal *tau, doublereal *c1, doublereal *c2, integer *ldc, doublereal *work);
-
-static VALUE
-rb_dlatzm(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- doublereal tau;
- VALUE rb_c1;
- doublereal *c1;
- VALUE rb_c2;
- doublereal *c2;
- VALUE rb_c1_out__;
- doublereal *c1_out__;
- VALUE rb_c2_out__;
- doublereal *c2_out__;
- doublereal *work;
-
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.dlatzm( side, m, n, v, incv, tau, c1, c2)\n or\n NumRu::Lapack.dlatzm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DORMRZ.\n*\n* DLATZM applies a Householder matrix generated by DTZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) DOUBLE PRECISION array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of P.\n*\n* C1 (input/output) DOUBLE PRECISION array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) DOUBLE PRECISION array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c1 = argv[6];
- rb_c2 = argv[7];
-
- tau = NUM2DBL(rb_tau);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_c2))
- rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
- if (NA_RANK(rb_c2) != 2)
- rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
- ldc = NA_SHAPE0(rb_c2);
- if (NA_TYPE(rb_c2) != NA_DFLOAT)
- rb_c2 = na_change_type(rb_c2, NA_DFLOAT);
- c2 = NA_PTR_TYPE(rb_c2, doublereal*);
- if (!NA_IsNArray(rb_c1))
- rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
- if (NA_RANK(rb_c1) != 2)
- rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
- if (NA_SHAPE0(rb_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
- if (NA_TYPE(rb_c1) != NA_DFLOAT)
- rb_c1 = na_change_type(rb_c1, NA_DFLOAT);
- c1 = NA_PTR_TYPE(rb_c1, doublereal*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- {
- int shape[2];
- shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
- rb_c1_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c1_out__ = NA_PTR_TYPE(rb_c1_out__, doublereal*);
- MEMCPY(c1_out__, c1, doublereal, NA_TOTAL(rb_c1));
- rb_c1 = rb_c1_out__;
- c1 = c1_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
- rb_c2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c2_out__ = NA_PTR_TYPE(rb_c2_out__, doublereal*);
- MEMCPY(c2_out__, c2, doublereal, NA_TOTAL(rb_c2));
- rb_c2 = rb_c2_out__;
- c2 = c2_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dlatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
-
- free(work);
- return rb_ary_new3(2, rb_c1, rb_c2);
-}
-
-void
-init_lapack_dlatzm(VALUE mLapack){
- rb_define_module_function(mLapack, "dlatzm", rb_dlatzm, -1);
-}
diff --git a/dlauu2.c b/dlauu2.c
deleted file mode 100644
index 59e2fe4..0000000
--- a/dlauu2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlauu2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dlauu2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dlauu2( uplo, a)\n or\n NumRu::Lapack.dlauu2 # print 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlauu2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dlauu2(VALUE mLapack){
- rb_define_module_function(mLapack, "dlauu2", rb_dlauu2, -1);
-}
diff --git a/dlauum.c b/dlauum.c
deleted file mode 100644
index 1e9cea2..0000000
--- a/dlauum.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dlauum_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dlauum(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dlauum( uplo, a)\n or\n NumRu::Lapack.dlauum # print 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dlauum_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dlauum(VALUE mLapack){
- rb_define_module_function(mLapack, "dlauum", rb_dlauum, -1);
-}
diff --git a/doc/c.html b/doc/c.html
deleted file mode 100644
index 8960d39..0000000
--- a/doc/c.html
+++ /dev/null
@@ -1,36 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines</TITLE>
- </HEAD>
- <BODY>
- <H1>COMPLEX routines</H1>
- <UL>
- <LI><A HREF="cbd.html">BD: bidiagonal</A></LI>
- <LI><A HREF="cgb.html">GB: general band</A></LI>
- <LI><A HREF="cge.html">GE: general (i.e., unsymmetric, in some cases rectangular)</A></LI>
- <LI><A HREF="cgg.html">GG: general matrices, generalized problem (i.e., a pair of general matrices)</A></LI>
- <LI><A HREF="cgt.html">GT: general tridiagonal</A></LI>
- <LI><A HREF="chb.html">HB: (complex) Hermitian band</A></LI>
- <LI><A HREF="che.html">HE: (complex) Hermitian</A></LI>
- <LI><A HREF="chg.html">HG: upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix)</A></LI>
- <LI><A HREF="chp.html">HP: (complex) Hermitian, packed storage</A></LI>
- <LI><A HREF="chs.html">HS: upper Hessenberg</A></LI>
- <LI><A HREF="cpb.html">PB: symmetric or Hermitian positive definite band</A></LI>
- <LI><A HREF="cpo.html">PO: symmetric or Hermitian positive definite</A></LI>
- <LI><A HREF="cpp.html">PP: symmetric or Hermitian positive definite, packed storage</A></LI>
- <LI><A HREF="cpt.html">PT: symmetric or Hermitian positive definite tridiagonal</A></LI>
- <LI><A HREF="csp.html">SP: symmetric, packed storage</A></LI>
- <LI><A HREF="cst.html">ST: (real) symmetric tridiagonal</A></LI>
- <LI><A HREF="csy.html">SY: symmetric</A></LI>
- <LI><A HREF="ctb.html">TB: triangular band</A></LI>
- <LI><A HREF="ctg.html">TG: triangular matrices, generalized problem (i.e., a pair of triangular matrices)</A></LI>
- <LI><A HREF="ctp.html">TP: triangular, packed storage</A></LI>
- <LI><A HREF="ctr.html">TR: triangular (or in some cases quasi-triangular)</A></LI>
- <LI><A HREF="ctz.html">TZ: trapezoidal</A></LI>
- <LI><A HREF="cun.html">UN: (complex) unitary</A></LI>
- <LI><A HREF="cup.html">UP: (complex) unitary, packed storageBDbidiagonal</A></LI>
- </UL>
- <HR />
- <A HREF="index.html">back to data types</A>
- </BODY>
-</HTML>
diff --git a/doc/cbd.html b/doc/cbd.html
deleted file mode 100644
index cb32163..0000000
--- a/doc/cbd.html
+++ /dev/null
@@ -1,163 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for bidiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for bidiagonal matrix</H1>
- <UL>
- <LI><A HREF="#cbdsqr">cbdsqr</A> : </LI>
- </UL>
-
- <A NAME="cbdsqr"></A>
- <H2>cbdsqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, vt, u, c = NumRu::Lapack.cbdsqr( uplo, nru, d, e, vt, u, c)
- or
- NumRu::Lapack.cbdsqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CBDSQR computes the singular values and, optionally, the right and/or
-* left singular vectors from the singular value decomposition (SVD) of
-* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
-* zero-shift QR algorithm. The SVD of B has the form
-*
-* B = Q * S * P**H
-*
-* where S is the diagonal matrix of singular values, Q is an orthogonal
-* matrix of left singular vectors, and P is an orthogonal matrix of
-* right singular vectors. If left singular vectors are requested, this
-* subroutine actually returns U*Q instead of Q, and, if right singular
-* vectors are requested, this subroutine returns P**H*VT instead of
-* P**H, for given complex input matrices U and VT. When U and VT are
-* the unitary matrices that reduce a general matrix A to bidiagonal
-* form: A = U*B*VT, as computed by CGEBRD, then
-*
-* A = (U*Q) * S * (P**H*VT)
-*
-* is the SVD of A. Optionally, the subroutine may also compute Q**H*C
-* for a given complex input matrix C.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices With
-* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
-* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
-* no. 5, pp. 873-912, Sept 1990) and
-* "Accurate singular values and differential qd algorithms," by
-* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
-* Department, University of California at Berkeley, July 1992
-* for a detailed description of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': B is upper bidiagonal;
-* = 'L': B is lower bidiagonal.
-*
-* N (input) INTEGER
-* The order of the matrix B. N >= 0.
-*
-* NCVT (input) INTEGER
-* The number of columns of the matrix VT. NCVT >= 0.
-*
-* NRU (input) INTEGER
-* The number of rows of the matrix U. NRU >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the bidiagonal matrix B.
-* On exit, if INFO=0, the singular values of B in decreasing
-* order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the N-1 offdiagonal elements of the bidiagonal
-* matrix B.
-* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
-* will contain the diagonal and superdiagonal elements of a
-* bidiagonal matrix orthogonally equivalent to the one given
-* as input.
-*
-* VT (input/output) COMPLEX array, dimension (LDVT, NCVT)
-* On entry, an N-by-NCVT matrix VT.
-* On exit, VT is overwritten by P**H * VT.
-* Not referenced if NCVT = 0.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT.
-* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
-*
-* U (input/output) COMPLEX array, dimension (LDU, N)
-* On entry, an NRU-by-N matrix U.
-* On exit, U is overwritten by U * Q.
-* Not referenced if NRU = 0.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,NRU).
-*
-* C (input/output) COMPLEX array, dimension (LDC, NCC)
-* On entry, an N-by-NCC matrix C.
-* On exit, C is overwritten by Q**H * C.
-* Not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm did not converge; D and E contain the
-* elements of a bidiagonal matrix which is orthogonally
-* similar to the input matrix B; if INFO = i, i
-* elements of E have not converged to zero.
-*
-* Internal Parameters
-* ===================
-*
-* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))
-* TOLMUL controls the convergence criterion of the QR loop.
-* If it is positive, TOLMUL*EPS is the desired relative
-* precision in the computed singular values.
-* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
-* desired absolute accuracy in the computed singular
-* values (corresponds to relative accuracy
-* abs(TOLMUL*EPS) in the largest singular value.
-* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
-* between 10 (for fast convergence) and .1/EPS
-* (for there to be some accuracy in the results).
-* Default is to lose at either one eighth or 2 of the
-* available decimal digits in each computed singular value
-* (whichever is smaller).
-*
-* MAXITR INTEGER, default = 6
-* MAXITR controls the maximum number of passes of the
-* algorithm through its inner loop. The algorithms stops
-* (and so fails to converge) if the number of passes
-* through the inner loop exceeds MAXITR*N**2.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cgb.html b/doc/cgb.html
deleted file mode 100644
index d148e5b..0000000
--- a/doc/cgb.html
+++ /dev/null
@@ -1,1900 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for general band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for general band matrix</H1>
- <UL>
- <LI><A HREF="#cgbbrd">cgbbrd</A> : </LI>
- <LI><A HREF="#cgbcon">cgbcon</A> : </LI>
- <LI><A HREF="#cgbequ">cgbequ</A> : </LI>
- <LI><A HREF="#cgbequb">cgbequb</A> : </LI>
- <LI><A HREF="#cgbrfs">cgbrfs</A> : </LI>
- <LI><A HREF="#cgbrfsx">cgbrfsx</A> : </LI>
- <LI><A HREF="#cgbsv">cgbsv</A> : </LI>
- <LI><A HREF="#cgbsvx">cgbsvx</A> : </LI>
- <LI><A HREF="#cgbsvxx">cgbsvxx</A> : </LI>
- <LI><A HREF="#cgbtf2">cgbtf2</A> : </LI>
- <LI><A HREF="#cgbtrf">cgbtrf</A> : </LI>
- <LI><A HREF="#cgbtrs">cgbtrs</A> : </LI>
- </UL>
-
- <A NAME="cgbbrd"></A>
- <H2>cgbbrd</H2>
-
- <PRE>
-USAGE:
- d, e, q, pt, info, ab, c = NumRu::Lapack.cgbbrd( vect, kl, ku, ab, c)
- or
- NumRu::Lapack.cgbbrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGBBRD reduces a complex general m-by-n band matrix A to real upper
-* bidiagonal form B by a unitary transformation: Q' * A * P = B.
-*
-* The routine computes B, and optionally forms Q or P', or computes
-* Q'*C for a given matrix C.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether or not the matrices Q and P' are to be
-* formed.
-* = 'N': do not form Q or P';
-* = 'Q': form Q only;
-* = 'P': form P' only;
-* = 'B': form both.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals of the matrix A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals of the matrix A. KU >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the m-by-n band matrix A, stored in rows 1 to
-* KL+KU+1. The j-th column of A is stored in the j-th column of
-* the array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-* On exit, A is overwritten by values generated during the
-* reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KL+KU+1.
-*
-* D (output) REAL array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B.
-*
-* E (output) REAL array, dimension (min(M,N)-1)
-* The superdiagonal elements of the bidiagonal matrix B.
-*
-* Q (output) COMPLEX array, dimension (LDQ,M)
-* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
-* If VECT = 'N' or 'P', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
-*
-* PT (output) COMPLEX array, dimension (LDPT,N)
-* If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
-* If VECT = 'N' or 'Q', the array PT is not referenced.
-*
-* LDPT (input) INTEGER
-* The leading dimension of the array PT.
-* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
-*
-* C (input/output) COMPLEX array, dimension (LDC,NCC)
-* On entry, an m-by-ncc matrix C.
-* On exit, C is overwritten by Q'*C.
-* C is not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
-*
-* WORK (workspace) COMPLEX array, dimension (max(M,N))
-*
-* RWORK (workspace) REAL array, dimension (max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbcon"></A>
- <H2>cgbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cgbcon( norm, kl, ku, ab, ipiv, anorm)
- or
- NumRu::Lapack.cgbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGBCON estimates the reciprocal of the condition number of a complex
-* general band matrix A, in either the 1-norm or the infinity-norm,
-* using the LU factorization computed by CGBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by CGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* ANORM (input) REAL
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbequ"></A>
- <H2>cgbequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequ( m, kl, ku, ab)
- or
- NumRu::Lapack.cgbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CGBEQU computes row and column scalings intended to equilibrate an
-* M-by-N band matrix A and reduce its condition number. R returns the
-* row scale factors and C the column scale factors, chosen to try to
-* make the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
-* column of A is stored in the j-th column of the array AB as
-* follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0, or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbequb"></A>
- <H2>cgbequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequb( kl, ku, ab)
- or
- NumRu::Lapack.cgbequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CGBEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from CGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= max(1,M).
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbrfs"></A>
- <H2>cgbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)
- or
- NumRu::Lapack.cgbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is banded, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) COMPLEX array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by CGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from CGBTRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CGBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbrfsx"></A>
- <H2>cgbrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.cgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.cgbrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGBRFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from SGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbsv"></A>
- <H2>cgbsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab, b = NumRu::Lapack.cgbsv( kl, ku, ab, b)
- or
- NumRu::Lapack.cgbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CGBSV computes the solution to a complex system of linear equations
-* A * X = B, where A is a band matrix of order N with KL subdiagonals
-* and KU superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as A = L * U, where L is a product of permutation
-* and unit lower triangular matrices with KL subdiagonals, and U is
-* upper triangular with KL+KU superdiagonals. The factored form of A
-* is then used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL CGBTRF, CGBTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbsvx"></A>
- <H2>cgbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.cgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.cgbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGBSVX uses the LU factorization to compute the solution to a complex
-* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
-* where A is a band matrix of order N with KL subdiagonals and KU
-* superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed by this subroutine:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = L * U,
-* where L is a product of permutation and unit lower triangular
-* matrices with KL subdiagonals, and U is upper triangular with
-* KL+KU superdiagonals.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB and IPIV contain the factored form of
-* A. If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* AB, AFB, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then A must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) COMPLEX array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by CGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns details of the LU factorization of A.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns details of the LU factorization of the equilibrated
-* matrix A (see the description of AB for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = L*U
-* as computed by CGBTRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace/output) REAL array, dimension (N)
-* On exit, RWORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If RWORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* RWORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-* Moved setting of INFO = N+1 so INFO does not subsequently get
-* overwritten. Sven, 17 Mar 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbsvxx"></A>
- <H2>cgbsvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.cgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.cgbsvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGBSVXX uses the LU factorization to compute the solution to a
-* complex system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. CGBSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* CGBSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* CGBSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what CGBSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose = Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then AB must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) REAL array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by CGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by SGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In SGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbtf2"></A>
- <H2>cgbtf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.cgbtf2( m, kl, ku, ab)
- or
- NumRu::Lapack.cgbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CGBTF2 computes an LU factorization of a complex m-by-n band matrix
-* A using partial pivoting with row interchanges.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U, because of fill-in resulting from the row
-* interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbtrf"></A>
- <H2>cgbtrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.cgbtrf( m, kl, ku, ab)
- or
- NumRu::Lapack.cgbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CGBTRF computes an LU factorization of a complex m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgbtrs"></A>
- <H2>cgbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.cgbtrs( trans, kl, ku, ab, ipiv, b)
- or
- NumRu::Lapack.cgbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CGBTRS solves a system of linear equations
-* A * X = B, A**T * X = B, or A**H * X = B
-* with a general band matrix A using the LU factorization computed
-* by CGBTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by CGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cge.html b/doc/cge.html
deleted file mode 100644
index 4947805..0000000
--- a/doc/cge.html
+++ /dev/null
@@ -1,5395 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for general (i.e., unsymmetric, in some cases rectangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for general (i.e., unsymmetric, in some cases rectangular) matrix</H1>
- <UL>
- <LI><A HREF="#cgebak">cgebak</A> : </LI>
- <LI><A HREF="#cgebal">cgebal</A> : </LI>
- <LI><A HREF="#cgebd2">cgebd2</A> : </LI>
- <LI><A HREF="#cgebrd">cgebrd</A> : </LI>
- <LI><A HREF="#cgecon">cgecon</A> : </LI>
- <LI><A HREF="#cgeequ">cgeequ</A> : </LI>
- <LI><A HREF="#cgeequb">cgeequb</A> : </LI>
- <LI><A HREF="#cgees">cgees</A> : </LI>
- <LI><A HREF="#cgeesx">cgeesx</A> : </LI>
- <LI><A HREF="#cgeev">cgeev</A> : </LI>
- <LI><A HREF="#cgeevx">cgeevx</A> : </LI>
- <LI><A HREF="#cgegs">cgegs</A> : </LI>
- <LI><A HREF="#cgegv">cgegv</A> : </LI>
- <LI><A HREF="#cgehd2">cgehd2</A> : </LI>
- <LI><A HREF="#cgehrd">cgehrd</A> : </LI>
- <LI><A HREF="#cgelq2">cgelq2</A> : </LI>
- <LI><A HREF="#cgelqf">cgelqf</A> : </LI>
- <LI><A HREF="#cgels">cgels</A> : </LI>
- <LI><A HREF="#cgelsd">cgelsd</A> : </LI>
- <LI><A HREF="#cgelss">cgelss</A> : </LI>
- <LI><A HREF="#cgelsx">cgelsx</A> : </LI>
- <LI><A HREF="#cgelsy">cgelsy</A> : </LI>
- <LI><A HREF="#cgeql2">cgeql2</A> : </LI>
- <LI><A HREF="#cgeqlf">cgeqlf</A> : </LI>
- <LI><A HREF="#cgeqp3">cgeqp3</A> : </LI>
- <LI><A HREF="#cgeqpf">cgeqpf</A> : </LI>
- <LI><A HREF="#cgeqr2">cgeqr2</A> : </LI>
- <LI><A HREF="#cgeqr2p">cgeqr2p</A> : </LI>
- <LI><A HREF="#cgeqrf">cgeqrf</A> : </LI>
- <LI><A HREF="#cgeqrfp">cgeqrfp</A> : </LI>
- <LI><A HREF="#cgerfs">cgerfs</A> : </LI>
- <LI><A HREF="#cgerfsx">cgerfsx</A> : </LI>
- <LI><A HREF="#cgerq2">cgerq2</A> : </LI>
- <LI><A HREF="#cgerqf">cgerqf</A> : </LI>
- <LI><A HREF="#cgesc2">cgesc2</A> : </LI>
- <LI><A HREF="#cgesdd">cgesdd</A> : </LI>
- <LI><A HREF="#cgesv">cgesv</A> : </LI>
- <LI><A HREF="#cgesvd">cgesvd</A> : </LI>
- <LI><A HREF="#cgesvx">cgesvx</A> : </LI>
- <LI><A HREF="#cgesvxx">cgesvxx</A> : </LI>
- <LI><A HREF="#cgetc2">cgetc2</A> : </LI>
- <LI><A HREF="#cgetf2">cgetf2</A> : </LI>
- <LI><A HREF="#cgetrf">cgetrf</A> : </LI>
- <LI><A HREF="#cgetri">cgetri</A> : </LI>
- <LI><A HREF="#cgetrs">cgetrs</A> : </LI>
- </UL>
-
- <A NAME="cgebak"></A>
- <H2>cgebak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.cgebak( job, side, ilo, ihi, scale, v)
- or
- NumRu::Lapack.cgebak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* CGEBAK forms the right or left eigenvectors of a complex general
-* matrix by backward transformation on the computed eigenvectors of the
-* balanced matrix output by CGEBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N', do nothing, return immediately;
-* = 'P', do backward transformation for permutation only;
-* = 'S', do backward transformation for scaling only;
-* = 'B', do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to CGEBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by CGEBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* SCALE (input) REAL array, dimension (N)
-* Details of the permutation and scaling factors, as returned
-* by CGEBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) COMPLEX array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by CHSEIN or CTREVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgebal"></A>
- <H2>cgebal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, scale, info, a = NumRu::Lapack.cgebal( job, a)
- or
- NumRu::Lapack.cgebal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* CGEBAL balances a general complex matrix A. This involves, first,
-* permuting A by a similarity transformation to isolate eigenvalues
-* in the first 1 to ILO-1 and last IHI+1 to N elements on the
-* diagonal; and second, applying a diagonal similarity transformation
-* to rows and columns ILO to IHI to make the rows and columns as
-* close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrix, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A:
-* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
-* for i = 1,...,N;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* SCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied to
-* A. If P(j) is the index of the row and column interchanged
-* with row and column j and D(j) is the scaling factor
-* applied to row and column j, then
-* SCALE(j) = P(j) for j = 1,...,ILO-1
-* = D(j) for j = ILO,...,IHI
-* = P(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The permutations consist of row and column interchanges which put
-* the matrix in the form
-*
-* ( T1 X Y )
-* P A P = ( 0 B Z )
-* ( 0 0 T2 )
-*
-* where T1 and T2 are upper triangular matrices whose eigenvalues lie
-* along the diagonal. The column indices ILO and IHI mark the starting
-* and ending columns of the submatrix B. Balancing consists of applying
-* a diagonal similarity transformation inv(D) * B * D to make the
-* 1-norms of each row of B and its corresponding column nearly equal.
-* The output matrix is
-*
-* ( T1 X*D Y )
-* ( 0 inv(D)*B*D inv(D)*Z ).
-* ( 0 0 T2 )
-*
-* Information about the permutations P and the diagonal matrix D is
-* returned in the vector SCALE.
-*
-* This subroutine is based on the EISPACK routine CBAL.
-*
-* Modified by Tzu-Yi Chen, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgebd2"></A>
- <H2>cgebd2</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, info, a = NumRu::Lapack.cgebd2( m, a)
- or
- NumRu::Lapack.cgebd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEBD2 reduces a complex general m by n matrix A to upper or lower
-* real bidiagonal form B by a unitary transformation: Q' * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the m by n general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the unitary matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the unitary matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) REAL array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) COMPLEX array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q. See Further Details.
-*
-* TAUP (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix P. See Further Details.
-*
-* WORK (workspace) COMPLEX array, dimension (max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, and v and u are complex
-* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
-* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
-* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, v and u are complex vectors;
-* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
-* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgebrd"></A>
- <H2>cgebrd</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, work, info, a = NumRu::Lapack.cgebrd( m, a, lwork)
- or
- NumRu::Lapack.cgebrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEBRD reduces a general complex M-by-N matrix A to upper or lower
-* bidiagonal form B by a unitary transformation: Q**H * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the unitary matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the unitary matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) REAL array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) COMPLEX array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q. See Further Details.
-*
-* TAUP (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix P. See Further Details.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,M,N).
-* For optimum performance LWORK >= (M+N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, and v and u are complex
-* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
-* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
-* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, and v and u are complex
-* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
-* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
-* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgecon"></A>
- <H2>cgecon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cgecon( norm, a, anorm)
- or
- NumRu::Lapack.cgecon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGECON estimates the reciprocal of the condition number of a general
-* complex matrix A, in either the 1-norm or the infinity-norm, using
-* the LU factorization computed by CGETRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by CGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) REAL
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeequ"></A>
- <H2>cgeequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequ( a)
- or
- NumRu::Lapack.cgeequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CGEEQU computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeequb"></A>
- <H2>cgeequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequb( a)
- or
- NumRu::Lapack.cgeequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CGEEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from CGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgees"></A>
- <H2>cgees</H2>
-
- <PRE>
-USAGE:
- sdim, w, vs, work, info, a = NumRu::Lapack.cgees( jobvs, sort, a, lwork){|a| ... }
- or
- NumRu::Lapack.cgees # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEES computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues, the Schur form T, and, optionally, the matrix of Schur
-* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* Schur form so that selected eigenvalues are at the top left.
-* The leading columns of Z then form an orthonormal basis for the
-* invariant subspace corresponding to the selected eigenvalues.
-
-* A complex matrix is in Schur form if it is upper triangular.
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered:
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to order
-* to the top left of the Schur form.
-* IF SORT = 'N', SELECT is not referenced.
-* The eigenvalue W(j) is selected if SELECT(W(j)) is true.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten by its Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues for which
-* SELECT is true.
-*
-* W (output) COMPLEX array, dimension (N)
-* W contains the computed eigenvalues, in the same order that
-* they appear on the diagonal of the output Schur form T.
-*
-* VS (output) COMPLEX array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the unitary matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1; if
-* JOBVS = 'V', LDVS >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of W
-* contain those eigenvalues which have converged;
-* if JOBVS = 'V', VS contains the matrix which
-* reduces A to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because
-* some eigenvalues were too close to separate (the
-* problem is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Schur form no longer satisfy
-* SELECT = .TRUE.. This could also be caused by
-* underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeesx"></A>
- <H2>cgeesx</H2>
-
- <PRE>
-USAGE:
- sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.cgeesx( jobvs, sort, sense, a, lwork){|a| ... }
- or
- NumRu::Lapack.cgeesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEESX computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues, the Schur form T, and, optionally, the matrix of Schur
-* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* Schur form so that selected eigenvalues are at the top left;
-* computes a reciprocal condition number for the average of the
-* selected eigenvalues (RCONDE); and computes a reciprocal condition
-* number for the right invariant subspace corresponding to the
-* selected eigenvalues (RCONDV). The leading columns of Z form an
-* orthonormal basis for this invariant subspace.
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
-* these quantities are called s and sep respectively).
-*
-* A complex matrix is in Schur form if it is upper triangular.
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to order
-* to the top left of the Schur form.
-* If SORT = 'N', SELECT is not referenced.
-* An eigenvalue W(j) is selected if SELECT(W(j)) is true.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for average of selected eigenvalues only;
-* = 'V': Computed for selected right invariant subspace only;
-* = 'B': Computed for both.
-* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the N-by-N matrix A.
-* On exit, A is overwritten by its Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues for which
-* SELECT is true.
-*
-* W (output) COMPLEX array, dimension (N)
-* W contains the computed eigenvalues, in the same order
-* that they appear on the diagonal of the output Schur form T.
-*
-* VS (output) COMPLEX array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the unitary matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1, and if
-* JOBVS = 'V', LDVS >= N.
-*
-* RCONDE (output) REAL
-* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
-* condition number for the average of the selected eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) REAL
-* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
-* condition number for the selected right invariant subspace.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),
-* where SDIM is the number of selected eigenvalues computed by
-* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also
-* that an error is only returned if LWORK < max(1,2*N), but if
-* SENSE = 'E' or 'V' or 'B' this may not be large enough.
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates upper bound on the optimal size of the
-* array WORK, returns this value as the first entry of the WORK
-* array, and no error message related to LWORK is issued by
-* XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of W
-* contain those eigenvalues which have converged; if
-* JOBVS = 'V', VS contains the transformation which
-* reduces A to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because some
-* eigenvalues were too close to separate (the problem
-* is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of some
-* complex eigenvalues so that leading eigenvalues in
-* the Schur form no longer satisfy SELECT=.TRUE. This
-* could also be caused by underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeev"></A>
- <H2>cgeev</H2>
-
- <PRE>
-USAGE:
- w, vl, vr, work, info, a = NumRu::Lapack.cgeev( jobvl, jobvr, a, lwork)
- or
- NumRu::Lapack.cgeev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of are computed.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) COMPLEX array, dimension (N)
-* W contains the computed eigenvalues.
-*
-* VL (output) COMPLEX array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* u(j) = VL(:,j), the j-th column of VL.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* v(j) = VR(:,j), the j-th column of VR.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1; if
-* JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors have been computed;
-* elements and i+1:N of W contain eigenvalues which have
-* converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeevx"></A>
- <H2>cgeevx</H2>
-
- <PRE>
-USAGE:
- w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.cgeevx( balanc, jobvl, jobvr, sense, a, lwork)
- or
- NumRu::Lapack.cgeevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* Optionally also, it computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
-* (RCONDE), and reciprocal condition numbers for the right
-* eigenvectors (RCONDV).
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-* Balancing a matrix means permuting the rows and columns to make it
-* more nearly upper triangular, and applying a diagonal similarity
-* transformation D * A * D**(-1), where D is a diagonal matrix, to
-* make its rows and columns closer in norm and the condition numbers
-* of its eigenvalues and eigenvectors smaller. The computed
-* reciprocal condition numbers correspond to the balanced matrix.
-* Permuting rows and columns will not change the condition numbers
-* (in exact arithmetic) but diagonal scaling will. For further
-* explanation of balancing, see section 4.10.2 of the LAPACK
-* Users' Guide.
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Indicates how the input matrix should be diagonally scaled
-* and/or permuted to improve the conditioning of its
-* eigenvalues.
-* = 'N': Do not diagonally scale or permute;
-* = 'P': Perform permutations to make the matrix more nearly
-* upper triangular. Do not diagonally scale;
-* = 'S': Diagonally scale the matrix, ie. replace A by
-* D*A*D**(-1), where D is a diagonal matrix chosen
-* to make the rows and columns of A more equal in
-* norm. Do not permute;
-* = 'B': Both diagonally scale and permute A.
-*
-* Computed reciprocal condition numbers will be for the matrix
-* after balancing and/or permuting. Permuting does not change
-* condition numbers (in exact arithmetic), but balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVL must = 'V'.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVR must = 'V'.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for eigenvalues only;
-* = 'V': Computed for right eigenvectors only;
-* = 'B': Computed for eigenvalues and right eigenvectors.
-*
-* If SENSE = 'E' or 'B', both left and right eigenvectors
-* must also be computed (JOBVL = 'V' and JOBVR = 'V').
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten. If JOBVL = 'V' or
-* JOBVR = 'V', A contains the Schur form of the balanced
-* version of the matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) COMPLEX array, dimension (N)
-* W contains the computed eigenvalues.
-*
-* VL (output) COMPLEX array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* u(j) = VL(:,j), the j-th column of VL.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* v(j) = VR(:,j), the j-th column of VR.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1; if
-* JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values determined when A was
-* balanced. The balanced A(i,j) = 0 if I > J and
-* J = 1,...,ILO-1 or I = IHI+1,...,N.
-*
-* SCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* when balancing A. If P(j) is the index of the row and column
-* interchanged with row and column j, and D(j) is the scaling
-* factor applied to row and column j, then
-* SCALE(J) = P(J), for J = 1,...,ILO-1
-* = D(J), for J = ILO,...,IHI
-* = P(J) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) REAL
-* The one-norm of the balanced matrix (the maximum
-* of the sum of absolute values of elements of any column).
-*
-* RCONDE (output) REAL array, dimension (N)
-* RCONDE(j) is the reciprocal condition number of the j-th
-* eigenvalue.
-*
-* RCONDV (output) REAL array, dimension (N)
-* RCONDV(j) is the reciprocal condition number of the j-th
-* right eigenvector.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. If SENSE = 'N' or 'E',
-* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
-* LWORK >= N*N+2*N.
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors or condition numbers
-* have been computed; elements 1:ILO-1 and i+1:N of W
-* contain eigenvalues which have converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgegs"></A>
- <H2>cgegs</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgegs( jobvsl, jobvsr, a, b, lwork)
- or
- NumRu::Lapack.cgegs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine CGGES.
-*
-* CGEGS computes the eigenvalues, Schur form, and, optionally, the
-* left and or/right Schur vectors of a complex matrix pair (A,B).
-* Given two square matrices A and B, the generalized Schur
-* factorization has the form
-*
-* A = Q*S*Z**H, B = Q*T*Z**H
-*
-* where Q and Z are unitary matrices and S and T are upper triangular.
-* The columns of Q are the left Schur vectors
-* and the columns of Z are the right Schur vectors.
-*
-* If only the eigenvalues of (A,B) are needed, the driver routine
-* CGEGV should be used instead. See CGEGV for a description of the
-* eigenvalues of the generalized nonsymmetric eigenvalue problem
-* (GNEP).
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors (returned in VSL).
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors (returned in VSR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the matrix A.
-* On exit, the upper triangular matrix S from the generalized
-* Schur factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the matrix B.
-* On exit, the upper triangular matrix T from the generalized
-* Schur factorization.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* The complex scalars alpha that define the eigenvalues of
-* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur
-* form of A.
-*
-* BETA (output) COMPLEX array, dimension (N)
-* The non-negative real scalars beta that define the
-* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element
-* of the triangular factor T.
-*
-* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
-* represent the j-th eigenvalue of the matrix pair (A,B), in
-* one of the forms lambda = alpha/beta or mu = beta/alpha.
-* Since either lambda or mu may overflow, they should not,
-* in general, be computed.
-*
-* VSL (output) COMPLEX array, dimension (LDVSL,N)
-* If JOBVSL = 'V', the matrix of left Schur vectors Q.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >= 1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) COMPLEX array, dimension (LDVSR,N)
-* If JOBVSR = 'V', the matrix of right Schur vectors Z.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:
-* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
-* the optimal LWORK is N*(NB+1).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHA(j) and BETA(j) should be correct for
-* j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from CGGBAL
-* =N+2: error return from CGEQRF
-* =N+3: error return from CUNMQR
-* =N+4: error return from CUNGQR
-* =N+5: error return from CGGHRD
-* =N+6: error return from CHGEQZ (other than failed
-* iteration)
-* =N+7: error return from CGGBAK (computing VSL)
-* =N+8: error return from CGGBAK (computing VSR)
-* =N+9: error return from CLASCL (various places)
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgegv"></A>
- <H2>cgegv</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cgegv( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.cgegv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine CGGEV.
-*
-* CGEGV computes the eigenvalues and, optionally, the left and/or right
-* eigenvectors of a complex matrix pair (A,B).
-* Given two square matrices A and B,
-* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
-* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
-* that
-* A*x = lambda*B*x.
-*
-* An alternate form is to find the eigenvalues mu and corresponding
-* eigenvectors y such that
-* mu*A*y = B*y.
-*
-* These two forms are equivalent with mu = 1/lambda and x = y if
-* neither lambda nor mu is zero. In order to deal with the case that
-* lambda or mu is zero or small, two values alpha and beta are returned
-* for each eigenvalue, such that lambda = alpha/beta and
-* mu = beta/alpha.
-*
-* The vectors x and y in the above equations are right eigenvectors of
-* the matrix pair (A,B). Vectors u and v satisfying
-* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
-* are left eigenvectors of (A,B).
-*
-* Note: this routine performs "full balancing" on A and B -- see
-* "Further Details", below.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors (returned
-* in VL).
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors (returned
-* in VR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the matrix A.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit A
-* contains the Schur form of A from the generalized Schur
-* factorization of the pair (A,B) after balancing. If no
-* eigenvectors were computed, then only the diagonal elements
-* of the Schur form will be correct. See CGGHRD and CHGEQZ
-* for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the matrix B.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
-* upper triangular matrix obtained from B in the generalized
-* Schur factorization of the pair (A,B) after balancing.
-* If no eigenvectors were computed, then only the diagonal
-* elements of B will be correct. See CGGHRD and CHGEQZ for
-* details.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* The complex scalars alpha that define the eigenvalues of
-* GNEP.
-*
-* BETA (output) COMPLEX array, dimension (N)
-* The complex scalars beta that define the eigenvalues of GNEP.
-*
-* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
-* represent the j-th eigenvalue of the matrix pair (A,B), in
-* one of the forms lambda = alpha/beta or mu = beta/alpha.
-* Since either lambda or mu may overflow, they should not,
-* in general, be computed.
-
-*
-* VL (output) COMPLEX array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored
-* in the columns of VL, in the same order as their eigenvalues.
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvectors
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors x(j) are stored
-* in the columns of VR, in the same order as their eigenvalues.
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvectors
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:
-* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
-* The optimal LWORK is MAX( 2*N, N*(NB+1) ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array, dimension (8*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHA(j) and BETA(j) should be
-* correct for j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from CGGBAL
-* =N+2: error return from CGEQRF
-* =N+3: error return from CUNMQR
-* =N+4: error return from CUNGQR
-* =N+5: error return from CGGHRD
-* =N+6: error return from CHGEQZ (other than failed
-* iteration)
-* =N+7: error return from CTGEVC
-* =N+8: error return from CGGBAK (computing VL)
-* =N+9: error return from CGGBAK (computing VR)
-* =N+10: error return from CLASCL (various calls)
-*
-
-* Further Details
-* ===============
-*
-* Balancing
-* ---------
-*
-* This driver calls CGGBAL to both permute and scale rows and columns
-* of A and B. The permutations PL and PR are chosen so that PL*A*PR
-* and PL*B*R will be upper triangular except for the diagonal blocks
-* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
-* possible. The diagonal scaling matrices DL and DR are chosen so
-* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
-* one (except for the elements that start out zero.)
-*
-* After the eigenvalues and eigenvectors of the balanced matrices
-* have been computed, CGGBAK transforms the eigenvectors back to what
-* they would have been (in perfect arithmetic) if they had not been
-* balanced.
-*
-* Contents of A and B on Exit
-* -------- -- - --- - -- ----
-*
-* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
-* both), then on exit the arrays A and B will contain the complex Schur
-* form[*] of the "balanced" versions of A and B. If no eigenvectors
-* are computed, then only the diagonal blocks will be correct.
-*
-* [*] In other words, upper triangular form.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgehd2"></A>
- <H2>cgehd2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.cgehd2( ilo, ihi, a)
- or
- NumRu::Lapack.cgehd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEHD2 reduces a complex general matrix A to upper Hessenberg form H
-* by a unitary similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to CGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= max(1,N).
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the n by n general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the unitary matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) COMPLEX array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgehrd"></A>
- <H2>cgehrd</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.cgehrd( ilo, ihi, a, lwork)
- or
- NumRu::Lapack.cgehrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEHRD reduces a complex general matrix A to upper Hessenberg form H by
-* an unitary similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to CGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the unitary matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) COMPLEX array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
-* zero.
-*
-* WORK (workspace/output) COMPLEX array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* This file is a slight modification of LAPACK-3.0's DGEHRD
-* subroutine incorporating improvements proposed by Quintana-Orti and
-* Van de Geijn (2006). (See DLAHR2.)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgelq2"></A>
- <H2>cgelq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.cgelq2( a)
- or
- NumRu::Lapack.cgelq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGELQ2 computes an LQ factorization of a complex m by n matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m by min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
-* A(i,i+1:n), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgelqf"></A>
- <H2>cgelqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.cgelqf( m, a, lwork)
- or
- NumRu::Lapack.cgelqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGELQF computes an LQ factorization of a complex M-by-N matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
-* A(i,i+1:n), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL CGELQ2, CLARFB, CLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgels"></A>
- <H2>cgels</H2>
-
- <PRE>
-USAGE:
- work, info, a, b = NumRu::Lapack.cgels( trans, m, a, b, lwork)
- or
- NumRu::Lapack.cgels # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGELS solves overdetermined or underdetermined complex linear systems
-* involving an M-by-N matrix A, or its conjugate-transpose, using a QR
-* or LQ factorization of A. It is assumed that A has full rank.
-*
-* The following options are provided:
-*
-* 1. If TRANS = 'N' and m >= n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A*X ||.
-*
-* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
-* an underdetermined system A * X = B.
-*
-* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of
-* an undetermined system A**H * X = B.
-*
-* 4. If TRANS = 'C' and m < n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A**H * X ||.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N': the linear system involves A;
-* = 'C': the linear system involves A**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* if M >= N, A is overwritten by details of its QR
-* factorization as returned by CGEQRF;
-* if M < N, A is overwritten by details of its LQ
-* factorization as returned by CGELQF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the matrix B of right hand side vectors, stored
-* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
-* if TRANS = 'C'.
-* On exit, if INFO = 0, B is overwritten by the solution
-* vectors, stored columnwise:
-* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
-* squares solution vectors; the residual sum of squares for the
-* solution in each column is given by the sum of squares of the
-* modulus of elements N+1 to M in that column;
-* if TRANS = 'N' and m < n, rows 1 to N of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'C' and m >= n, rows 1 to M of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'C' and m < n, rows 1 to M of B contain the
-* least squares solution vectors; the residual sum of squares
-* for the solution in each column is given by the sum of
-* squares of the modulus of elements M+1 to N in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= MAX(1,M,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= max( 1, MN + max( MN, NRHS ) ).
-* For optimal performance,
-* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
-* where MN = min(M,N) and NB is the optimum block size.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of the
-* triangular factor of A is zero, so that A does not have
-* full rank; the least squares solution could not be
-* computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgelsd"></A>
- <H2>cgelsd</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, a, b = NumRu::Lapack.cgelsd( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.cgelsd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGELSD computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize 2-norm(| b - A*x |)
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The problem is solved in three steps:
-* (1) Reduce the coefficient matrix A to bidiagonal form with
-* Householder tranformations, reducing the original problem
-* into a "bidiagonal least squares problem" (BLS)
-* (2) Solve the BLS using a divide and conquer approach.
-* (3) Apply back all the Householder tranformations to solve
-* the original least squares problem.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of the modulus of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK must be at least 1.
-* The exact minimum amount of workspace needed depends on M,
-* N and NRHS. As long as LWORK is at least
-* 2 * N + N * NRHS
-* if M is greater than or equal to N or
-* 2 * M + M * NRHS
-* if M is less than N, the code will execute correctly.
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the array WORK and the
-* minimum sizes of the arrays RWORK and IWORK, and returns
-* these values as the first entries of the WORK, RWORK and
-* IWORK arrays, and no error message related to LWORK is issued
-* by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))
-* LRWORK >=
-* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
-* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
-* if M is greater than or equal to N or
-* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
-* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
-* if M is less than N, the code will execute correctly.
-* SMLSIZ is returned by ILAENV and is equal to the maximum
-* size of the subproblems at the bottom of the computation
-* tree (usually about 25), and
-* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
-* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
-* where MINMN = MIN( M,N ).
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Ren-Cang Li, Computer Science Division, University of
-* California at Berkeley, USA
-* Osni Marques, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgelss"></A>
- <H2>cgelss</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, a, b = NumRu::Lapack.cgelss( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.cgelss # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGELSS computes the minimum norm solution to a complex linear
-* least squares problem:
-*
-* Minimize 2-norm(| b - A*x |).
-*
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
-* X.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the first min(m,n) rows of A are overwritten with
-* its right singular vectors, stored rowwise.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of the modulus of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1, and also:
-* LWORK >= 2*min(M,N) + max(M,N,NRHS)
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (5*min(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgelsx"></A>
- <H2>cgelsx</H2>
-
- <PRE>
-USAGE:
- rank, info, a, b, jpvt = NumRu::Lapack.cgelsx( m, a, b, jpvt, rcond)
- or
- NumRu::Lapack.cgelsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine CGELSY.
-*
-* CGELSX computes the minimum-norm solution to a complex linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by unitary transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of elements N+1:M in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
-* initial column, otherwise it is a free column. Before
-* the QR factorization of A, all initial columns are
-* permuted to the leading positions; only the remaining
-* free columns are moved as a result of column pivoting
-* during the factorization.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace) COMPLEX array, dimension
-* (min(M,N) + max( N, 2*min(M,N)+NRHS )),
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgelsy"></A>
- <H2>cgelsy</H2>
-
- <PRE>
-USAGE:
- rank, work, info, a, b, jpvt = NumRu::Lapack.cgelsy( m, a, b, jpvt, rcond, lwork)
- or
- NumRu::Lapack.cgelsy # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGELSY computes the minimum-norm solution to a complex linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by unitary transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-* This routine is basically identical to the original xGELSX except
-* three differences:
-* o The permutation of matrix B (the right hand side) is faster and
-* more simple.
-* o The call to the subroutine xGEQPF has been substituted by the
-* the call to the subroutine xGEQP3. This subroutine is a Blas-3
-* version of the QR factorization with column pivoting.
-* o Matrix B (the right hand side) is updated with Blas-3.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of AP, otherwise column i is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* The unblocked strategy requires that:
-* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )
-* where MN = min(M,N).
-* The block algorithm requires that:
-* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )
-* where NB is an upper bound on the blocksize returned
-* by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR,
-* and CUNMRZ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeql2"></A>
- <H2>cgeql2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.cgeql2( m, a)
- or
- NumRu::Lapack.cgeql2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEQL2 computes a QL factorization of a complex m by n matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the m by n lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* unitary matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeqlf"></A>
- <H2>cgeqlf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.cgeqlf( m, a, lwork)
- or
- NumRu::Lapack.cgeqlf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEQLF computes a QL factorization of a complex M-by-N matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the M-by-N lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* unitary matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL CGEQL2, CLARFB, CLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeqp3"></A>
- <H2>cgeqp3</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a, jpvt = NumRu::Lapack.cgeqp3( m, a, jpvt, lwork)
- or
- NumRu::Lapack.cgeqp3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEQP3 computes a QR factorization with column pivoting of a
-* matrix A: A*P = Q*R using Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper trapezoidal matrix R; the elements below
-* the diagonal, together with the array TAU, represent the
-* unitary matrix Q as a product of min(M,N) elementary
-* reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(J)=0,
-* the J-th column of A is a free column.
-* On exit, if JPVT(J)=K, then the J-th column of A*P was the
-* the K-th column of A.
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= N+1.
-* For optimal performance LWORK >= ( N+1 )*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real/complex scalar, and v is a real/complex vector
-* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
-* A(i+1:m,i), and tau in TAU(i).
-*
-* Based on contributions by
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* X. Sun, Computer Science Dept., Duke University, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeqpf"></A>
- <H2>cgeqpf</H2>
-
- <PRE>
-USAGE:
- tau, info, a, jpvt = NumRu::Lapack.cgeqpf( m, a, jpvt)
- or
- NumRu::Lapack.cgeqpf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine CGEQP3.
-*
-* CGEQPF computes a QR factorization with column pivoting of a
-* complex M-by-N matrix A: A*P = Q*R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper triangular matrix R; the elements
-* below the diagonal, together with the array TAU,
-* represent the unitary matrix Q as a product of
-* min(m,n) elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(i) = 0,
-* the i-th column of A is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(n)
-*
-* Each H(i) has the form
-*
-* H = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
-*
-* The matrix P is represented in jpvt as follows: If
-* jpvt(j) = i
-* then the jth column of P is the ith canonical unit vector.
-*
-* Partial column norm updating strategy modified by
-* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
-* University of Zagreb, Croatia.
-* June 2010
-* For more details see LAPACK Working Note 176.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeqr2"></A>
- <H2>cgeqr2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.cgeqr2( m, a)
- or
- NumRu::Lapack.cgeqr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEQR2 computes a QR factorization of a complex m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeqr2p"></A>
- <H2>cgeqr2p</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.cgeqr2p( m, a)
- or
- NumRu::Lapack.cgeqr2p # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEQR2P computes a QR factorization of a complex m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeqrf"></A>
- <H2>cgeqrf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.cgeqrf( m, a, lwork)
- or
- NumRu::Lapack.cgeqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEQRF computes a QR factorization of a complex M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL CGEQR2, CLARFB, CLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgeqrfp"></A>
- <H2>cgeqrfp</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.cgeqrfp( m, a, lwork)
- or
- NumRu::Lapack.cgeqrfp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGEQRFP computes a QR factorization of a complex M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL CGEQR2P, CLARFB, CLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgerfs"></A>
- <H2>cgerfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cgerfs( trans, a, af, ipiv, b, x)
- or
- NumRu::Lapack.cgerfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGERFS improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates for
-* the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by CGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from CGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgerfsx"></A>
- <H2>cgerfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.cgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.cgerfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGERFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by CGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from CGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed.
-* If R is accessed, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed.
-* If C is accessed, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgerq2"></A>
- <H2>cgerq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.cgerq2( a)
- or
- NumRu::Lapack.cgerq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGERQ2 computes an RQ factorization of a complex m by n matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the m by n upper trapezoidal matrix R; the remaining
-* elements, with the array TAU, represent the unitary matrix
-* Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on
-* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgerqf"></A>
- <H2>cgerqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.cgerqf( m, a, lwork)
- or
- NumRu::Lapack.cgerqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGERQF computes an RQ factorization of a complex M-by-N matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R;
-* the remaining elements, with the array TAU, represent the
-* unitary matrix Q as a product of min(m,n) elementary
-* reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on
-* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL CGERQ2, CLARFB, CLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgesc2"></A>
- <H2>cgesc2</H2>
-
- <PRE>
-USAGE:
- scale, rhs = NumRu::Lapack.cgesc2( a, rhs, ipiv, jpiv)
- or
- NumRu::Lapack.cgesc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
-
-* Purpose
-* =======
-*
-* CGESC2 solves a system of linear equations
-*
-* A * X = scale* RHS
-*
-* with a general N-by-N matrix A using the LU factorization with
-* complete pivoting computed by CGETC2.
-*
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of columns of the matrix A.
-*
-* A (input) COMPLEX array, dimension (LDA, N)
-* On entry, the LU part of the factorization of the n-by-n
-* matrix A computed by CGETC2: A = P * L * U * Q
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, N).
-*
-* RHS (input/output) COMPLEX array, dimension N.
-* On entry, the right hand side vector b.
-* On exit, the solution vector X.
-*
-* IPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* SCALE (output) REAL
-* On exit, SCALE contains the scale factor. SCALE is chosen
-* 0 <= SCALE <= 1 to prevent owerflow in the solution.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgesdd"></A>
- <H2>cgesdd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.cgesdd( jobz, m, a, lwork)
- or
- NumRu::Lapack.cgesdd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGESDD computes the singular value decomposition (SVD) of a complex
-* M-by-N matrix A, optionally computing the left and/or right singular
-* vectors, by using divide-and-conquer method. The SVD is written
-*
-* A = U * SIGMA * conjugate-transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
-* V is an N-by-N unitary matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns VT = V**H, not V.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U and all N rows of V**H are
-* returned in the arrays U and VT;
-* = 'S': the first min(M,N) columns of U and the first
-* min(M,N) rows of V**H are returned in the arrays U
-* and VT;
-* = 'O': If M >= N, the first N columns of U are overwritten
-* in the array A and all rows of V**H are returned in
-* the array VT;
-* otherwise, all columns of U are returned in the
-* array U and the first M rows of V**H are overwritten
-* in the array A;
-* = 'N': no columns of U or rows of V**H are computed.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBZ = 'O', A is overwritten with the first N columns
-* of U (the left singular vectors, stored
-* columnwise) if M >= N;
-* A is overwritten with the first M rows
-* of V**H (the right singular vectors, stored
-* rowwise) otherwise.
-* if JOBZ .ne. 'O', the contents of A are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) COMPLEX array, dimension (LDU,UCOL)
-* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
-* UCOL = min(M,N) if JOBZ = 'S'.
-* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
-* unitary matrix U;
-* if JOBZ = 'S', U contains the first min(M,N) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
-*
-* VT (output) COMPLEX array, dimension (LDVT,N)
-* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
-* N-by-N unitary matrix V**H;
-* if JOBZ = 'S', VT contains the first min(M,N) rows of
-* V**H (the right singular vectors, stored rowwise);
-* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
-* if JOBZ = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).
-* if JOBZ = 'O',
-* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
-* if JOBZ = 'S' or 'A',
-* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, a workspace query is assumed. The optimal
-* size for the WORK array is calculated and stored in WORK(1),
-* and no other work except argument checking is performed.
-*
-* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))
-* If JOBZ = 'N', LRWORK >= 5*min(M,N).
-* Otherwise,
-* LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)
-*
-* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The updating process of SBDSDC did not converge.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgesv"></A>
- <H2>cgesv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a, b = NumRu::Lapack.cgesv( a, b)
- or
- NumRu::Lapack.cgesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CGESV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as
-* A = P * L * U,
-* where P is a permutation matrix, L is unit lower triangular, and U is
-* upper triangular. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the N-by-N coefficient matrix A.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS matrix of right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL CGETRF, CGETRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgesvd"></A>
- <H2>cgesvd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.cgesvd( jobu, jobvt, m, a, lwork)
- or
- NumRu::Lapack.cgesvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGESVD computes the singular value decomposition (SVD) of a complex
-* M-by-N matrix A, optionally computing the left and/or right singular
-* vectors. The SVD is written
-*
-* A = U * SIGMA * conjugate-transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
-* V is an N-by-N unitary matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns V**H, not V.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U are returned in array U:
-* = 'S': the first min(m,n) columns of U (the left singular
-* vectors) are returned in the array U;
-* = 'O': the first min(m,n) columns of U (the left singular
-* vectors) are overwritten on the array A;
-* = 'N': no columns of U (no left singular vectors) are
-* computed.
-*
-* JOBVT (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix
-* V**H:
-* = 'A': all N rows of V**H are returned in the array VT;
-* = 'S': the first min(m,n) rows of V**H (the right singular
-* vectors) are returned in the array VT;
-* = 'O': the first min(m,n) rows of V**H (the right singular
-* vectors) are overwritten on the array A;
-* = 'N': no rows of V**H (no right singular vectors) are
-* computed.
-*
-* JOBVT and JOBU cannot both be 'O'.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBU = 'O', A is overwritten with the first min(m,n)
-* columns of U (the left singular vectors,
-* stored columnwise);
-* if JOBVT = 'O', A is overwritten with the first min(m,n)
-* rows of V**H (the right singular vectors,
-* stored rowwise);
-* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
-* are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) COMPLEX array, dimension (LDU,UCOL)
-* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
-* If JOBU = 'A', U contains the M-by-M unitary matrix U;
-* if JOBU = 'S', U contains the first min(m,n) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBU = 'N' or 'O', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBU = 'S' or 'A', LDU >= M.
-*
-* VT (output) COMPLEX array, dimension (LDVT,N)
-* If JOBVT = 'A', VT contains the N-by-N unitary matrix
-* V**H;
-* if JOBVT = 'S', VT contains the first min(m,n) rows of
-* V**H (the right singular vectors, stored rowwise);
-* if JOBVT = 'N' or 'O', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (5*min(M,N))
-* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
-* unconverged superdiagonal elements of an upper bidiagonal
-* matrix B whose diagonal is in S (not necessarily sorted).
-* B satisfies A = U * B * VT, so it has the same singular
-* values as A, and singular vectors related by U and VT.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if CBDSQR did not converge, INFO specifies how many
-* superdiagonals of an intermediate bidiagonal form B
-* did not converge to zero. See the description of RWORK
-* above for details.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgesvx"></A>
- <H2>cgesvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.cgesvx( fact, trans, a, af, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.cgesvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGESVX uses the LU factorization to compute the solution to a complex
-* system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = P * L * U,
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by CGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace/output) REAL array, dimension (2*N)
-* On exit, RWORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If RWORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* RWORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization has
-* been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgesvxx"></A>
- <H2>cgesvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.cgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.cgesvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGESVXX uses the LU factorization to compute the solution to a
-* complex system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. CGESVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* CGESVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* CGESVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what CGESVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by CGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In CGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgetc2"></A>
- <H2>cgetc2</H2>
-
- <PRE>
-USAGE:
- ipiv, jpiv, info, a = NumRu::Lapack.cgetc2( a)
- or
- NumRu::Lapack.cgetc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO )
-
-* Purpose
-* =======
-*
-* CGETC2 computes an LU factorization, using complete pivoting, of the
-* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
-* where P and Q are permutation matrices, L is lower triangular with
-* unit diagonal elements and U is upper triangular.
-*
-* This is a level 1 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the n-by-n matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U*Q; the unit diagonal elements of L are not stored.
-* If U(k, k) appears to be less than SMIN, U(k, k) is given the
-* value of SMIN, giving a nonsingular perturbed system.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, N).
-*
-* IPIV (output) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (output) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* > 0: if INFO = k, U(k, k) is likely to produce overflow if
-* one tries to solve for x in Ax = b. So U is perturbed
-* to avoid the overflow.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgetf2"></A>
- <H2>cgetf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.cgetf2( m, a)
- or
- NumRu::Lapack.cgetf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CGETF2 computes an LU factorization of a general m-by-n matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the m by n matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgetrf"></A>
- <H2>cgetrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.cgetrf( m, a)
- or
- NumRu::Lapack.cgetrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CGETRF computes an LU factorization of a general M-by-N matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgetri"></A>
- <H2>cgetri</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cgetri( a, ipiv, lwork)
- or
- NumRu::Lapack.cgetri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGETRI computes the inverse of a matrix using the LU factorization
-* computed by CGETRF.
-*
-* This method inverts U and then computes inv(A) by solving the system
-* inv(A)*L = inv(U) for inv(A).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the factors L and U from the factorization
-* A = P*L*U as computed by CGETRF.
-* On exit, if INFO = 0, the inverse of the original matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from CGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimal performance LWORK >= N*NB, where NB is
-* the optimal blocksize returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
-* singular and its inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgetrs"></A>
- <H2>cgetrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.cgetrs( trans, a, ipiv, b)
- or
- NumRu::Lapack.cgetrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CGETRS solves a system of linear equations
-* A * X = B, A**T * X = B, or A**H * X = B
-* with a general N-by-N matrix A using the LU factorization computed
-* by CGETRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by CGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from CGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cgg.html b/doc/cgg.html
deleted file mode 100644
index cfe100d..0000000
--- a/doc/cgg.html
+++ /dev/null
@@ -1,2065 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</H1>
- <UL>
- <LI><A HREF="#cggbak">cggbak</A> : </LI>
- <LI><A HREF="#cggbal">cggbal</A> : </LI>
- <LI><A HREF="#cgges">cgges</A> : </LI>
- <LI><A HREF="#cggesx">cggesx</A> : </LI>
- <LI><A HREF="#cggev">cggev</A> : </LI>
- <LI><A HREF="#cggevx">cggevx</A> : </LI>
- <LI><A HREF="#cggglm">cggglm</A> : </LI>
- <LI><A HREF="#cgghrd">cgghrd</A> : </LI>
- <LI><A HREF="#cgglse">cgglse</A> : </LI>
- <LI><A HREF="#cggqrf">cggqrf</A> : </LI>
- <LI><A HREF="#cggrqf">cggrqf</A> : </LI>
- <LI><A HREF="#cggsvd">cggsvd</A> : </LI>
- <LI><A HREF="#cggsvp">cggsvp</A> : </LI>
- </UL>
-
- <A NAME="cggbak"></A>
- <H2>cggbak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.cggbak( job, side, ilo, ihi, lscale, rscale, v)
- or
- NumRu::Lapack.cggbak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* CGGBAK forms the right or left eigenvectors of a complex generalized
-* eigenvalue problem A*x = lambda*B*x, by backward transformation on
-* the computed eigenvectors of the balanced pair of matrices output by
-* CGGBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N': do nothing, return immediately;
-* = 'P': do backward transformation for permutation only;
-* = 'S': do backward transformation for scaling only;
-* = 'B': do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to CGGBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by CGGBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* LSCALE (input) REAL array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the left side of A and B, as returned by CGGBAL.
-*
-* RSCALE (input) REAL array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the right side of A and B, as returned by CGGBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) COMPLEX array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by CTGEVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the matrix V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. Ward, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFTV, RIGHTV
- INTEGER I, K
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CSSCAL, CSWAP, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggbal"></A>
- <H2>cggbal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.cggbal( job, a, b)
- or
- NumRu::Lapack.cggbal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGBAL balances a pair of general complex matrices (A,B). This
-* involves, first, permuting A and B by similarity transformations to
-* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
-* elements on the diagonal; and second, applying a diagonal similarity
-* transformation to rows and columns ILO to IHI to make the rows
-* and columns as close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrices, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors in the
-* generalized eigenvalue problem A*x = lambda*B*x.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A and B:
-* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
-* and RSCALE(I) = 1.0 for i=1,...,N;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB,N)
-* On entry, the input matrix B.
-* On exit, B is overwritten by the balanced matrix.
-* If JOB = 'N', B is not referenced.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If P(j) is the index of the
-* row interchanged with row j, and D(j) is the scaling factor
-* applied to row j, then
-* LSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If P(j) is the index of the
-* column interchanged with column j, and D(j) is the scaling
-* factor applied to column j, then
-* RSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* WORK (workspace) REAL array, dimension (lwork)
-* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
-* at least 1 when JOB = 'N' or 'P'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. WARD, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgges"></A>
- <H2>cgges</H2>
-
- <PRE>
-USAGE:
- sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b| ... }
- or
- NumRu::Lapack.cgges # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGES computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B), the generalized eigenvalues, the generalized complex Schur
-* form (S, T), and optionally left and/or right Schur vectors (VSL
-* and VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
-*
-* where (VSR)**H is the conjugate-transpose of VSR.
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* triangular matrix S and the upper triangular matrix T. The leading
-* columns of VSL and VSR then form an unitary basis for the
-* corresponding left and right eigenspaces (deflating subspaces).
-*
-* (If only the generalized eigenvalues are needed, use the driver
-* CGGEV instead, which is faster.)
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0, and even for both being zero.
-*
-* A pair of matrices (S,T) is in generalized complex Schur form if S
-* and T are upper triangular and, in addition, the diagonal elements
-* of T are non-negative real numbers.
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG).
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* An eigenvalue ALPHA(j)/BETA(j) is selected if
-* SELCTG(ALPHA(j),BETA(j)) is true.
-*
-* Note that a selected complex eigenvalue may no longer satisfy
-* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned), in this
-* case INFO is set to N+2 (See INFO below).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true.
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* BETA (output) COMPLEX array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
-* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),
-* j=1,...,N are the diagonals of the complex Schur form (A,B)
-* output by CGGES. The BETA(j) will be non-negative real.
-*
-* Note: the quotients ALPHA(j)/BETA(j) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio alpha/beta.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VSL (output) COMPLEX array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >= 1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) COMPLEX array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (8*N)
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHA(j) and BETA(j) should be correct for
-* j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in CHGEQZ
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering falied in CTGSEN.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggesx"></A>
- <H2>cggesx</H2>
-
- <PRE>
-USAGE:
- sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.cggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b| ... }
- or
- NumRu::Lapack.cggesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGESX computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B), the generalized eigenvalues, the complex Schur form (S,T),
-* and, optionally, the left and/or right matrices of Schur vectors (VSL
-* and VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )
-*
-* where (VSR)**H is the conjugate-transpose of VSR.
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* triangular matrix S and the upper triangular matrix T; computes
-* a reciprocal condition number for the average of the selected
-* eigenvalues (RCONDE); and computes a reciprocal condition number for
-* the right and left deflating subspaces corresponding to the selected
-* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
-* an orthonormal basis for the corresponding left and right eigenspaces
-* (deflating subspaces).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0 or for both being zero.
-*
-* A pair of matrices (S,T) is in generalized complex Schur form if T is
-* upper triangular with non-negative diagonal and S is upper
-* triangular.
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG).
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* Note that a selected complex eigenvalue may no longer satisfy
-* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned), in this
-* case INFO is set to N+3 see INFO below).
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N' : None are computed;
-* = 'E' : Computed for average of selected eigenvalues only;
-* = 'V' : Computed for selected deflating subspaces only;
-* = 'B' : Computed for both.
-* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true.
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* BETA (output) COMPLEX array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
-* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are
-* the diagonals of the complex Schur form (S,T). BETA(j) will
-* be non-negative real.
-*
-* Note: the quotients ALPHA(j)/BETA(j) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio alpha/beta.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VSL (output) COMPLEX array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) COMPLEX array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* RCONDE (output) REAL array, dimension ( 2 )
-* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
-* reciprocal condition numbers for the average of the selected
-* eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) REAL array, dimension ( 2 )
-* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
-* reciprocal condition number for the selected deflating
-* subspaces.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
-* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else
-* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.
-* Note also that an error is only returned if
-* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may
-* not be large enough.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the bound on the optimal size of the WORK
-* array and the minimum size of the IWORK array, returns these
-* values as the first entries of the WORK and IWORK arrays, and
-* no error message related to LWORK or LIWORK is issued by
-* XERBLA.
-*
-* RWORK (workspace) REAL array, dimension ( 8*N )
-* Real workspace.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
-* LIWORK >= N+2.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the bound on the optimal size of the
-* WORK array and the minimum size of the IWORK array, returns
-* these values as the first entries of the WORK and IWORK
-* arrays, and no error message related to LWORK or LIWORK is
-* issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHA(j) and BETA(j) should be correct for
-* j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in CHGEQZ
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering failed in CTGSEN.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggev"></A>
- <H2>cggev</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cggev( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.cggev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGEV computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B), the generalized eigenvalues, and optionally, the left and/or
-* right generalized eigenvectors.
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right generalized eigenvector v(j) corresponding to the
-* generalized eigenvalue lambda(j) of (A,B) satisfies
-*
-* A * v(j) = lambda(j) * B * v(j).
-*
-* The left generalized eigenvector u(j) corresponding to the
-* generalized eigenvalues lambda(j) of (A,B) satisfies
-*
-* u(j)**H * A = lambda(j) * u(j)**H * B
-*
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* BETA (output) COMPLEX array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
-* generalized eigenvalues.
-*
-* Note: the quotients ALPHA(j)/BETA(j) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio alpha/beta.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VL (output) COMPLEX array, dimension (LDVL,N)
-* If JOBVL = 'V', the left generalized eigenvectors u(j) are
-* stored one after another in the columns of VL, in the same
-* order as their eigenvalues.
-* Each eigenvector is scaled so the largest component has
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX array, dimension (LDVR,N)
-* If JOBVR = 'V', the right generalized eigenvectors v(j) are
-* stored one after another in the columns of VR, in the same
-* order as their eigenvalues.
-* Each eigenvector is scaled so the largest component has
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array, dimension (8*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHA(j) and BETA(j) should be
-* correct for j=INFO+1,...,N.
-* > N: =N+1: other then QZ iteration failed in SHGEQZ,
-* =N+2: error return from STGEVC.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggevx"></A>
- <H2>cggevx</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.cggevx( balanc, jobvl, jobvr, sense, a, b, lwork)
- or
- NumRu::Lapack.cggevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B) the generalized eigenvalues, and optionally, the left and/or
-* right generalized eigenvectors.
-*
-* Optionally, it also computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
-* the eigenvalues (RCONDE), and reciprocal condition numbers for the
-* right eigenvectors (RCONDV).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-* A * v(j) = lambda(j) * B * v(j) .
-* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-* u(j)**H * A = lambda(j) * u(j)**H * B.
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Specifies the balance option to be performed:
-* = 'N': do not diagonally scale or permute;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-* Computed reciprocal condition numbers will be for the
-* matrices after permuting and/or balancing. Permuting does
-* not change condition numbers (in exact arithmetic), but
-* balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': none are computed;
-* = 'E': computed for eigenvalues only;
-* = 'V': computed for eigenvectors only;
-* = 'B': computed for eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then A contains the first part of the complex Schur
-* form of the "balanced" versions of the input A and B.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then B contains the second part of the complex
-* Schur form of the "balanced" versions of the input A and B.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* BETA (output) COMPLEX array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized
-* eigenvalues.
-*
-* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio ALPHA/BETA.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VL (output) COMPLEX array, dimension (LDVL,N)
-* If JOBVL = 'V', the left generalized eigenvectors u(j) are
-* stored one after another in the columns of VL, in the same
-* order as their eigenvalues.
-* Each eigenvector will be scaled so the largest component
-* will have abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX array, dimension (LDVR,N)
-* If JOBVR = 'V', the right generalized eigenvectors v(j) are
-* stored one after another in the columns of VR, in the same
-* order as their eigenvalues.
-* Each eigenvector will be scaled so the largest component
-* will have abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If PL(j) is the index of the
-* row interchanged with row j, and DL(j) is the scaling
-* factor applied to row j, then
-* LSCALE(j) = PL(j) for j = 1,...,ILO-1
-* = DL(j) for j = ILO,...,IHI
-* = PL(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If PR(j) is the index of the
-* column interchanged with column j, and DR(j) is the scaling
-* factor applied to column j, then
-* RSCALE(j) = PR(j) for j = 1,...,ILO-1
-* = DR(j) for j = ILO,...,IHI
-* = PR(j) for j = IHI+1,...,N
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) REAL
-* The one-norm of the balanced matrix A.
-*
-* BBNRM (output) REAL
-* The one-norm of the balanced matrix B.
-*
-* RCONDE (output) REAL array, dimension (N)
-* If SENSE = 'E' or 'B', the reciprocal condition numbers of
-* the eigenvalues, stored in consecutive elements of the array.
-* If SENSE = 'N' or 'V', RCONDE is not referenced.
-*
-* RCONDV (output) REAL array, dimension (N)
-* If SENSE = 'V' or 'B', the estimated reciprocal condition
-* numbers of the eigenvectors, stored in consecutive elements
-* of the array. If the eigenvalues cannot be reordered to
-* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur
-* when the true value would be very small anyway.
-* If SENSE = 'N' or 'E', RCONDV is not referenced.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* If SENSE = 'E', LWORK >= max(1,4*N).
-* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (lrwork)
-* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',
-* and at least max(1,2*N) otherwise.
-* Real workspace.
-*
-* IWORK (workspace) INTEGER array, dimension (N+2)
-* If SENSE = 'E', IWORK is not referenced.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* If SENSE = 'N', BWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHA(j) and BETA(j) should be correct
-* for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in CHGEQZ.
-* =N+2: error return from CTGEVC.
-*
-
-* Further Details
-* ===============
-*
-* Balancing a matrix pair (A,B) includes, first, permuting rows and
-* columns to isolate eigenvalues, second, applying diagonal similarity
-* transformation to the rows and columns to make the rows and columns
-* as close in norm as possible. The computed reciprocal condition
-* numbers correspond to the balanced matrix. Permuting rows and columns
-* will not change the condition numbers (in exact arithmetic) but
-* diagonal scaling will. For further explanation of balancing, see
-* section 4.11.1.2 of LAPACK Users' Guide.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
-*
-* An approximate error bound for the angle between the i-th computed
-* eigenvector VL(i) or VR(i) is given by
-*
-* EPS * norm(ABNRM, BBNRM) / DIF(i).
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see section 4.11 of LAPACK User's Guide.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggglm"></A>
- <H2>cggglm</H2>
-
- <PRE>
-USAGE:
- x, y, work, info, a, b, d = NumRu::Lapack.cggglm( a, b, d, lwork)
- or
- NumRu::Lapack.cggglm # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGGLM solves a general Gauss-Markov linear model (GLM) problem:
-*
-* minimize || y ||_2 subject to d = A*x + B*y
-* x
-*
-* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
-* given N-vector. It is assumed that M <= N <= M+P, and
-*
-* rank(A) = M and rank( A B ) = N.
-*
-* Under these assumptions, the constrained equation is always
-* consistent, and there is a unique solution x and a minimal 2-norm
-* solution y, which is obtained using a generalized QR factorization
-* of the matrices (A, B) given by
-*
-* A = Q*(R), B = Q*T*Z.
-* (0)
-*
-* In particular, if matrix B is square nonsingular, then the problem
-* GLM is equivalent to the following weighted linear least squares
-* problem
-*
-* minimize || inv(B)*(d-A*x) ||_2
-* x
-*
-* where inv(B) denotes the inverse of B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. 0 <= M <= N.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= N-M.
-*
-* A (input/output) COMPLEX array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the upper triangular part of the array A contains
-* the M-by-M upper triangular matrix R.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* D (input/output) COMPLEX array, dimension (N)
-* On entry, D is the left hand side of the GLM equation.
-* On exit, D is destroyed.
-*
-* X (output) COMPLEX array, dimension (M)
-* Y (output) COMPLEX array, dimension (P)
-* On exit, X and Y are the solutions of the GLM problem.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N+M+P).
-* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* CGEQRF, CGERQF, CUNMQR and CUNMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with A in the
-* generalized QR factorization of the pair (A, B) is
-* singular, so that rank(A) < M; the least squares
-* solution could not be computed.
-* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
-* factor T associated with B in the generalized QR
-* factorization of the pair (A, B) is singular, so that
-* rank( A B ) < N; the least squares solution could not
-* be computed.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgghrd"></A>
- <H2>cgghrd</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.cgghrd( compq, compz, ilo, ihi, a, b, q, z)
- or
- NumRu::Lapack.cgghrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )
-
-* Purpose
-* =======
-*
-* CGGHRD reduces a pair of complex matrices (A,B) to generalized upper
-* Hessenberg form using unitary transformations, where A is a
-* general matrix and B is upper triangular. The form of the generalized
-* eigenvalue problem is
-* A*x = lambda*B*x,
-* and B is typically made upper triangular by computing its QR
-* factorization and moving the unitary matrix Q to the left side
-* of the equation.
-*
-* This subroutine simultaneously reduces A to a Hessenberg matrix H:
-* Q**H*A*Z = H
-* and transforms B to another upper triangular matrix T:
-* Q**H*B*Z = T
-* in order to reduce the problem to its standard form
-* H*y = lambda*T*y
-* where y = Z**H*x.
-*
-* The unitary matrices Q and Z are determined as products of Givens
-* rotations. They may either be formed explicitly, or they may be
-* postmultiplied into input matrices Q1 and Z1, so that
-* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
-* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
-* If Q1 is the unitary matrix from the QR factorization of B in the
-* original equation A*x = lambda*B*x, then CGGHRD reduces the original
-* problem to generalized Hessenberg form.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': do not compute Q;
-* = 'I': Q is initialized to the unit matrix, and the
-* unitary matrix Q is returned;
-* = 'V': Q must contain a unitary matrix Q1 on entry,
-* and the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': do not compute Q;
-* = 'I': Q is initialized to the unit matrix, and the
-* unitary matrix Q is returned;
-* = 'V': Q must contain a unitary matrix Q1 on entry,
-* and the product Q1*Q is returned.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of A which are to be
-* reduced. It is assumed that A is already upper triangular
-* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
-* normally set by a previous call to CGGBAL; otherwise they
-* should be set to 1 and N respectively.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* rest is set to zero.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the N-by-N upper triangular matrix B.
-* On exit, the upper triangular matrix T = Q**H B Z. The
-* elements below the diagonal are set to zero.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) COMPLEX array, dimension (LDQ, N)
-* On entry, if COMPQ = 'V', the unitary matrix Q1, typically
-* from the QR factorization of B.
-* On exit, if COMPQ='I', the unitary matrix Q, and if
-* COMPQ = 'V', the product Q1*Q.
-* Not referenced if COMPQ='N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the unitary matrix Z1.
-* On exit, if COMPZ='I', the unitary matrix Z, and if
-* COMPZ = 'V', the product Z1*Z.
-* Not referenced if COMPZ='N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z.
-* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* This routine reduces A to Hessenberg and B to triangular form by
-* an unblocked reduction, as described in _Matrix_Computations_,
-* by Golub and van Loan (Johns Hopkins Press).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgglse"></A>
- <H2>cgglse</H2>
-
- <PRE>
-USAGE:
- x, work, info, a, b, c, d = NumRu::Lapack.cgglse( a, b, c, d, lwork)
- or
- NumRu::Lapack.cgglse # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGLSE solves the linear equality-constrained least squares (LSE)
-* problem:
-*
-* minimize || c - A*x ||_2 subject to B*x = d
-*
-* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
-* M-vector, and d is a given P-vector. It is assumed that
-* P <= N <= M+P, and
-*
-* rank(B) = P and rank( (A) ) = N.
-* ( (B) )
-*
-* These conditions ensure that the LSE problem has a unique solution,
-* which is obtained using a generalized RQ factorization of the
-* matrices (B, A) given by
-*
-* B = (0 R)*Q, A = Z*T*Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. 0 <= P <= N <= M+P.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
-* contains the P-by-P upper triangular matrix R.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* C (input/output) COMPLEX array, dimension (M)
-* On entry, C contains the right hand side vector for the
-* least squares part of the LSE problem.
-* On exit, the residual sum of squares for the solution
-* is given by the sum of squares of elements N-P+1 to M of
-* vector C.
-*
-* D (input/output) COMPLEX array, dimension (P)
-* On entry, D contains the right hand side vector for the
-* constrained equation.
-* On exit, D is destroyed.
-*
-* X (output) COMPLEX array, dimension (N)
-* On exit, X is the solution of the LSE problem.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M+N+P).
-* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* CGEQRF, CGERQF, CUNMQR and CUNMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with B in the
-* generalized RQ factorization of the pair (B, A) is
-* singular, so that rank(B) < P; the least squares
-* solution could not be computed.
-* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
-* T associated with A in the generalized RQ factorization
-* of the pair (B, A) is singular, so that
-* rank( (A) ) < N; the least squares solution could not
-* ( (B) )
-* be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggqrf"></A>
- <H2>cggqrf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.cggqrf( n, a, b, lwork)
- or
- NumRu::Lapack.cggqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGQRF computes a generalized QR factorization of an N-by-M matrix A
-* and an N-by-P matrix B:
-*
-* A = Q*R, B = Q*T*Z,
-*
-* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,
-* and R and T assume one of the forms:
-*
-* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
-* ( 0 ) N-M N M-N
-* M
-*
-* where R11 is upper triangular, and
-*
-* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
-* P-N N ( T21 ) P
-* P
-*
-* where T12 or T21 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GQR factorization
-* of A and B implicitly gives the QR factorization of inv(B)*A:
-*
-* inv(B)*A = Z'*(inv(T)*R)
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* conjugate transpose of matrix Z.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
-* upper triangular if N >= M); the elements below the diagonal,
-* with the array TAUA, represent the unitary matrix Q as a
-* product of min(N,M) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAUA (output) COMPLEX array, dimension (min(N,M))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q (see Further Details).
-*
-* B (input/output) COMPLEX array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)-th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T; the remaining
-* elements, with the array TAUB, represent the unitary
-* matrix Z as a product of elementary reflectors (see Further
-* Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* TAUB (output) COMPLEX array, dimension (min(N,P))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Z (see Further Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the QR factorization
-* of an N-by-M matrix, NB2 is the optimal blocksize for the
-* RQ factorization of an N-by-P matrix, and NB3 is the optimal
-* blocksize for a call of CUNMQR.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(n,m).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
-* and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine CUNGQR.
-* To use Q to update another matrix, use LAPACK subroutine CUNMQR.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(n,p).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a complex scalar, and v is a complex vector with
-* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
-* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine CUNGRQ.
-* To use Z to update another matrix, use LAPACK subroutine CUNMRQ.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL CGEQRF, CGERQF, CUNMQR, XERBLA
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggrqf"></A>
- <H2>cggrqf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.cggrqf( m, p, a, b, lwork)
- or
- NumRu::Lapack.cggrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGRQF computes a generalized RQ factorization of an M-by-N matrix A
-* and a P-by-N matrix B:
-*
-* A = R*Q, B = Z*T*Q,
-*
-* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary
-* matrix, and R and T assume one of the forms:
-*
-* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
-* N-M M ( R21 ) N
-* N
-*
-* where R12 or R21 is upper triangular, and
-*
-* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
-* ( 0 ) P-N P N-P
-* N
-*
-* where T11 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GRQ factorization
-* of A and B implicitly gives the RQ factorization of A*inv(B):
-*
-* A*inv(B) = (R*inv(T))*Z'
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* conjugate transpose of the matrix Z.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, if M <= N, the upper triangle of the subarray
-* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
-* if M > N, the elements on and above the (M-N)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R; the remaining
-* elements, with the array TAUA, represent the unitary
-* matrix Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAUA (output) COMPLEX array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q (see Further Details).
-*
-* B (input/output) COMPLEX array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
-* upper triangular if P >= N); the elements below the diagonal,
-* with the array TAUB, represent the unitary matrix Z as a
-* product of elementary reflectors (see Further Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TAUB (output) COMPLEX array, dimension (min(P,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Z (see Further Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the RQ factorization
-* of an M-by-N matrix, NB2 is the optimal blocksize for the
-* QR factorization of a P-by-N matrix, and NB3 is the optimal
-* blocksize for a call of CUNMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO=-i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a complex scalar, and v is a complex vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine CUNGRQ.
-* To use Q to update another matrix, use LAPACK subroutine CUNMRQ.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(p,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
-* and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine CUNGQR.
-* To use Z to update another matrix, use LAPACK subroutine CUNMQR.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL CGEQRF, CGERQF, CUNMRQ, XERBLA
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggsvd"></A>
- <H2>cggsvd</H2>
-
- <PRE>
-USAGE:
- k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.cggsvd( jobu, jobv, jobq, a, b)
- or
- NumRu::Lapack.cggsvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGSVD computes the generalized singular value decomposition (GSVD)
-* of an M-by-N complex matrix A and P-by-N complex matrix B:
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
-*
-* where U, V and Q are unitary matrices, and Z' means the conjugate
-* transpose of Z. Let K+L = the effective numerical rank of the
-* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper
-* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal"
-* matrices and of the following structures, respectively:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 )
-* L ( 0 0 R22 )
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The routine computes C, S, R, and optionally the unitary
-* transformation matrices U, V and Q.
-*
-* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
-* A and B implicitly gives the SVD of A*inv(B):
-* A*inv(B) = U*(D1*inv(D2))*V'.
-* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also
-* equal to the CS decomposition of A and B. Furthermore, the GSVD can
-* be used to derive the solution of the eigenvalue problem:
-* A'*A x = lambda* B'*B x.
-* In some literature, the GSVD of A and B is presented in the form
-* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
-* where U and V are orthogonal and X is nonsingular, and D1 and D2 are
-* ``diagonal''. The former GSVD form can be converted to the latter
-* form by taking the nonsingular matrix X as
-*
-* X = Q*( I 0 )
-* ( 0 inv(R) )
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Unitary matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Unitary matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Unitary matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in Purpose.
-* K + L = effective numerical rank of (A',B')'.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular matrix R, or part of R.
-* See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains part of the triangular matrix R if
-* M-K-L < 0. See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* ALPHA (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = C,
-* BETA(K+1:K+L) = S,
-* or if M-K-L < 0,
-* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
-* BETA(K+1:M) = S, BETA(M+1:K+L) = 1
-* and
-* ALPHA(K+L+1:N) = 0
-* BETA(K+L+1:N) = 0
-*
-* U (output) COMPLEX array, dimension (LDU,M)
-* If JOBU = 'U', U contains the M-by-M unitary matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) COMPLEX array, dimension (LDV,P)
-* If JOBV = 'V', V contains the P-by-P unitary matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) COMPLEX array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P)+N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* IWORK (workspace/output) INTEGER array, dimension (N)
-* On exit, IWORK stores the sorting information. More
-* precisely, the following loop will sort ALPHA
-* for I = K+1, min(M,K+L)
-* swap ALPHA(I) and ALPHA(IWORK(I))
-* endfor
-* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = 1, the Jacobi-type procedure failed to
-* converge. For further details, see subroutine CTGSJA.
-*
-* Internal Parameters
-* ===================
-*
-* TOLA REAL
-* TOLB REAL
-* TOLA and TOLB are the thresholds to determine the effective
-* rank of (A',B')'. Generally, they are set to
-* TOLA = MAX(M,N)*norm(A)*MACHEPS,
-* TOLB = MAX(P,N)*norm(B)*MACHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-
-* Further Details
-* ===============
-*
-* 2-96 Based on modifications by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL WANTQ, WANTU, WANTV
- INTEGER I, IBND, ISUB, J, NCYCLE
- REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- REAL CLANGE, SLAMCH
- EXTERNAL LSAME, CLANGE, SLAMCH
-* ..
-* .. External Subroutines ..
- EXTERNAL CGGSVP, CTGSJA, SCOPY, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cggsvp"></A>
- <H2>cggsvp</H2>
-
- <PRE>
-USAGE:
- k, l, u, v, q, info, a, b = NumRu::Lapack.cggsvp( jobu, jobv, jobq, a, b, tola, tolb)
- or
- NumRu::Lapack.cggsvp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGGSVP computes unitary matrices U, V and Q such that
-*
-* N-K-L K L
-* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* V'*B*Q = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
-* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
-* conjugate transpose of Z.
-*
-* This decomposition is the preprocessing step for computing the
-* Generalized Singular Value Decomposition (GSVD), see subroutine
-* CGGSVD.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Unitary matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Unitary matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Unitary matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular (or trapezoidal) matrix
-* described in the Purpose section.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains the triangular matrix described in
-* the Purpose section.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) REAL
-* TOLB (input) REAL
-* TOLA and TOLB are the thresholds to determine the effective
-* numerical rank of matrix B and a subblock of A. Generally,
-* they are set to
-* TOLA = MAX(M,N)*norm(A)*MACHEPS,
-* TOLB = MAX(P,N)*norm(B)*MACHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in Purpose section.
-* K + L = effective numerical rank of (A',B')'.
-*
-* U (output) COMPLEX array, dimension (LDU,M)
-* If JOBU = 'U', U contains the unitary matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) COMPLEX array, dimension (LDV,P)
-* If JOBV = 'V', V contains the unitary matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) COMPLEX array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the unitary matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* TAU (workspace) COMPLEX array, dimension (N)
-*
-* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The subroutine uses LAPACK subroutine CGEQPF for the QR factorization
-* with column pivoting to detect the effective numerical rank of the
-* a matrix. It may be replaced by a better rank determination strategy.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cgt.html b/doc/cgt.html
deleted file mode 100644
index 45393b4..0000000
--- a/doc/cgt.html
+++ /dev/null
@@ -1,731 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for general tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for general tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#cgtcon">cgtcon</A> : </LI>
- <LI><A HREF="#cgtrfs">cgtrfs</A> : </LI>
- <LI><A HREF="#cgtsv">cgtsv</A> : </LI>
- <LI><A HREF="#cgtsvx">cgtsvx</A> : </LI>
- <LI><A HREF="#cgttrf">cgttrf</A> : </LI>
- <LI><A HREF="#cgttrs">cgttrs</A> : </LI>
- <LI><A HREF="#cgtts2">cgtts2</A> : </LI>
- </UL>
-
- <A NAME="cgtcon"></A>
- <H2>cgtcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cgtcon( norm, dl, d, du, du2, ipiv, anorm)
- or
- NumRu::Lapack.cgtcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CGTCON estimates the reciprocal of the condition number of a complex
-* tridiagonal matrix A using the LU factorization as computed by
-* CGTTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* DL (input) COMPLEX array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by CGTTRF.
-*
-* D (input) COMPLEX array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) COMPLEX array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) COMPLEX array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* ANORM (input) REAL
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgtrfs"></A>
- <H2>cgtrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)
- or
- NumRu::Lapack.cgtrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is tridiagonal, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) COMPLEX array, dimension (N)
-* The diagonal elements of A.
-*
-* DU (input) COMPLEX array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input) COMPLEX array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by CGTTRF.
-*
-* DF (input) COMPLEX array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DUF (input) COMPLEX array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) COMPLEX array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CGTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgtsv"></A>
- <H2>cgtsv</H2>
-
- <PRE>
-USAGE:
- info, dl, d, du, b = NumRu::Lapack.cgtsv( dl, d, du, b)
- or
- NumRu::Lapack.cgtsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CGTSV solves the equation
-*
-* A*X = B,
-*
-* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
-* partial pivoting.
-*
-* Note that the equation A'*X = B may be solved by interchanging the
-* order of the arguments DU and DL.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input/output) COMPLEX array, dimension (N-1)
-* On entry, DL must contain the (n-1) subdiagonal elements of
-* A.
-* On exit, DL is overwritten by the (n-2) elements of the
-* second superdiagonal of the upper triangular matrix U from
-* the LU factorization of A, in DL(1), ..., DL(n-2).
-*
-* D (input/output) COMPLEX array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-* On exit, D is overwritten by the n diagonal elements of U.
-*
-* DU (input/output) COMPLEX array, dimension (N-1)
-* On entry, DU must contain the (n-1) superdiagonal elements
-* of A.
-* On exit, DU is overwritten by the (n-1) elements of the first
-* superdiagonal of U.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
-* has not been computed. The factorization has not been
-* completed unless i = N.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgtsvx"></A>
- <H2>cgtsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.cgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)
- or
- NumRu::Lapack.cgtsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CGTSVX uses the LU factorization to compute the solution to a complex
-* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
-* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
-* as A = L * U, where L is a product of permutation and unit lower
-* bidiagonal matrices and U is upper triangular with nonzeros in
-* only the main diagonal and first two superdiagonals.
-*
-* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form
-* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not
-* be modified.
-* = 'N': The matrix will be copied to DLF, DF, and DUF
-* and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) COMPLEX array, dimension (N)
-* The n diagonal elements of A.
-*
-* DU (input) COMPLEX array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input or output) COMPLEX array, dimension (N-1)
-* If FACT = 'F', then DLF is an input argument and on entry
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A as computed by CGTTRF.
-*
-* If FACT = 'N', then DLF is an output argument and on exit
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A.
-*
-* DF (input or output) COMPLEX array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* DUF (input or output) COMPLEX array, dimension (N-1)
-* If FACT = 'F', then DUF is an input argument and on entry
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* If FACT = 'N', then DUF is an output argument and on exit
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input or output) COMPLEX array, dimension (N-2)
-* If FACT = 'F', then DU2 is an input argument and on entry
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* If FACT = 'N', then DU2 is an output argument and on exit
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the LU factorization of A as
-* computed by CGTTRF.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the LU factorization of A;
-* row i of the matrix was interchanged with row IPIV(i).
-* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
-* a row interchange was not required.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has not been completed unless i = N, but the
-* factor U is exactly singular, so the solution
-* and error bounds could not be computed.
-* RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgttrf"></A>
- <H2>cgttrf</H2>
-
- <PRE>
-USAGE:
- du2, ipiv, info, dl, d, du = NumRu::Lapack.cgttrf( dl, d, du)
- or
- NumRu::Lapack.cgttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CGTTRF computes an LU factorization of a complex tridiagonal matrix A
-* using elimination with partial pivoting and row interchanges.
-*
-* The factorization has the form
-* A = L * U
-* where L is a product of permutation and unit lower bidiagonal
-* matrices and U is upper triangular with nonzeros in only the main
-* diagonal and first two superdiagonals.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* DL (input/output) COMPLEX array, dimension (N-1)
-* On entry, DL must contain the (n-1) sub-diagonal elements of
-* A.
-*
-* On exit, DL is overwritten by the (n-1) multipliers that
-* define the matrix L from the LU factorization of A.
-*
-* D (input/output) COMPLEX array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-*
-* On exit, D is overwritten by the n diagonal elements of the
-* upper triangular matrix U from the LU factorization of A.
-*
-* DU (input/output) COMPLEX array, dimension (N-1)
-* On entry, DU must contain the (n-1) super-diagonal elements
-* of A.
-*
-* On exit, DU is overwritten by the (n-1) elements of the first
-* super-diagonal of U.
-*
-* DU2 (output) COMPLEX array, dimension (N-2)
-* On exit, DU2 is overwritten by the (n-2) elements of the
-* second super-diagonal of U.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgttrs"></A>
- <H2>cgttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.cgttrs( trans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.cgttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CGTTRS solves one of the systems of equations
-* A * X = B, A**T * X = B, or A**H * X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by CGTTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) COMPLEX array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) COMPLEX array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) COMPLEX array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL NOTRAN
- INTEGER ITRANS, J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL CGTTS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cgtts2"></A>
- <H2>cgtts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.cgtts2( itrans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.cgtts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
-
-* Purpose
-* =======
-*
-* CGTTS2 solves one of the systems of equations
-* A * X = B, A**T * X = B, or A**H * X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by CGTTRF.
-*
-
-* Arguments
-* =========
-*
-* ITRANS (input) INTEGER
-* Specifies the form of the system of equations.
-* = 0: A * X = B (No transpose)
-* = 1: A**T * X = B (Transpose)
-* = 2: A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) COMPLEX array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) COMPLEX array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) COMPLEX array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, J
- COMPLEX TEMP
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC CONJG
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/chb.html b/doc/chb.html
deleted file mode 100644
index d075619..0000000
--- a/doc/chb.html
+++ /dev/null
@@ -1,1054 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for (complex) Hermitian band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for (complex) Hermitian band matrix</H1>
- <UL>
- <LI><A HREF="#chbev">chbev</A> : </LI>
- <LI><A HREF="#chbevd">chbevd</A> : </LI>
- <LI><A HREF="#chbevx">chbevx</A> : </LI>
- <LI><A HREF="#chbgst">chbgst</A> : </LI>
- <LI><A HREF="#chbgv">chbgv</A> : </LI>
- <LI><A HREF="#chbgvd">chbgvd</A> : </LI>
- <LI><A HREF="#chbgvx">chbgvx</A> : </LI>
- <LI><A HREF="#chbtrd">chbtrd</A> : </LI>
- </UL>
-
- <A NAME="chbev"></A>
- <H2>chbev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab = NumRu::Lapack.chbev( jobz, uplo, kd, ab)
- or
- NumRu::Lapack.chbev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHBEV computes all the eigenvalues and, optionally, eigenvectors of
-* a complex Hermitian band matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (max(1,3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chbevd"></A>
- <H2>chbevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, rwork, iwork, info, ab = NumRu::Lapack.chbevd( jobz, uplo, kd, ab, lwork, lrwork, liwork)
- or
- NumRu::Lapack.chbevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHBEVD computes all the eigenvalues and, optionally, eigenvectors of
-* a complex Hermitian band matrix A. If eigenvectors are desired, it
-* uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array,
-* dimension (LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LRWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chbevx"></A>
- <H2>chbevx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, ifail, info, ab = NumRu::Lapack.chbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.chbevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* CHBEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors
-* can be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* Q (output) COMPLEX array, dimension (LDQ, N)
-* If JOBZ = 'V', the N-by-N unitary matrix used in the
-* reduction to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'V', then
-* LDQ >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AB to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chbgst"></A>
- <H2>chbgst</H2>
-
- <PRE>
-USAGE:
- x, info, ab = NumRu::Lapack.chbgst( vect, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.chbgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHBGST reduces a complex Hermitian-definite banded generalized
-* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
-* such that C has the same bandwidth as A.
-*
-* B must have been previously factorized as S**H*S by CPBSTF, using a
-* split Cholesky factorization. A is overwritten by C = X**H*A*X, where
-* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the
-* bandwidth of A.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form the transformation matrix X;
-* = 'V': form X.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the transformed matrix X**H*A*X, stored in the same
-* format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input) COMPLEX array, dimension (LDBB,N)
-* The banded factor S from the split Cholesky factorization of
-* B, as returned by CPBSTF, stored in the first kb+1 rows of
-* the array.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* X (output) COMPLEX array, dimension (LDX,N)
-* If VECT = 'V', the n-by-n matrix X.
-* If VECT = 'N', the array X is not referenced.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X.
-* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chbgv"></A>
- <H2>chbgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab, bb = NumRu::Lapack.chbgv( jobz, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.chbgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHBGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
-* and banded, and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) COMPLEX array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**H*S, as returned by CPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**H*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER VECT
- INTEGER IINFO, INDE, INDWRK
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CHBGST, CHBTRD, CPBSTF, CSTEQR, SSTERF, XERBLA
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chbgvd"></A>
- <H2>chbgvd</H2>
-
- <PRE>
-USAGE:
- w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.chbgvd( jobz, uplo, ka, kb, ab, bb, lwork, lrwork, liwork)
- or
- NumRu::Lapack.chbgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHBGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
-* and banded, and B is also positive definite. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) COMPLEX array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**H*S, as returned by CPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**H*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= N.
-* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))
-* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK >= 1.
-* If JOBZ = 'N' and N > 1, LRWORK >= N.
-* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chbgvx"></A>
- <H2>chbgvx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.chbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.chbgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* CHBGVX computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
-* and banded, and B is also positive definite. Eigenvalues and
-* eigenvectors can be selected by specifying either all eigenvalues,
-* a range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) COMPLEX array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**H*S, as returned by CPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* Q (output) COMPLEX array, dimension (LDQ, N)
-* If JOBZ = 'V', the n-by-n matrix used in the reduction of
-* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
-* and consequently C to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'N',
-* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**H*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: then i eigenvectors failed to converge. Their
-* indices are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chbtrd"></A>
- <H2>chbtrd</H2>
-
- <PRE>
-USAGE:
- d, e, info, ab, q = NumRu::Lapack.chbtrd( vect, uplo, kd, ab, q)
- or
- NumRu::Lapack.chbtrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CHBTRD reduces a complex Hermitian band matrix A to real symmetric
-* tridiagonal form T by a unitary similarity transformation:
-* Q**H * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form Q;
-* = 'V': form Q;
-* = 'U': update a matrix X, by forming X*Q.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* On exit, the diagonal elements of AB are overwritten by the
-* diagonal elements of the tridiagonal matrix T; if KD > 0, the
-* elements on the first superdiagonal (if UPLO = 'U') or the
-* first subdiagonal (if UPLO = 'L') are overwritten by the
-* off-diagonal elements of T; the rest of AB is overwritten by
-* values generated during the reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T.
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
-*
-* Q (input/output) COMPLEX array, dimension (LDQ,N)
-* On entry, if VECT = 'U', then Q must contain an N-by-N
-* matrix X; if VECT = 'N' or 'V', then Q need not be set.
-*
-* On exit:
-* if VECT = 'V', Q contains the N-by-N unitary matrix Q;
-* if VECT = 'U', Q contains the product X*Q;
-* if VECT = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Modified by Linda Kaufman, Bell Labs.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/che.html b/doc/che.html
deleted file mode 100644
index 2618f0e..0000000
--- a/doc/che.html
+++ /dev/null
@@ -1,3233 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for (complex) Hermitian matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for (complex) Hermitian matrix</H1>
- <UL>
- <LI><A HREF="#checon">checon</A> : </LI>
- <LI><A HREF="#cheequb">cheequb</A> : </LI>
- <LI><A HREF="#cheev">cheev</A> : </LI>
- <LI><A HREF="#cheevd">cheevd</A> : </LI>
- <LI><A HREF="#cheevr">cheevr</A> : </LI>
- <LI><A HREF="#cheevx">cheevx</A> : </LI>
- <LI><A HREF="#chegs2">chegs2</A> : </LI>
- <LI><A HREF="#chegst">chegst</A> : </LI>
- <LI><A HREF="#chegv">chegv</A> : </LI>
- <LI><A HREF="#chegvd">chegvd</A> : </LI>
- <LI><A HREF="#chegvx">chegvx</A> : </LI>
- <LI><A HREF="#cherfs">cherfs</A> : </LI>
- <LI><A HREF="#cherfsx">cherfsx</A> : </LI>
- <LI><A HREF="#chesv">chesv</A> : </LI>
- <LI><A HREF="#chesvx">chesvx</A> : </LI>
- <LI><A HREF="#chesvxx">chesvxx</A> : </LI>
- <LI><A HREF="#chetd2">chetd2</A> : </LI>
- <LI><A HREF="#chetf2">chetf2</A> : </LI>
- <LI><A HREF="#chetrd">chetrd</A> : </LI>
- <LI><A HREF="#chetrf">chetrf</A> : </LI>
- <LI><A HREF="#chetri">chetri</A> : </LI>
- <LI><A HREF="#chetrs">chetrs</A> : </LI>
- <LI><A HREF="#chetrs2">chetrs2</A> : </LI>
- </UL>
-
- <A NAME="checon"></A>
- <H2>checon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.checon( uplo, a, ipiv, anorm)
- or
- NumRu::Lapack.checon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CHECON estimates the reciprocal of the condition number of a complex
-* Hermitian matrix A using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by CHETRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHETRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cheequb"></A>
- <H2>cheequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.cheequb( uplo, a)
- or
- NumRu::Lapack.cheequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYEQUB computes row and column scalings intended to equilibrate a
-* symmetric matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The N-by-N symmetric matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cheev"></A>
- <H2>cheev</H2>
-
- <PRE>
-USAGE:
- w, work, info, a = NumRu::Lapack.cheev( jobz, uplo, a, lwork)
- or
- NumRu::Lapack.cheev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHEEV computes all eigenvalues and, optionally, eigenvectors of a
-* complex Hermitian matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N-1).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the blocksize for CHETRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cheevd"></A>
- <H2>cheevd</H2>
-
- <PRE>
-USAGE:
- w, work, rwork, iwork, info, a = NumRu::Lapack.cheevd( jobz, uplo, a, lwork, lrwork, liwork)
- or
- NumRu::Lapack.cheevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHEEVD computes all eigenvalues and, optionally, eigenvectors of a
-* complex Hermitian matrix A. If eigenvectors are desired, it uses a
-* divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
-* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array,
-* dimension (LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-* If N <= 1, LRWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LRWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
-* to converge; i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* if INFO = i and JOBZ = 'V', then the algorithm failed
-* to compute an eigenvalue while working on the submatrix
-* lying in rows and columns INFO/(N+1) through
-* mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-*
-* Modified description of INFO. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cheevr"></A>
- <H2>cheevr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.cheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, lrwork, liwork)
- or
- NumRu::Lapack.cheevr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHEEVR computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
-* be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-* CHEEVR first reduces the matrix A to tridiagonal form T with a call
-* to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute
-* the eigenspectrum using Relatively Robust Representations. CSTEMR
-* computes eigenvalues by the dqds algorithm, while orthogonal
-* eigenvectors are computed from various "good" L D L^T representations
-* (also known as Relatively Robust Representations). Gram-Schmidt
-* orthogonalization is avoided as far as possible. More specifically,
-* the various steps of the algorithm are as follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* The desired accuracy of the output can be specified by the input
-* parameter ABSTOL.
-*
-* For more details, see DSTEMR's documentation and:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-*
-* Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested
-* on machines which conform to the ieee-754 floating point standard.
-* CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and
-* when partial spectrum requests are made.
-*
-* Normal execution of CSTEMR may create NaNs and infinities and
-* hence may abort due to a floating point exception in environments
-* which do not handle NaNs and infinities in the ieee standard default
-* manner.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
-********** CSTEIN are called
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* If high relative accuracy is important, set ABSTOL to
-* SLAMCH( 'Safe minimum' ). Doing so will guarantee that
-* eigenvalues are computed to high relative accuracy when
-* possible in future releases. The current code does not
-* make any guarantees about high relative accuracy, but
-* furutre releases will. See J. Barlow and J. Demmel,
-* "Computing Accurate Eigensystems of Scaled Diagonally
-* Dominant Matrices", LAPACK Working Note #7, for a discussion
-* of which matrices define their eigenvalues to high relative
-* accuracy.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ).
-********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the max of the blocksize for CHETRD and for
-* CUNMTR as returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the optimal
-* (and minimal) LRWORK.
-*
-* LRWORK (input) INTEGER
-* The length of the array RWORK. LRWORK >= max(1,24*N).
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal
-* (and minimal) LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: Internal error
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Ken Stanley, Computer Science Division, University of
-* California at Berkeley, USA
-* Jason Riedy, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cheevx"></A>
- <H2>cheevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a = NumRu::Lapack.cheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)
- or
- NumRu::Lapack.cheevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* CHEEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
-* be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= 1, when N <= 1;
-* otherwise 2*N.
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the max of the blocksize for CHETRD and for
-* CUNMTR as returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chegs2"></A>
- <H2>chegs2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.chegs2( itype, uplo, a, b)
- or
- NumRu::Lapack.chegs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CHEGS2 reduces a complex Hermitian-definite generalized
-* eigenproblem to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
-*
-* B must have been previously factorized as U'*U or L*L' by CPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
-* = 2 or 3: compute U*A*U' or L'*A*L.
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored, and how B has been factorized.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by CPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chegst"></A>
- <H2>chegst</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.chegst( itype, uplo, a, b)
- or
- NumRu::Lapack.chegst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CHEGST reduces a complex Hermitian-definite generalized
-* eigenproblem to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
-*
-* B must have been previously factorized as U**H*U or L*L**H by CPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
-* = 2 or 3: compute U*A*U**H or L**H*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**H*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**H.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by CPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chegv"></A>
- <H2>chegv</H2>
-
- <PRE>
-USAGE:
- w, work, info, a, b = NumRu::Lapack.chegv( itype, jobz, uplo, a, b, lwork)
- or
- NumRu::Lapack.chegv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHEGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be Hermitian and B is also
-* positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the Hermitian positive definite matrix B.
-* If UPLO = 'U', the leading N-by-N upper triangular part of B
-* contains the upper triangular part of the matrix B.
-* If UPLO = 'L', the leading N-by-N lower triangular part of B
-* contains the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N-1).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the blocksize for CHETRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: CPOTRF or CHEEV returned an error code:
-* <= N: if INFO = i, CHEEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chegvd"></A>
- <H2>chegvd</H2>
-
- <PRE>
-USAGE:
- w, work, rwork, iwork, info, a, b = NumRu::Lapack.chegvd( itype, jobz, uplo, a, b, lwork, lrwork, liwork)
- or
- NumRu::Lapack.chegvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHEGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian and B is also positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the Hermitian matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= N + 1.
-* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-* If N <= 1, LRWORK >= 1.
-* If JOBZ = 'N' and N > 1, LRWORK >= N.
-* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK >= 1.
-* If JOBZ = 'N' and N > 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: CPOTRF or CHEEVD returned an error code:
-* <= N: if INFO = i and JOBZ = 'N', then the algorithm
-* failed to converge; i off-diagonal elements of an
-* intermediate tridiagonal form did not converge to
-* zero;
-* if INFO = i and JOBZ = 'V', then the algorithm
-* failed to compute an eigenvalue while working on
-* the submatrix lying in rows and columns INFO/(N+1)
-* through mod(INFO,N+1);
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* Modified so that no backsubstitution is performed if CHEEVD fails to
-* converge (NEIG in old code could be greater than N causing out of
-* bounds reference to A - reported by Ralf Meyer). Also corrected the
-* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chegvx"></A>
- <H2>chegvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a, b = NumRu::Lapack.chegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, ldz, lwork)
- or
- NumRu::Lapack.chegvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* CHEGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian and B is also positive definite.
-* Eigenvalues and eigenvectors can be selected by specifying either a
-* range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-**
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB, N)
-* On entry, the Hermitian matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, max(1,M))
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the blocksize for CHETRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: CPOTRF or CHEEVX returned an error code:
-* <= N: if INFO = i, CHEEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cherfs"></A>
- <H2>cherfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cherfs( uplo, a, af, ipiv, b, x)
- or
- NumRu::Lapack.cherfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHERFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian indefinite, and
-* provides error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**H or
-* A = L*D*L**H as computed by CHETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHETRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CHETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cherfsx"></A>
- <H2>cherfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cherfsx( uplo, equed, a, af, ipiv, s, b, x, params)
- or
- NumRu::Lapack.cherfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHERFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian indefinite, and
-* provides error bounds and backward error estimates for the
-* solution. In addition to normwise error bound, the code provides
-* maximum componentwise error bound if possible. See comments for
-* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or A =
-* L*D*L**T as computed by SSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chesv"></A>
- <H2>chesv</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a, b = NumRu::Lapack.chesv( uplo, a, b, lwork)
- or
- NumRu::Lapack.chesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHESV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
-* matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
-* used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the block diagonal matrix D and the
-* multipliers used to obtain the factor U or L from the
-* factorization A = U*D*U**H or A = L*D*L**H as computed by
-* CHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by CHETRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= 1, and for best performance
-* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
-* CHETRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LWKOPT, NB
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CHETRF, CHETRS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chesvx"></A>
- <H2>chesvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.chesvx( fact, uplo, a, af, ipiv, b, lwork)
- or
- NumRu::Lapack.chesvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHESVX uses the diagonal pivoting factorization to compute the
-* solution to a complex system of linear equations A * X = B,
-* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
-* The form of the factorization is
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AF and IPIV contain the factored form
-* of A. A, AF and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by CHETRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by CHETRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by CHETRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= max(1,2*N), and for best
-* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
-* NB is the optimal blocksize for CHETRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chesvxx"></A>
- <H2>chesvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.chesvxx( fact, uplo, a, af, ipiv, equed, s, b, params)
- or
- NumRu::Lapack.chesvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHESVXX uses the diagonal pivoting factorization to compute the
-* solution to a complex system of linear equations A * X = B, where
-* A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. CHESVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* CHESVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* CHESVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what CHESVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 3. If some D(i,i)=0, so that D is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is
-* less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(R) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T as computed by SSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block
-* structure of D, as determined by CHETRF. If IPIV(k) > 0,
-* then rows and columns k and IPIV(k) were interchanged and
-* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and
-* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and
-* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2
-* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,
-* then rows and columns k+1 and -IPIV(k) were interchanged
-* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block
-* structure of D, as determined by CHETRF.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chetd2"></A>
- <H2>chetd2</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, a = NumRu::Lapack.chetd2( uplo, a)
- or
- NumRu::Lapack.chetd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* CHETD2 reduces a complex Hermitian matrix A to real symmetric
-* tridiagonal form T by a unitary similarity transformation:
-* Q' * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the unitary
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the unitary matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) COMPLEX array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chetf2"></A>
- <H2>chetf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.chetf2( uplo, a)
- or
- NumRu::Lapack.chetf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CHETF2 computes the factorization of a complex Hermitian matrix A
-* using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U' or A = L*D*L'
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, U' is the conjugate transpose of U, and D is
-* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 09-29-06 - patch from
-* Bobby Cheng, MathWorks
-*
-* Replace l.210 and l.392
-* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
-* by
-* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
-*
-* 01-01-96 - Based on modifications by
-* J. Lewis, Boeing Computer Services Company
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chetrd"></A>
- <H2>chetrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, work, info, a = NumRu::Lapack.chetrd( uplo, a, lwork)
- or
- NumRu::Lapack.chetrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHETRD reduces a complex Hermitian matrix A to real symmetric
-* tridiagonal form T by a unitary similarity transformation:
-* Q**H * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the unitary
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the unitary matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) COMPLEX array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chetrf"></A>
- <H2>chetrf</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a = NumRu::Lapack.chetrf( uplo, a, lwork)
- or
- NumRu::Lapack.chetrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHETRF computes the factorization of a complex Hermitian matrix A
-* using the Bunch-Kaufman diagonal pivoting method. The form of the
-* factorization is
-*
-* A = U*D*U**H or A = L*D*L**H
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1. For best performance
-* LWORK >= N*NB, where NB is the block size returned by ILAENV.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER
- INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL CHETF2, CLAHEF, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chetri"></A>
- <H2>chetri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.chetri( uplo, a, ipiv)
- or
- NumRu::Lapack.chetri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CHETRI computes the inverse of a complex Hermitian indefinite matrix
-* A using the factorization A = U*D*U**H or A = L*D*L**H computed by
-* CHETRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by CHETRF.
-*
-* On exit, if INFO = 0, the (Hermitian) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHETRF.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chetrs"></A>
- <H2>chetrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.chetrs( uplo, a, ipiv, b)
- or
- NumRu::Lapack.chetrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CHETRS solves a system of linear equations A*X = B with a complex
-* Hermitian matrix A using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by CHETRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHETRF.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chetrs2"></A>
- <H2>chetrs2</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.chetrs2( uplo, a, ipiv, b)
- or
- NumRu::Lapack.chetrs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CHETRS2 solves a system of linear equations A*X = B with a COMPLEX
-* Hermitian matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by CSYTRF and converted by CSYCONV.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHETRF.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/chg.html b/doc/chg.html
deleted file mode 100644
index 5a0eb7e..0000000
--- a/doc/chg.html
+++ /dev/null
@@ -1,203 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</H1>
- <UL>
- <LI><A HREF="#chgeqz">chgeqz</A> : </LI>
- </UL>
-
- <A NAME="chgeqz"></A>
- <H2>chgeqz</H2>
-
- <PRE>
-USAGE:
- alpha, beta, work, info, h, t, q, z = NumRu::Lapack.chgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)
- or
- NumRu::Lapack.chgeqz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T),
-* where H is an upper Hessenberg matrix and T is upper triangular,
-* using the single-shift QZ method.
-* Matrix pairs of this type are produced by the reduction to
-* generalized upper Hessenberg form of a complex matrix pair (A,B):
-*
-* A = Q1*H*Z1**H, B = Q1*T*Z1**H,
-*
-* as computed by CGGHRD.
-*
-* If JOB='S', then the Hessenberg-triangular pair (H,T) is
-* also reduced to generalized Schur form,
-*
-* H = Q*S*Z**H, T = Q*P*Z**H,
-*
-* where Q and Z are unitary matrices and S and P are upper triangular.
-*
-* Optionally, the unitary matrix Q from the generalized Schur
-* factorization may be postmultiplied into an input matrix Q1, and the
-* unitary matrix Z may be postmultiplied into an input matrix Z1.
-* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced
-* the matrix pair (A,B) to generalized Hessenberg form, then the output
-* matrices Q1*Q and Z1*Z are the unitary factors from the generalized
-* Schur factorization of (A,B):
-*
-* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.
-*
-* To avoid overflow, eigenvalues of the matrix pair (H,T)
-* (equivalently, of (A,B)) are computed as a pair of complex values
-* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an
-* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)
-* A*x = lambda*B*x
-* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
-* alternate form of the GNEP
-* mu*A*y = B*y.
-* The values of alpha and beta for the i-th eigenvalue can be read
-* directly from the generalized Schur form: alpha = S(i,i),
-* beta = P(i,i).
-*
-* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
-* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
-* pp. 241--256.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': Compute eigenvalues only;
-* = 'S': Computer eigenvalues and the Schur form.
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': Left Schur vectors (Q) are not computed;
-* = 'I': Q is initialized to the unit matrix and the matrix Q
-* of left Schur vectors of (H,T) is returned;
-* = 'V': Q must contain a unitary matrix Q1 on entry and
-* the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Right Schur vectors (Z) are not computed;
-* = 'I': Q is initialized to the unit matrix and the matrix Z
-* of right Schur vectors of (H,T) is returned;
-* = 'V': Z must contain a unitary matrix Z1 on entry and
-* the product Z1*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrices H, T, Q, and Z. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of H which are in
-* Hessenberg form. It is assumed that A is already upper
-* triangular in rows and columns 1:ILO-1 and IHI+1:N.
-* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
-*
-* H (input/output) COMPLEX array, dimension (LDH, N)
-* On entry, the N-by-N upper Hessenberg matrix H.
-* On exit, if JOB = 'S', H contains the upper triangular
-* matrix S from the generalized Schur factorization.
-* If JOB = 'E', the diagonal of H matches that of S, but
-* the rest of H is unspecified.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max( 1, N ).
-*
-* T (input/output) COMPLEX array, dimension (LDT, N)
-* On entry, the N-by-N upper triangular matrix T.
-* On exit, if JOB = 'S', T contains the upper triangular
-* matrix P from the generalized Schur factorization.
-* If JOB = 'E', the diagonal of T matches that of P, but
-* the rest of T is unspecified.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max( 1, N ).
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* The complex scalars alpha that define the eigenvalues of
-* GNEP. ALPHA(i) = S(i,i) in the generalized Schur
-* factorization.
-*
-* BETA (output) COMPLEX array, dimension (N)
-* The real non-negative scalars beta that define the
-* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized
-* Schur factorization.
-*
-* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
-* represent the j-th eigenvalue of the matrix pair (A,B), in
-* one of the forms lambda = alpha/beta or mu = beta/alpha.
-* Since either lambda or mu may overflow, they should not,
-* in general, be computed.
-*
-* Q (input/output) COMPLEX array, dimension (LDQ, N)
-* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the
-* reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the unitary matrix of left Schur
-* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
-* left Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If COMPQ='V' or 'I', then LDQ >= N.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the
-* reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the unitary matrix of right Schur
-* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
-* right Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If COMPZ='V' or 'I', then LDZ >= N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1,...,N: the QZ iteration did not converge. (H,T) is not
-* in Schur form, but ALPHA(i) and BETA(i),
-* i=INFO+1,...,N should be correct.
-* = N+1,...,2*N: the shift calculation failed. (H,T) is not
-* in Schur form, but ALPHA(i) and BETA(i),
-* i=INFO-N+1,...,N should be correct.
-*
-
-* Further Details
-* ===============
-*
-* We assume that complex ABS works as long as its value is less than
-* overflow.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/chp.html b/doc/chp.html
deleted file mode 100644
index 9e70180..0000000
--- a/doc/chp.html
+++ /dev/null
@@ -1,1740 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for (complex) Hermitian, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for (complex) Hermitian, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#chpcon">chpcon</A> : </LI>
- <LI><A HREF="#chpev">chpev</A> : </LI>
- <LI><A HREF="#chpevd">chpevd</A> : </LI>
- <LI><A HREF="#chpevx">chpevx</A> : </LI>
- <LI><A HREF="#chpgst">chpgst</A> : </LI>
- <LI><A HREF="#chpgv">chpgv</A> : </LI>
- <LI><A HREF="#chpgvd">chpgvd</A> : </LI>
- <LI><A HREF="#chpgvx">chpgvx</A> : </LI>
- <LI><A HREF="#chprfs">chprfs</A> : </LI>
- <LI><A HREF="#chpsv">chpsv</A> : </LI>
- <LI><A HREF="#chpsvx">chpsvx</A> : </LI>
- <LI><A HREF="#chptrd">chptrd</A> : </LI>
- <LI><A HREF="#chptrf">chptrf</A> : </LI>
- <LI><A HREF="#chptri">chptri</A> : </LI>
- <LI><A HREF="#chptrs">chptrs</A> : </LI>
- </UL>
-
- <A NAME="chpcon"></A>
- <H2>chpcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.chpcon( uplo, ap, ipiv, anorm)
- or
- NumRu::Lapack.chpcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPCON estimates the reciprocal of the condition number of a complex
-* Hermitian packed matrix A using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by CHPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CHPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHPTRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpev"></A>
- <H2>chpev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap = NumRu::Lapack.chpev( jobz, uplo, ap)
- or
- NumRu::Lapack.chpev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPEV computes all the eigenvalues and, optionally, eigenvectors of a
-* complex Hermitian matrix in packed storage.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))
-*
-* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpevd"></A>
- <H2>chpevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, rwork, iwork, info, ap = NumRu::Lapack.chpevd( jobz, uplo, ap, lwork, lrwork, liwork)
- or
- NumRu::Lapack.chpevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPEVD computes all the eigenvalues and, optionally, eigenvectors of
-* a complex Hermitian matrix A in packed storage. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LRWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpevx"></A>
- <H2>chpevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap = NumRu::Lapack.chpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.chpevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* CHPEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian matrix A in packed storage.
-* Eigenvalues/vectors can be selected by specifying either a range of
-* values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the selected eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and
-* the index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpgst"></A>
- <H2>chpgst</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.chpgst( itype, uplo, n, ap, bp)
- or
- NumRu::Lapack.chpgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO )
-
-* Purpose
-* =======
-*
-* CHPGST reduces a complex Hermitian-definite generalized
-* eigenproblem to standard form, using packed storage.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
-*
-* B must have been previously factorized as U**H*U or L*L**H by CPPTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
-* = 2 or 3: compute U*A*U**H or L**H*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**H*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**H.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* BP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The triangular factor from the Cholesky factorization of B,
-* stored in the same format as A, as returned by CPPTRF.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpgv"></A>
- <H2>chpgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap, bp = NumRu::Lapack.chpgv( itype, jobz, uplo, ap, bp)
- or
- NumRu::Lapack.chpgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPGV computes all the eigenvalues and, optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be Hermitian, stored in packed format,
-* and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H, in the same storage
-* format as B.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))
-*
-* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: CPPTRF or CHPEV returned an error code:
-* <= N: if INFO = i, CHPEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not convergeto zero;
-* > N: if INFO = N + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER TRANS
- INTEGER J, NEIG
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CHPEV, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpgvd"></A>
- <H2>chpgvd</H2>
-
- <PRE>
-USAGE:
- w, z, iwork, info, ap, bp = NumRu::Lapack.chpgvd( itype, jobz, uplo, ap, bp, lwork, lrwork, liwork)
- or
- NumRu::Lapack.chpgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPGVD computes all the eigenvalues and, optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian, stored in packed format, and B is also
-* positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H, in the same storage
-* format as B.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= N.
-* If JOBZ = 'V' and N > 1, LWORK >= 2*N.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK >= 1.
-* If JOBZ = 'N' and N > 1, LRWORK >= N.
-* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: CPPTRF or CHPEVD returned an error code:
-* <= N: if INFO = i, CHPEVD failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not convergeto zero;
-* > N: if INFO = N + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER, WANTZ
- CHARACTER TRANS
- INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CHPEVD, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, REAL
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpgvx"></A>
- <H2>chpgvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap, bp = NumRu::Lapack.chpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)
- or
- NumRu::Lapack.chpgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* CHPGVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian, stored in packed format, and B is also
-* positive definite. Eigenvalues and eigenvectors can be selected by
-* specifying either a range of values or a range of indices for the
-* desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H, in the same storage
-* format as B.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, N)
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: CPPTRF or CHPEVX returned an error code:
-* <= N: if INFO = i, CHPEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
- CHARACTER TRANS
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CHPEVX, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chprfs"></A>
- <H2>chprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.chprfs( uplo, ap, afp, ipiv, b, x)
- or
- NumRu::Lapack.chprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian indefinite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The factored form of the matrix A. AFP contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**H or
-* A = L*D*L**H as computed by CHPTRF, stored as a packed
-* triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHPTRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CHPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpsv"></A>
- <H2>chpsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap, b = NumRu::Lapack.chpsv( uplo, ap, b)
- or
- NumRu::Lapack.chpsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CHPSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian matrix stored in packed format and X
-* and B are N-by-NRHS matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, D is Hermitian and block diagonal with 1-by-1
-* and 2-by-2 diagonal blocks. The factored form of A is then used to
-* solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by CHPTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be
-* computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CHPTRF, CHPTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chpsvx"></A>
- <H2>chpsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.chpsvx( fact, uplo, ap, afp, ipiv, b)
- or
- NumRu::Lapack.chpsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or
-* A = L*D*L**H to compute the solution to a complex system of linear
-* equations A * X = B, where A is an N-by-N Hermitian matrix stored
-* in packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AFP and IPIV contain the factored form of
-* A. AFP and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by CHPTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by CHPTRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chptrd"></A>
- <H2>chptrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, ap = NumRu::Lapack.chptrd( uplo, ap)
- or
- NumRu::Lapack.chptrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* CHPTRD reduces a complex Hermitian matrix A stored in packed form to
-* real symmetric tridiagonal form T by a unitary similarity
-* transformation: Q**H * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the unitary
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the unitary matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) COMPLEX array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
-* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
-* overwriting A(i+2:n,i), and tau is stored in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chptrf"></A>
- <H2>chptrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap = NumRu::Lapack.chptrf( uplo, ap)
- or
- NumRu::Lapack.chptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CHPTRF computes the factorization of a complex Hermitian packed
-* matrix A using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U**H or A = L*D*L**H
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L, stored as a packed triangular
-* matrix overwriting A (see below for further details).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chptri"></A>
- <H2>chptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.chptri( uplo, ap, ipiv)
- or
- NumRu::Lapack.chptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CHPTRI computes the inverse of a complex Hermitian indefinite matrix
-* A in packed storage using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by CHPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by CHPTRF,
-* stored as a packed triangular matrix.
-*
-* On exit, if INFO = 0, the (Hermitian) inverse of the original
-* matrix, stored as a packed triangular matrix. The j-th column
-* of inv(A) is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
-* if UPLO = 'L',
-* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHPTRF.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chptrs"></A>
- <H2>chptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.chptrs( uplo, ap, ipiv, b)
- or
- NumRu::Lapack.chptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CHPTRS solves a system of linear equations A*X = B with a complex
-* Hermitian matrix A stored in packed format using the factorization
-* A = U*D*U**H or A = L*D*L**H computed by CHPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CHPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CHPTRF.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/chs.html b/doc/chs.html
deleted file mode 100644
index 50b33d1..0000000
--- a/doc/chs.html
+++ /dev/null
@@ -1,391 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for upper Hessenberg matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for upper Hessenberg matrix</H1>
- <UL>
- <LI><A HREF="#chsein">chsein</A> : </LI>
- <LI><A HREF="#chseqr">chseqr</A> : </LI>
- </UL>
-
- <A NAME="chsein"></A>
- <H2>chsein</H2>
-
- <PRE>
-USAGE:
- m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.chsein( side, eigsrc, initv, select, h, w, vl, vr)
- or
- NumRu::Lapack.chsein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )
-
-* Purpose
-* =======
-*
-* CHSEIN uses inverse iteration to find specified right and/or left
-* eigenvectors of a complex upper Hessenberg matrix H.
-*
-* The right eigenvector x and the left eigenvector y of the matrix H
-* corresponding to an eigenvalue w are defined by:
-*
-* H * x = w * x, y**h * H = w * y**h
-*
-* where y**h denotes the conjugate transpose of the vector y.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* EIGSRC (input) CHARACTER*1
-* Specifies the source of eigenvalues supplied in W:
-* = 'Q': the eigenvalues were found using CHSEQR; thus, if
-* H has zero subdiagonal elements, and so is
-* block-triangular, then the j-th eigenvalue can be
-* assumed to be an eigenvalue of the block containing
-* the j-th row/column. This property allows CHSEIN to
-* perform inverse iteration on just one diagonal block.
-* = 'N': no assumptions are made on the correspondence
-* between eigenvalues and diagonal blocks. In this
-* case, CHSEIN must always perform inverse iteration
-* using the whole matrix H.
-*
-* INITV (input) CHARACTER*1
-* = 'N': no initial vectors are supplied;
-* = 'U': user-supplied initial vectors are stored in the arrays
-* VL and/or VR.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* Specifies the eigenvectors to be computed. To select the
-* eigenvector corresponding to the eigenvalue W(j),
-* SELECT(j) must be set to .TRUE..
-*
-* N (input) INTEGER
-* The order of the matrix H. N >= 0.
-*
-* H (input) COMPLEX array, dimension (LDH,N)
-* The upper Hessenberg matrix H.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max(1,N).
-*
-* W (input/output) COMPLEX array, dimension (N)
-* On entry, the eigenvalues of H.
-* On exit, the real parts of W may have been altered since
-* close eigenvalues are perturbed slightly in searching for
-* independent eigenvectors.
-*
-* VL (input/output) COMPLEX array, dimension (LDVL,MM)
-* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
-* contain starting vectors for the inverse iteration for the
-* left eigenvectors; the starting vector for each eigenvector
-* must be in the same column in which the eigenvector will be
-* stored.
-* On exit, if SIDE = 'L' or 'B', the left eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VL, in the same order as their eigenvalues.
-* If SIDE = 'R', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
-*
-* VR (input/output) COMPLEX array, dimension (LDVR,MM)
-* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
-* contain starting vectors for the inverse iteration for the
-* right eigenvectors; the starting vector for each eigenvector
-* must be in the same column in which the eigenvector will be
-* stored.
-* On exit, if SIDE = 'R' or 'B', the right eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VR, in the same order as their eigenvalues.
-* If SIDE = 'L', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR required to
-* store the eigenvectors (= the number of .TRUE. elements in
-* SELECT).
-*
-* WORK (workspace) COMPLEX array, dimension (N*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* IFAILL (output) INTEGER array, dimension (MM)
-* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
-* eigenvector in the i-th column of VL (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
-* eigenvector converged satisfactorily.
-* If SIDE = 'R', IFAILL is not referenced.
-*
-* IFAILR (output) INTEGER array, dimension (MM)
-* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
-* eigenvector in the i-th column of VR (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
-* eigenvector converged satisfactorily.
-* If SIDE = 'L', IFAILR is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, i is the number of eigenvectors which
-* failed to converge; see IFAILL and IFAILR for further
-* details.
-*
-
-* Further Details
-* ===============
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x|+|y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="chseqr"></A>
- <H2>chseqr</H2>
-
- <PRE>
-USAGE:
- w, work, info, h, z = NumRu::Lapack.chseqr( job, compz, ilo, ihi, h, z, ldz, lwork)
- or
- NumRu::Lapack.chseqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CHSEQR computes the eigenvalues of a Hessenberg matrix H
-* and, optionally, the matrices T and Z from the Schur decomposition
-* H = Z T Z**H, where T is an upper triangular matrix (the
-* Schur form), and Z is the unitary matrix of Schur vectors.
-*
-* Optionally Z may be postmultiplied into an input unitary
-* matrix Q so that this routine can give the Schur factorization
-* of a matrix A which has been reduced to the Hessenberg form H
-* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': compute eigenvalues only;
-* = 'S': compute eigenvalues and the Schur form T.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': no Schur vectors are computed;
-* = 'I': Z is initialized to the unit matrix and the matrix Z
-* of Schur vectors of H is returned;
-* = 'V': Z must contain an unitary matrix Q on entry, and
-* the product Q*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrix H. N .GE. 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that H is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to CGEBAL, and then passed to CGEHRD
-* when the matrix output by CGEBAL is reduced to Hessenberg
-* form. Otherwise ILO and IHI should be set to 1 and N
-* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
-* If N = 0, then ILO = 1 and IHI = 0.
-*
-* H (input/output) COMPLEX array, dimension (LDH,N)
-* On entry, the upper Hessenberg matrix H.
-* On exit, if INFO = 0 and JOB = 'S', H contains the upper
-* triangular matrix T from the Schur decomposition (the
-* Schur form). If INFO = 0 and JOB = 'E', the contents of
-* H are unspecified on exit. (The output value of H when
-* INFO.GT.0 is given under the description of INFO below.)
-*
-* Unlike earlier versions of CHSEQR, this subroutine may
-* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
-* or j = IHI+1, IHI+2, ... N.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH .GE. max(1,N).
-*
-* W (output) COMPLEX array, dimension (N)
-* The computed eigenvalues. If JOB = 'S', the eigenvalues are
-* stored in the same order as on the diagonal of the Schur
-* form returned in H, with W(i) = H(i,i).
-*
-* Z (input/output) COMPLEX array, dimension (LDZ,N)
-* If COMPZ = 'N', Z is not referenced.
-* If COMPZ = 'I', on entry Z need not be set and on exit,
-* if INFO = 0, Z contains the unitary matrix Z of the Schur
-* vectors of H. If COMPZ = 'V', on entry Z must contain an
-* N-by-N matrix Q, which is assumed to be equal to the unit
-* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
-* if INFO = 0, Z contains Q*Z.
-* Normally Q is the unitary matrix generated by CUNGHR
-* after the call to CGEHRD which formed the Hessenberg matrix
-* H. (The output value of Z when INFO.GT.0 is given under
-* the description of INFO below.)
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. if COMPZ = 'I' or
-* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
-*
-* WORK (workspace/output) COMPLEX array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns an estimate of
-* the optimal value for LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK .GE. max(1,N)
-* is sufficient and delivers very good and sometimes
-* optimal performance. However, LWORK as large as 11*N
-* may be required for optimal performance. A workspace
-* query is recommended to determine the optimal workspace
-* size.
-*
-* If LWORK = -1, then CHSEQR does a workspace query.
-* In this case, CHSEQR checks the input parameters and
-* estimates the optimal workspace size for the given
-* values of N, ILO and IHI. The estimate is returned
-* in WORK(1). No error message related to LWORK is
-* issued by XERBLA. Neither H nor Z are accessed.
-*
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* .LT. 0: if INFO = -i, the i-th argument had an illegal
-* value
-* .GT. 0: if INFO = i, CHSEQR failed to compute all of
-* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
-* and WI contain those eigenvalues which have been
-* successfully computed. (Failures are rare.)
-*
-* If INFO .GT. 0 and JOB = 'E', then on exit, the
-* remaining unconverged eigenvalues are the eigen-
-* values of the upper Hessenberg matrix rows and
-* columns ILO through INFO of the final, output
-* value of H.
-*
-* If INFO .GT. 0 and JOB = 'S', then on exit
-*
-* (*) (initial value of H)*U = U*(final value of H)
-*
-* where U is a unitary matrix. The final
-* value of H is upper Hessenberg and triangular in
-* rows and columns INFO+1 through IHI.
-*
-* If INFO .GT. 0 and COMPZ = 'V', then on exit
-*
-* (final value of Z) = (initial value of Z)*U
-*
-* where U is the unitary matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'I', then on exit
-* (final value of Z) = U
-* where U is the unitary matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'N', then Z is not
-* accessed.
-*
-
-* ================================================================
-* Default values supplied by
-* ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
-* It is suggested that these defaults be adjusted in order
-* to attain best performance in each particular
-* computational environment.
-*
-* ISPEC=12: The CLAHQR vs CLAQR0 crossover point.
-* Default: 75. (Must be at least 11.)
-*
-* ISPEC=13: Recommended deflation window size.
-* This depends on ILO, IHI and NS. NS is the
-* number of simultaneous shifts returned
-* by ILAENV(ISPEC=15). (See ISPEC=15 below.)
-* The default for (IHI-ILO+1).LE.500 is NS.
-* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
-*
-* ISPEC=14: Nibble crossover point. (See IPARMQ for
-* details.) Default: 14% of deflation window
-* size.
-*
-* ISPEC=15: Number of simultaneous shifts in a multishift
-* QR iteration.
-*
-* If IHI-ILO+1 is ...
-*
-* greater than ...but less ... the
-* or equal to ... than default is
-*
-* 1 30 NS = 2(+)
-* 30 60 NS = 4(+)
-* 60 150 NS = 10(+)
-* 150 590 NS = **
-* 590 3000 NS = 64
-* 3000 6000 NS = 128
-* 6000 infinity NS = 256
-*
-* (+) By default some or all matrices of this order
-* are passed to the implicit double shift routine
-* CLAHQR and this parameter is ignored. See
-* ISPEC=12 above and comments in IPARMQ for
-* details.
-*
-* (**) The asterisks (**) indicate an ad-hoc
-* function of N increasing from 10 to 64.
-*
-* ISPEC=16: Select structured matrix multiply.
-* If the number of simultaneous shifts (specified
-* by ISPEC=15) is less than 14, then the default
-* for ISPEC=16 is 0. Otherwise the default for
-* ISPEC=16 is 2.
-*
-* ================================================================
-* Based on contributions by
-* Karen Braman and Ralph Byers, Department of Mathematics,
-* University of Kansas, USA
-*
-* ================================================================
-* References:
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
-* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
-* 929--947, 2002.
-*
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
-* of Matrix Analysis, volume 23, pages 948--973, 2002.
-*
-* ================================================================
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cpb.html b/doc/cpb.html
deleted file mode 100644
index b50a93f..0000000
--- a/doc/cpb.html
+++ /dev/null
@@ -1,1020 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for symmetric or Hermitian positive definite band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for symmetric or Hermitian positive definite band matrix</H1>
- <UL>
- <LI><A HREF="#cpbcon">cpbcon</A> : </LI>
- <LI><A HREF="#cpbequ">cpbequ</A> : </LI>
- <LI><A HREF="#cpbrfs">cpbrfs</A> : </LI>
- <LI><A HREF="#cpbstf">cpbstf</A> : </LI>
- <LI><A HREF="#cpbsv">cpbsv</A> : </LI>
- <LI><A HREF="#cpbsvx">cpbsvx</A> : </LI>
- <LI><A HREF="#cpbtf2">cpbtf2</A> : </LI>
- <LI><A HREF="#cpbtrf">cpbtrf</A> : </LI>
- <LI><A HREF="#cpbtrs">cpbtrs</A> : </LI>
- </UL>
-
- <A NAME="cpbcon"></A>
- <H2>cpbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cpbcon( uplo, kd, ab, anorm)
- or
- NumRu::Lapack.cpbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPBCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite band matrix using
-* the Cholesky factorization A = U**H*U or A = L*L**H computed by
-* CPBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* ANORM (input) REAL
-* The 1-norm (or infinity-norm) of the Hermitian band matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbequ"></A>
- <H2>cpbequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.cpbequ( uplo, kd, ab)
- or
- NumRu::Lapack.cpbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CPBEQU computes row and column scalings intended to equilibrate a
-* Hermitian positive definite band matrix A and reduce its condition
-* number (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular of A is stored;
-* = 'L': Lower triangular of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The upper or lower triangle of the Hermitian band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbrfs"></A>
- <H2>cpbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cpbrfs( uplo, kd, ab, afb, b, x)
- or
- NumRu::Lapack.cpbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite
-* and banded, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The upper or lower triangle of the Hermitian band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* AFB (input) COMPLEX array, dimension (LDAFB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H of the band matrix A as computed by
-* CPBTRF, in the same storage format as A (see AB).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CPBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbstf"></A>
- <H2>cpbstf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.cpbstf( uplo, kd, ab)
- or
- NumRu::Lapack.cpbstf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* CPBSTF computes a split Cholesky factorization of a complex
-* Hermitian positive definite band matrix A.
-*
-* This routine is designed to be used in conjunction with CHBGST.
-*
-* The factorization has the form A = S**H*S where S is a band matrix
-* of the same bandwidth as A and the following structure:
-*
-* S = ( U )
-* ( M L )
-*
-* where U is upper triangular of order m = (n+kd)/2, and L is lower
-* triangular of order n-m.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first kd+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the factor S from the split Cholesky
-* factorization A = S**H*S. See Further Details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the factorization could not be completed,
-* because the updated element a(i,i) was negative; the
-* matrix A is not positive definite.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 7, KD = 2:
-*
-* S = ( s11 s12 s13 )
-* ( s22 s23 s24 )
-* ( s33 s34 )
-* ( s44 )
-* ( s53 s54 s55 )
-* ( s64 s65 s66 )
-* ( s75 s76 s77 )
-*
-* If UPLO = 'U', the array AB holds:
-*
-* on entry: on exit:
-*
-* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'
-* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-*
-* If UPLO = 'L', the array AB holds:
-*
-* on entry: on exit:
-*
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *
-* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *
-*
-* Array elements marked * are not used by the routine; s12' denotes
-* conjg(s12); the diagonal elements of S are real.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbsv"></A>
- <H2>cpbsv</H2>
-
- <PRE>
-USAGE:
- info, ab, b = NumRu::Lapack.cpbsv( uplo, kd, ab, b)
- or
- NumRu::Lapack.cpbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPBSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix, with the same number of superdiagonals or
-* subdiagonals as A. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**H*U or A = L*L**H of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CPBTRF, CPBTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbsvx"></A>
- <H2>cpbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.cpbsvx( fact, uplo, kd, ab, afb, equed, s, b)
- or
- NumRu::Lapack.cpbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
-* compute the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AB and AFB will not
-* be modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right-hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array, except
-* if FACT = 'F' and EQUED = 'Y', then A must contain the
-* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
-* is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* AFB (input or output) COMPLEX array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the band matrix
-* A, in the same storage format as A (see AB). If EQUED = 'Y',
-* then AFB is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13
-* a22 a23 a24
-* a33 a34 a35
-* a44 a45 a46
-* a55 a56
-* (aij=conjg(aji)) a66
-*
-* Band storage of the upper triangle of A:
-*
-* * * a13 a24 a35 a46
-* * a12 a23 a34 a45 a56
-* a11 a22 a33 a44 a55 a66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* a11 a22 a33 a44 a55 a66
-* a21 a32 a43 a54 a65 *
-* a31 a42 a53 a64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbtf2"></A>
- <H2>cpbtf2</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.cpbtf2( uplo, kd, ab)
- or
- NumRu::Lapack.cpbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* CPBTF2 computes the Cholesky factorization of a complex Hermitian
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix, U' is the conjugate transpose
-* of U, and L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of super-diagonals of the matrix A if UPLO = 'U',
-* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U'*U or A = L*L' of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbtrf"></A>
- <H2>cpbtrf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.cpbtrf( uplo, kd, ab)
- or
- NumRu::Lapack.cpbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* CPBTRF computes the Cholesky factorization of a complex Hermitian
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**H*U or A = L*L**H of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* Contributed by
-* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpbtrs"></A>
- <H2>cpbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.cpbtrs( uplo, kd, ab, b)
- or
- NumRu::Lapack.cpbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPBTRS solves a system of linear equations A*X = B with a Hermitian
-* positive definite band matrix A using the Cholesky factorization
-* A = U**H*U or A = L*L**H computed by CPBTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CTBSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cpo.html b/doc/cpo.html
deleted file mode 100644
index 20eea66..0000000
--- a/doc/cpo.html
+++ /dev/null
@@ -1,1555 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for symmetric or Hermitian positive definite matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for symmetric or Hermitian positive definite matrix</H1>
- <UL>
- <LI><A HREF="#cpocon">cpocon</A> : </LI>
- <LI><A HREF="#cpoequ">cpoequ</A> : </LI>
- <LI><A HREF="#cpoequb">cpoequb</A> : </LI>
- <LI><A HREF="#cporfs">cporfs</A> : </LI>
- <LI><A HREF="#cporfsx">cporfsx</A> : </LI>
- <LI><A HREF="#cposv">cposv</A> : </LI>
- <LI><A HREF="#cposvx">cposvx</A> : </LI>
- <LI><A HREF="#cposvxx">cposvxx</A> : </LI>
- <LI><A HREF="#cpotf2">cpotf2</A> : </LI>
- <LI><A HREF="#cpotrf">cpotrf</A> : </LI>
- <LI><A HREF="#cpotri">cpotri</A> : </LI>
- <LI><A HREF="#cpotrs">cpotrs</A> : </LI>
- </UL>
-
- <A NAME="cpocon"></A>
- <H2>cpocon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cpocon( uplo, a, anorm)
- or
- NumRu::Lapack.cpocon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPOCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite matrix using the
-* Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by CPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) REAL
-* The 1-norm (or infinity-norm) of the Hermitian matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpoequ"></A>
- <H2>cpoequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.cpoequ( a)
- or
- NumRu::Lapack.cpoequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CPOEQU computes row and column scalings intended to equilibrate a
-* Hermitian positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The N-by-N Hermitian positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpoequb"></A>
- <H2>cpoequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.cpoequb( a)
- or
- NumRu::Lapack.cpoequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CPOEQUB computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The N-by-N symmetric positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cporfs"></A>
- <H2>cporfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cporfs( uplo, a, af, b, x)
- or
- NumRu::Lapack.cporfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPORFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite,
-* and provides error bounds and backward error estimates for the
-* solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by CPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CPOTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cporfsx"></A>
- <H2>cporfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cporfsx( uplo, equed, a, af, s, b, x, params)
- or
- NumRu::Lapack.cporfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPORFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive
-* definite, and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by SPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* S (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cposv"></A>
- <H2>cposv</H2>
-
- <PRE>
-USAGE:
- info, a, b = NumRu::Lapack.cposv( uplo, a, b)
- or
- NumRu::Lapack.cposv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPOSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**H* U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CPOTRF, CPOTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cposvx"></A>
- <H2>cposvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.cposvx( fact, uplo, a, af, equed, s, b)
- or
- NumRu::Lapack.cposvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
-* compute the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**H* U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. A and AF will not
-* be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A, except if FACT = 'F' and
-* EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored form
-* of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS righthand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cposvxx"></A>
- <H2>cposvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.cposvxx( fact, uplo, a, af, equed, s, b, params)
- or
- NumRu::Lapack.cposvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T
-* to compute the solution to a complex system of linear equations
-* A * X = B, where A is an N-by-N symmetric positive definite matrix
-* and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. CPOSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* CPOSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* CPOSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what CPOSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A (see argument RCOND). If the reciprocal of the condition number
-* is less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A and AF are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =
-* 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper
-* triangular part of A contains the upper triangular part of the
-* matrix A, and the strictly lower triangular part of A is not
-* referenced. If UPLO = 'L', the leading N-by-N lower triangular
-* part of A contains the lower triangular part of the matrix A, and
-* the strictly upper triangular part of A is not referenced. A is
-* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =
-* 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored
-* form of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpotf2"></A>
- <H2>cpotf2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.cpotf2( uplo, a)
- or
- NumRu::Lapack.cpotf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* CPOTF2 computes the Cholesky factorization of a complex Hermitian
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L'.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpotrf"></A>
- <H2>cpotrf</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.cpotrf( uplo, a)
- or
- NumRu::Lapack.cpotrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* CPOTRF computes the Cholesky factorization of a complex Hermitian
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the block version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpotri"></A>
- <H2>cpotri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.cpotri( uplo, a)
- or
- NumRu::Lapack.cpotri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* CPOTRI computes the inverse of a complex Hermitian positive definite
-* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
-* computed by CPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, as computed by
-* CPOTRF.
-* On exit, the upper or lower triangle of the (Hermitian)
-* inverse of A, overwriting the input factor U or L.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CLAUUM, CTRTRI, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpotrs"></A>
- <H2>cpotrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.cpotrs( uplo, a, b)
- or
- NumRu::Lapack.cpotrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPOTRS solves a system of linear equations A*X = B with a Hermitian
-* positive definite matrix A using the Cholesky factorization
-* A = U**H*U or A = L*L**H computed by CPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by CPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cpp.html b/doc/cpp.html
deleted file mode 100644
index 2874116..0000000
--- a/doc/cpp.html
+++ /dev/null
@@ -1,793 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for symmetric or Hermitian positive definite, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for symmetric or Hermitian positive definite, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#cppcon">cppcon</A> : </LI>
- <LI><A HREF="#cppequ">cppequ</A> : </LI>
- <LI><A HREF="#cpprfs">cpprfs</A> : </LI>
- <LI><A HREF="#cppsv">cppsv</A> : </LI>
- <LI><A HREF="#cppsvx">cppsvx</A> : </LI>
- <LI><A HREF="#cpptrf">cpptrf</A> : </LI>
- <LI><A HREF="#cpptri">cpptri</A> : </LI>
- <LI><A HREF="#cpptrs">cpptrs</A> : </LI>
- </UL>
-
- <A NAME="cppcon"></A>
- <H2>cppcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cppcon( uplo, ap, anorm)
- or
- NumRu::Lapack.cppcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite packed matrix using
-* the Cholesky factorization A = U**H*U or A = L*L**H computed by
-* CPPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* ANORM (input) REAL
-* The 1-norm (or infinity-norm) of the Hermitian matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cppequ"></A>
- <H2>cppequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.cppequ( uplo, ap)
- or
- NumRu::Lapack.cppequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* CPPEQU computes row and column scalings intended to equilibrate a
-* Hermitian positive definite matrix A in packed storage and reduce
-* its condition number (with respect to the two-norm). S contains the
-* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
-* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
-* This choice of S puts the condition number of B within a factor N of
-* the smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpprfs"></A>
- <H2>cpprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cpprfs( uplo, ap, afp, b, x)
- or
- NumRu::Lapack.cpprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF,
-* packed columnwise in a linear array in the same format as A
-* (see AP).
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CPPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cppsv"></A>
- <H2>cppsv</H2>
-
- <PRE>
-USAGE:
- info, ap, b = NumRu::Lapack.cppsv( uplo, n, ap, b)
- or
- NumRu::Lapack.cppsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPPSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**H* U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, in the same storage
-* format as A.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CPPTRF, CPPTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cppsvx"></A>
- <H2>cppsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.cppsvx( fact, uplo, ap, afp, equed, s, b)
- or
- NumRu::Lapack.cppsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
-* compute the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U'* U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix, L is a lower triangular
-* matrix, and ' indicates conjugate transpose.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFP contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AP and AFP will not
-* be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array, except if FACT = 'F'
-* and EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). The j-th column of A is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, in the same storage
-* format as A. If EQUED .ne. 'N', then AFP is the factored
-* form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the original
-* matrix A.
-*
-* If FACT = 'E', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the equilibrated
-* matrix A (see the description of AP for the form of the
-* equilibrated matrix).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpptrf"></A>
- <H2>cpptrf</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.cpptrf( uplo, n, ap)
- or
- NumRu::Lapack.cpptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPTRF( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* CPPTRF computes the Cholesky factorization of a complex Hermitian
-* positive definite matrix A stored in packed format.
-*
-* The factorization has the form
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**H*U or A = L*L**H, in the same
-* storage format as A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpptri"></A>
- <H2>cpptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.cpptri( uplo, n, ap)
- or
- NumRu::Lapack.cpptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPTRI( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* CPPTRI computes the inverse of a complex Hermitian positive definite
-* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
-* computed by CPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor is stored in AP;
-* = 'L': Lower triangular factor is stored in AP.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, packed columnwise as
-* a linear array. The j-th column of U or L is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* On exit, the upper or lower triangle of the (Hermitian)
-* inverse of A, overwriting the input factor U or L.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpptrs"></A>
- <H2>cpptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.cpptrs( uplo, n, ap, b)
- or
- NumRu::Lapack.cpptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPPTRS solves a system of linear equations A*X = B with a Hermitian
-* positive definite matrix A in packed storage using the Cholesky
-* factorization A = U**H*U or A = L*L**H computed by CPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CTPSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cpt.html b/doc/cpt.html
deleted file mode 100644
index cc5cfaa..0000000
--- a/doc/cpt.html
+++ /dev/null
@@ -1,729 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for symmetric or Hermitian positive definite tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for symmetric or Hermitian positive definite tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#cptcon">cptcon</A> : </LI>
- <LI><A HREF="#cpteqr">cpteqr</A> : </LI>
- <LI><A HREF="#cptrfs">cptrfs</A> : </LI>
- <LI><A HREF="#cptsv">cptsv</A> : </LI>
- <LI><A HREF="#cptsvx">cptsvx</A> : </LI>
- <LI><A HREF="#cpttrf">cpttrf</A> : </LI>
- <LI><A HREF="#cpttrs">cpttrs</A> : </LI>
- <LI><A HREF="#cptts2">cptts2</A> : </LI>
- </UL>
-
- <A NAME="cptcon"></A>
- <H2>cptcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cptcon( d, e, anorm)
- or
- NumRu::Lapack.cptcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPTCON computes the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite tridiagonal matrix
-* using the factorization A = L*D*L**H or A = U**H*D*U computed by
-* CPTTRF.
-*
-* Norm(inv(A)) is computed by a direct method, and the reciprocal of
-* the condition number is computed as
-* RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization of A, as computed by CPTTRF.
-*
-* E (input) COMPLEX array, dimension (N-1)
-* The (n-1) off-diagonal elements of the unit bidiagonal factor
-* U or L from the factorization of A, as computed by CPTTRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
-* 1-norm of inv(A) computed in this routine.
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The method used is described in Nicholas J. Higham, "Efficient
-* Algorithms for Computing the Condition Number of a Tridiagonal
-* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpteqr"></A>
- <H2>cpteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.cpteqr( compz, d, e, z)
- or
- NumRu::Lapack.cpteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CPTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric positive definite tridiagonal matrix by first factoring the
-* matrix using SPTTRF and then calling CBDSQR to compute the singular
-* values of the bidiagonal factor.
-*
-* This routine computes the eigenvalues of the positive definite
-* tridiagonal matrix to high relative accuracy. This means that if the
-* eigenvalues range over many orders of magnitude in size, then the
-* small eigenvalues and corresponding eigenvectors will be computed
-* more accurately than, for example, with the standard QR method.
-*
-* The eigenvectors of a full or band positive definite Hermitian matrix
-* can also be found if CHETRD, CHPTRD, or CHBTRD has been used to
-* reduce this matrix to tridiagonal form. (The reduction to
-* tridiagonal form, however, may preclude the possibility of obtaining
-* high relative accuracy in the small eigenvalues of the original
-* matrix, if these eigenvalues range over many orders of magnitude.)
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvectors of original Hermitian
-* matrix also. Array Z contains the unitary matrix
-* used to reduce the original matrix to tridiagonal
-* form.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix.
-* On normal exit, D contains the eigenvalues, in descending
-* order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the unitary matrix used in the
-* reduction to tridiagonal form.
-* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
-* original Hermitian matrix;
-* if COMPZ = 'I', the orthonormal eigenvectors of the
-* tridiagonal matrix.
-* If INFO > 0 on exit, Z contains the eigenvectors associated
-* with only the stored eigenvalues.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* COMPZ = 'V' or 'I', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is:
-* <= N the Cholesky factorization of the matrix could
-* not be performed because the i-th principal minor
-* was not positive definite.
-* > N the SVD algorithm failed to converge;
-* if INFO = N+i, i off-diagonal elements of the
-* bidiagonal factor did not converge to zero.
-*
-
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cptrfs"></A>
- <H2>cptrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.cptrfs( uplo, d, e, df, ef, b, x)
- or
- NumRu::Lapack.cptrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite
-* and tridiagonal, and provides error bounds and backward error
-* estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the superdiagonal or the subdiagonal of the
-* tridiagonal matrix A is stored and the form of the
-* factorization:
-* = 'U': E is the superdiagonal of A, and A = U**H*D*U;
-* = 'L': E is the subdiagonal of A, and A = L*D*L**H.
-* (The two forms are equivalent if A is real.)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n real diagonal elements of the tridiagonal matrix A.
-*
-* E (input) COMPLEX array, dimension (N-1)
-* The (n-1) off-diagonal elements of the tridiagonal matrix A
-* (see UPLO).
-*
-* DF (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from
-* the factorization computed by CPTTRF.
-*
-* EF (input) COMPLEX array, dimension (N-1)
-* The (n-1) off-diagonal elements of the unit bidiagonal
-* factor U or L from the factorization computed by CPTTRF
-* (see UPLO).
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CPTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cptsv"></A>
- <H2>cptsv</H2>
-
- <PRE>
-USAGE:
- info, d, e, b = NumRu::Lapack.cptsv( d, e, b)
- or
- NumRu::Lapack.cptsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPTSV computes the solution to a complex system of linear equations
-* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal
-* matrix, and X and B are N-by-NRHS matrices.
-*
-* A is factored as A = L*D*L**H, and the factored form of A is then
-* used to solve the system of equations.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the factorization A = L*D*L**H.
-*
-* E (input/output) COMPLEX array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L**H factorization of
-* A. E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U**H*D*U factorization of A.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the solution has not been
-* computed. The factorization has not been completed
-* unless i = N.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL CPTTRF, CPTTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cptsvx"></A>
- <H2>cptsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.cptsvx( fact, d, e, df, ef, b)
- or
- NumRu::Lapack.cptsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CPTSVX uses the factorization A = L*D*L**H to compute the solution
-* to a complex system of linear equations A*X = B, where A is an
-* N-by-N Hermitian positive definite tridiagonal matrix and X and B
-* are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L
-* is a unit lower bidiagonal matrix and D is diagonal. The
-* factorization can also be regarded as having the form
-* A = U**H*D*U.
-*
-* 2. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix
-* A is supplied on entry.
-* = 'F': On entry, DF and EF contain the factored form of A.
-* D, E, DF, and EF will not be modified.
-* = 'N': The matrix A will be copied to DF and EF and
-* factored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix A.
-*
-* E (input) COMPLEX array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix A.
-*
-* DF (input or output) REAL array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**H factorization of A.
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**H factorization of A.
-*
-* EF (input or output) COMPLEX array, dimension (N-1)
-* If FACT = 'F', then EF is an input argument and on entry
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**H factorization of A.
-* If FACT = 'N', then EF is an output argument and on exit
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**H factorization of A.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The reciprocal condition number of the matrix A. If RCOND
-* is less than the machine precision (in particular, if
-* RCOND = 0), the matrix is singular to working precision.
-* This condition is indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in any
-* element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpttrf"></A>
- <H2>cpttrf</H2>
-
- <PRE>
-USAGE:
- info, d, e = NumRu::Lapack.cpttrf( d, e)
- or
- NumRu::Lapack.cpttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTTRF( N, D, E, INFO )
-
-* Purpose
-* =======
-*
-* CPTTRF computes the L*D*L' factorization of a complex Hermitian
-* positive definite tridiagonal matrix A. The factorization may also
-* be regarded as having the form A = U'*D*U.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the L*D*L' factorization of A.
-*
-* E (input/output) COMPLEX array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L' factorization of A.
-* E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U'*D*U factorization of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite; if k < N, the factorization could not
-* be completed, while if k = N, the factorization was
-* completed, but D(N) <= 0.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cpttrs"></A>
- <H2>cpttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.cpttrs( uplo, d, e, b)
- or
- NumRu::Lapack.cpttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CPTTRS solves a tridiagonal system of the form
-* A * X = B
-* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.
-* D is a diagonal matrix specified in the vector D, U (or L) is a unit
-* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
-* the vector E, and X and B are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies the form of the factorization and whether the
-* vector E is the superdiagonal of the upper bidiagonal factor
-* U or the subdiagonal of the lower bidiagonal factor L.
-* = 'U': A = U'*D*U, E is the superdiagonal of U
-* = 'L': A = L*D*L', E is the subdiagonal of L
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization A = U'*D*U or A = L*D*L'.
-*
-* E (input) COMPLEX array, dimension (N-1)
-* If UPLO = 'U', the (n-1) superdiagonal elements of the unit
-* bidiagonal factor U from the factorization A = U'*D*U.
-* If UPLO = 'L', the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the factorization A = L*D*L'.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER IUPLO, J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL CPTTS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cptts2"></A>
- <H2>cptts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.cptts2( iuplo, d, e, b)
- or
- NumRu::Lapack.cptts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
-
-* Purpose
-* =======
-*
-* CPTTS2 solves a tridiagonal system of the form
-* A * X = B
-* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.
-* D is a diagonal matrix specified in the vector D, U (or L) is a unit
-* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
-* the vector E, and X and B are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* IUPLO (input) INTEGER
-* Specifies the form of the factorization and whether the
-* vector E is the superdiagonal of the upper bidiagonal factor
-* U or the subdiagonal of the lower bidiagonal factor L.
-* = 1: A = U'*D*U, E is the superdiagonal of U
-* = 0: A = L*D*L', E is the subdiagonal of L
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization A = U'*D*U or A = L*D*L'.
-*
-* E (input) COMPLEX array, dimension (N-1)
-* If IUPLO = 1, the (n-1) superdiagonal elements of the unit
-* bidiagonal factor U from the factorization A = U'*D*U.
-* If IUPLO = 0, the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the factorization A = L*D*L'.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, J
-* ..
-* .. External Subroutines ..
- EXTERNAL CSSCAL
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC CONJG
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/csp.html b/doc/csp.html
deleted file mode 100644
index 2aecdaf..0000000
--- a/doc/csp.html
+++ /dev/null
@@ -1,931 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for symmetric, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for symmetric, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#cspcon">cspcon</A> : </LI>
- <LI><A HREF="#cspmv">cspmv</A> : </LI>
- <LI><A HREF="#cspr">cspr</A> : </LI>
- <LI><A HREF="#csprfs">csprfs</A> : </LI>
- <LI><A HREF="#cspsv">cspsv</A> : </LI>
- <LI><A HREF="#cspsvx">cspsvx</A> : </LI>
- <LI><A HREF="#csptrf">csptrf</A> : </LI>
- <LI><A HREF="#csptri">csptri</A> : </LI>
- <LI><A HREF="#csptrs">csptrs</A> : </LI>
- </UL>
-
- <A NAME="cspcon"></A>
- <H2>cspcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.cspcon( uplo, ap, ipiv, anorm)
- or
- NumRu::Lapack.cspcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex symmetric packed matrix A using the
-* factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSPTRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cspmv"></A>
- <H2>cspmv</H2>
-
- <PRE>
-USAGE:
- y = NumRu::Lapack.cspmv( uplo, n, alpha, ap, x, incx, beta, y, incy)
- or
- NumRu::Lapack.cspmv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
-
-* Purpose
-* =======
-*
-* CSPMV performs the matrix-vector operation
-*
-* y := alpha*A*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are n element vectors and
-* A is an n by n symmetric matrix, supplied in packed form.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the matrix A is supplied in the packed
-* array AP as follows:
-*
-* UPLO = 'U' or 'u' The upper triangular part of A is
-* supplied in AP.
-*
-* UPLO = 'L' or 'l' The lower triangular part of A is
-* supplied in AP.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* AP (input) COMPLEX array, dimension at least
-* ( ( N*( N + 1 ) )/2 ).
-* Before entry, with UPLO = 'U' or 'u', the array AP must
-* contain the upper triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
-* and a( 2, 2 ) respectively, and so on.
-* Before entry, with UPLO = 'L' or 'l', the array AP must
-* contain the lower triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
-* and a( 3, 1 ) respectively, and so on.
-* Unchanged on exit.
-*
-* X (input) COMPLEX array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* BETA (input) COMPLEX
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y (input/output) COMPLEX array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y. On exit, Y is overwritten by the updated
-* vector y.
-*
-* INCY (input) INTEGER
-* On entry, INCY specifies the increment for the elements of
-* Y. INCY must not be zero.
-* Unchanged on exit.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cspr"></A>
- <H2>cspr</H2>
-
- <PRE>
-USAGE:
- ap = NumRu::Lapack.cspr( uplo, n, alpha, x, incx, ap)
- or
- NumRu::Lapack.cspr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP )
-
-* Purpose
-* =======
-*
-* CSPR performs the symmetric rank 1 operation
-*
-* A := alpha*x*conjg( x' ) + A,
-*
-* where alpha is a complex scalar, x is an n element vector and A is an
-* n by n symmetric matrix, supplied in packed form.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the matrix A is supplied in the packed
-* array AP as follows:
-*
-* UPLO = 'U' or 'u' The upper triangular part of A is
-* supplied in AP.
-*
-* UPLO = 'L' or 'l' The lower triangular part of A is
-* supplied in AP.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X (input) COMPLEX array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* AP (input/output) COMPLEX array, dimension at least
-* ( ( N*( N + 1 ) )/2 ).
-* Before entry, with UPLO = 'U' or 'u', the array AP must
-* contain the upper triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
-* and a( 2, 2 ) respectively, and so on. On exit, the array
-* AP is overwritten by the upper triangular part of the
-* updated matrix.
-* Before entry, with UPLO = 'L' or 'l', the array AP must
-* contain the lower triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
-* and a( 3, 1 ) respectively, and so on. On exit, the array
-* AP is overwritten by the lower triangular part of the
-* updated matrix.
-* Note that the imaginary parts of the diagonal elements need
-* not be set, they are assumed to be zero, and on exit they
-* are set to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csprfs"></A>
- <H2>csprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.csprfs( uplo, ap, afp, ipiv, b, x)
- or
- NumRu::Lapack.csprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The factored form of the matrix A. AFP contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by CSPTRF, stored as a packed
-* triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSPTRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CSPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cspsv"></A>
- <H2>cspsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap, b = NumRu::Lapack.cspsv( uplo, ap, b)
- or
- NumRu::Lapack.cspsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CSPSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix stored in packed format and X
-* and B are N-by-NRHS matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, D is symmetric and block diagonal with 1-by-1
-* and 2-by-2 diagonal blocks. The factored form of A is then used to
-* solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by CSPTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be
-* computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CSPTRF, CSPTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cspsvx"></A>
- <H2>cspsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.cspsvx( fact, uplo, ap, afp, ipiv, b)
- or
- NumRu::Lapack.cspsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
-* A = L*D*L**T to compute the solution to a complex system of linear
-* equations A * X = B, where A is an N-by-N symmetric matrix stored
-* in packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AFP and IPIV contain the factored form
-* of A. AP, AFP and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by CSPTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by CSPTRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csptrf"></A>
- <H2>csptrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap = NumRu::Lapack.csptrf( uplo, ap)
- or
- NumRu::Lapack.csptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CSPTRF computes the factorization of a complex symmetric matrix A
-* stored in packed format using the Bunch-Kaufman diagonal pivoting
-* method:
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L, stored as a packed triangular
-* matrix overwriting A (see below for further details).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csptri"></A>
- <H2>csptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.csptri( uplo, ap, ipiv)
- or
- NumRu::Lapack.csptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSPTRI computes the inverse of a complex symmetric indefinite matrix
-* A in packed storage using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by CSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by CSPTRF,
-* stored as a packed triangular matrix.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix, stored as a packed triangular matrix. The j-th column
-* of inv(A) is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
-* if UPLO = 'L',
-* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSPTRF.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csptrs"></A>
- <H2>csptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.csptrs( uplo, ap, ipiv, b)
- or
- NumRu::Lapack.csptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CSPTRS solves a system of linear equations A*X = B with a complex
-* symmetric matrix A stored in packed format using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by CSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSPTRF.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cst.html b/doc/cst.html
deleted file mode 100644
index 2a6f0f2..0000000
--- a/doc/cst.html
+++ /dev/null
@@ -1,756 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for (real) symmetric tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for (real) symmetric tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#cstedc">cstedc</A> : </LI>
- <LI><A HREF="#cstegr">cstegr</A> : </LI>
- <LI><A HREF="#cstein">cstein</A> : </LI>
- <LI><A HREF="#cstemr">cstemr</A> : </LI>
- <LI><A HREF="#csteqr">csteqr</A> : </LI>
- </UL>
-
- <A NAME="cstedc"></A>
- <H2>cstedc</H2>
-
- <PRE>
-USAGE:
- work, rwork, iwork, info, d, e, z = NumRu::Lapack.cstedc( compz, d, e, z, lwork, lrwork, liwork)
- or
- NumRu::Lapack.cstedc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSTEDC computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the divide and conquer method.
-* The eigenvectors of a full or band complex Hermitian matrix can also
-* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this
-* matrix to tridiagonal form.
-*
-* This code makes very mild assumptions about floating point
-* arithmetic. It will work on machines with a guard digit in
-* add/subtract, or on those binary machines without guard digits
-* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
-* It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none. See SLAED3 for details.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-* = 'V': Compute eigenvectors of original Hermitian matrix
-* also. On entry, Z contains the unitary matrix used
-* to reduce the original matrix to tridiagonal form.
-*
-* N (input) INTEGER
-* The dimension of the symmetric tridiagonal matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the subdiagonal elements of the tridiagonal matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ,N)
-* On entry, if COMPZ = 'V', then Z contains the unitary
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original Hermitian matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
-* If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
-* Note that for COMPZ = 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LWORK need
-* only be 1.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
-* If COMPZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 3*N + 2*N*lg N + 3*N**2 ,
-* where lg( N ) = smallest integer k such
-* that 2**k >= N.
-* If COMPZ = 'I' and N > 1, LRWORK must be at least
-* 1 + 4*N + 2*N**2 .
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LRWORK
-* need only be max(1,2*(N-1)).
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If COMPZ = 'V' or N > 1, LIWORK must be at least
-* 6 + 6*N + 5*N*lg N.
-* If COMPZ = 'I' or N > 1, LIWORK must be at least
-* 3 + 5*N .
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LIWORK
-* need only be 1.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The algorithm failed to compute an eigenvalue while
-* working on the submatrix lying in rows and columns
-* INFO/(N+1) through mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cstegr"></A>
- <H2>cstegr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.cstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.cstegr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSTEGR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* CSTEGR is a compatability wrapper around the improved CSTEMR routine.
-* See SSTEMR for further details.
-*
-* One important change is that the ABSTOL parameter no longer provides any
-* benefit and hence is no longer used.
-*
-* Note : CSTEGR and CSTEMR work only on machines which follow
-* IEEE-754 floating-point standard in their handling of infinities and
-* NaNs. Normal execution may create these exceptiona values and hence
-* may abort due to a floating point exception in environments which
-* do not conform to the IEEE-754 standard.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) REAL array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* Unused. Was the absolute error tolerance for the
-* eigenvalues/eigenvectors in previous versions.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-* Supplying N columns is always safe.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* WORK (workspace/output) REAL array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in SLARRE,
-* if INFO = 2X, internal error in CLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by SLARRE or
-* CLARRV, respectively.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL TRYRAC
-* ..
-* .. External Subroutines ..
- EXTERNAL CSTEMR
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cstein"></A>
- <H2>cstein</H2>
-
- <PRE>
-USAGE:
- z, ifail, info = NumRu::Lapack.cstein( d, e, w, iblock, isplit)
- or
- NumRu::Lapack.cstein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* CSTEIN computes the eigenvectors of a real symmetric tridiagonal
-* matrix T corresponding to specified eigenvalues, using inverse
-* iteration.
-*
-* The maximum number of iterations allowed for each eigenvector is
-* specified by an internal parameter MAXITS (currently set to 5).
-*
-* Although the eigenvectors are real, they are stored in a complex
-* array, which may be passed to CUNMTR or CUPMTR for back
-* transformation to the eigenvectors of a complex Hermitian matrix
-* which was reduced to tridiagonal form.
-*
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix T.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix
-* T, stored in elements 1 to N-1.
-*
-* M (input) INTEGER
-* The number of eigenvectors to be found. 0 <= M <= N.
-*
-* W (input) REAL array, dimension (N)
-* The first M elements of W contain the eigenvalues for
-* which eigenvectors are to be computed. The eigenvalues
-* should be grouped by split-off block and ordered from
-* smallest to largest within the block. ( The output array
-* W from SSTEBZ with ORDER = 'B' is expected here. )
-*
-* IBLOCK (input) INTEGER array, dimension (N)
-* The submatrix indices associated with the corresponding
-* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
-* the first submatrix from the top, =2 if W(i) belongs to
-* the second submatrix, etc. ( The output array IBLOCK
-* from SSTEBZ is expected here. )
-*
-* ISPLIT (input) INTEGER array, dimension (N)
-* The splitting points, at which T breaks up into submatrices.
-* The first submatrix consists of rows/columns 1 to
-* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
-* through ISPLIT( 2 ), etc.
-* ( The output array ISPLIT from SSTEBZ is expected here. )
-*
-* Z (output) COMPLEX array, dimension (LDZ, M)
-* The computed eigenvectors. The eigenvector associated
-* with the eigenvalue W(i) is stored in the i-th column of
-* Z. Any vector which fails to converge is set to its current
-* iterate after MAXITS iterations.
-* The imaginary parts of the eigenvectors are set to zero.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (5*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* IFAIL (output) INTEGER array, dimension (M)
-* On normal exit, all elements of IFAIL are zero.
-* If one or more eigenvectors fail to converge after
-* MAXITS iterations, then their indices are stored in
-* array IFAIL.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge
-* in MAXITS iterations. Their indices are stored in
-* array IFAIL.
-*
-* Internal Parameters
-* ===================
-*
-* MAXITS INTEGER, default = 5
-* The maximum number of iterations performed.
-*
-* EXTRA INTEGER, default = 2
-* The number of iterations performed after norm growth
-* criterion is satisfied, should be at least 1.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cstemr"></A>
- <H2>cstemr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.cstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)
- or
- NumRu::Lapack.cstemr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSTEMR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* Depending on the number of desired eigenvalues, these are computed either
-* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
-* computed by the use of various suitable L D L^T factorizations near clusters
-* of close eigenvalues (referred to as RRRs, Relatively Robust
-* Representations). An informal sketch of the algorithm follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* For more details, see:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-* Further Details
-* 1.CSTEMR works only on machines which follow IEEE-754
-* floating-point standard in their handling of infinities and NaNs.
-* This permits the use of efficient inner loops avoiding a check for
-* zero divisors.
-*
-* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to
-* real symmetric tridiagonal form.
-*
-* (Any complex Hermitean tridiagonal matrix has real values on its diagonal
-* and potentially complex numbers on its off-diagonals. By applying a
-* similarity transform with an appropriate diagonal matrix
-* diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
-* matrix can be transformed into a real symmetric matrix and complex
-* arithmetic can be entirely avoided.)
-*
-* While the eigenvectors of the real symmetric tridiagonal matrix are real,
-* the eigenvectors of original complex Hermitean matrix have complex entries
-* in general.
-* Since LAPACK drivers overwrite the matrix data with the eigenvectors,
-* CSTEMR accepts complex workspace to facilitate interoperability
-* with CUNMTR or CUPMTR.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) REAL array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and can be computed with a workspace
-* query by setting NZC = -1, see below.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* NZC (input) INTEGER
-* The number of eigenvectors to be held in the array Z.
-* If RANGE = 'A', then NZC >= max(1,N).
-* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
-* If RANGE = 'I', then NZC >= IU-IL+1.
-* If NZC = -1, then a workspace query is assumed; the
-* routine calculates the number of columns of the array Z that
-* are needed to hold the eigenvectors.
-* This value is returned as the first entry of the Z array, and
-* no error message related to NZC is issued by XERBLA.
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* TRYRAC (input/output) LOGICAL
-* If TRYRAC.EQ..TRUE., indicates that the code should check whether
-* the tridiagonal matrix defines its eigenvalues to high relative
-* accuracy. If so, the code uses relative-accuracy preserving
-* algorithms that might be (a bit) slower depending on the matrix.
-* If the matrix does not define its eigenvalues to high relative
-* accuracy, the code can uses possibly faster algorithms.
-* If TRYRAC.EQ..FALSE., the code is not required to guarantee
-* relatively accurate eigenvalues and can use the fastest possible
-* techniques.
-* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
-* does not define its eigenvalues to high relative accuracy.
-*
-* WORK (workspace/output) REAL array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in SLARRE,
-* if INFO = 2X, internal error in CLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by SLARRE or
-* CLARRV, respectively.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Beresford Parlett, University of California, Berkeley, USA
-* Jim Demmel, University of California, Berkeley, USA
-* Inderjit Dhillon, University of Texas, Austin, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, University of California, Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csteqr"></A>
- <H2>csteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.csteqr( compz, d, e, z)
- or
- NumRu::Lapack.csteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the implicit QL or QR method.
-* The eigenvectors of a full or band complex Hermitian matrix can also
-* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this
-* matrix to tridiagonal form.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvalues and eigenvectors of the original
-* Hermitian matrix. On entry, Z must contain the
-* unitary matrix used to reduce the original matrix
-* to tridiagonal form.
-* = 'I': Compute eigenvalues and eigenvectors of the
-* tridiagonal matrix. Z is initialized to the identity
-* matrix.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', then Z contains the unitary
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original Hermitian matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (max(1,2*N-2))
-* If COMPZ = 'N', then WORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm has failed to find all the eigenvalues in
-* a total of 30*N iterations; if INFO = i, then i
-* elements of E have not converged to zero; on exit, D
-* and E contain the elements of a symmetric tridiagonal
-* matrix which is unitarily similar to the original
-* matrix.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/csy.html b/doc/csy.html
deleted file mode 100644
index 5926b01..0000000
--- a/doc/csy.html
+++ /dev/null
@@ -1,2247 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for symmetric matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for symmetric matrix</H1>
- <UL>
- <LI><A HREF="#csycon">csycon</A> : </LI>
- <LI><A HREF="#csyconv">csyconv</A> : </LI>
- <LI><A HREF="#csyequb">csyequb</A> : </LI>
- <LI><A HREF="#csymv">csymv</A> : </LI>
- <LI><A HREF="#csyr">csyr</A> : </LI>
- <LI><A HREF="#csyrfs">csyrfs</A> : </LI>
- <LI><A HREF="#csyrfsx">csyrfsx</A> : </LI>
- <LI><A HREF="#csysv">csysv</A> : </LI>
- <LI><A HREF="#csysvx">csysvx</A> : </LI>
- <LI><A HREF="#csysvxx">csysvxx</A> : </LI>
- <LI><A HREF="#csyswapr">csyswapr</A> : </LI>
- <LI><A HREF="#csytf2">csytf2</A> : </LI>
- <LI><A HREF="#csytrf">csytrf</A> : </LI>
- <LI><A HREF="#csytri">csytri</A> : </LI>
- <LI><A HREF="#csytri2">csytri2</A> : </LI>
- <LI><A HREF="#csytri2x">csytri2x</A> : </LI>
- <LI><A HREF="#csytrs">csytrs</A> : </LI>
- <LI><A HREF="#csytrs2">csytrs2</A> : </LI>
- </UL>
-
- <A NAME="csycon"></A>
- <H2>csycon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.csycon( uplo, a, ipiv, anorm)
- or
- NumRu::Lapack.csycon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex symmetric matrix A using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by CSYTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSYTRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csyconv"></A>
- <H2>csyconv</H2>
-
- <PRE>
-USAGE:
- info = NumRu::Lapack.csyconv( uplo, way, a, ipiv)
- or
- NumRu::Lapack.csyconv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYCONV convert A given by TRF into L and D and vice-versa.
-* Get Non-diag elements of D (returned in workspace) and
-* apply or reverse permutation done in TRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* WAY (input) CHARACTER*1
-* = 'C': Convert
-* = 'R': Revert
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSYTRF.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1.
-* LWORK = N
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csyequb"></A>
- <H2>csyequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.csyequb( uplo, a)
- or
- NumRu::Lapack.csyequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYEQUB computes row and column scalings intended to equilibrate a
-* symmetric matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The N-by-N symmetric matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* WORK (workspace) COMPLEX array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* Further Details
-* ======= =======
-*
-* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization",
-* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.
-* DOI 10.1023/B:NUMA.0000016606.32820.69
-* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csymv"></A>
- <H2>csymv</H2>
-
- <PRE>
-USAGE:
- y = NumRu::Lapack.csymv( uplo, alpha, a, x, incx, beta, y, incy)
- or
- NumRu::Lapack.csymv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
-
-* Purpose
-* =======
-*
-* CSYMV performs the matrix-vector operation
-*
-* y := alpha*A*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are n element vectors and
-* A is an n by n symmetric matrix.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the array A is to be referenced as
-* follows:
-*
-* UPLO = 'U' or 'u' Only the upper triangular part of A
-* is to be referenced.
-*
-* UPLO = 'L' or 'l' Only the lower triangular part of A
-* is to be referenced.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A (input) COMPLEX array, dimension ( LDA, N )
-* Before entry, with UPLO = 'U' or 'u', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular part of the symmetric matrix and the strictly
-* lower triangular part of A is not referenced.
-* Before entry, with UPLO = 'L' or 'l', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular part of the symmetric matrix and the strictly
-* upper triangular part of A is not referenced.
-* Unchanged on exit.
-*
-* LDA (input) INTEGER
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least
-* max( 1, N ).
-* Unchanged on exit.
-*
-* X (input) COMPLEX array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* BETA (input) COMPLEX
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y (input/output) COMPLEX array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y. On exit, Y is overwritten by the updated
-* vector y.
-*
-* INCY (input) INTEGER
-* On entry, INCY specifies the increment for the elements of
-* Y. INCY must not be zero.
-* Unchanged on exit.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csyr"></A>
- <H2>csyr</H2>
-
- <PRE>
-USAGE:
- a = NumRu::Lapack.csyr( uplo, alpha, x, incx, a)
- or
- NumRu::Lapack.csyr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
-
-* Purpose
-* =======
-*
-* CSYR performs the symmetric rank 1 operation
-*
-* A := alpha*x*( x' ) + A,
-*
-* where alpha is a complex scalar, x is an n element vector and A is an
-* n by n symmetric matrix.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the array A is to be referenced as
-* follows:
-*
-* UPLO = 'U' or 'u' Only the upper triangular part of A
-* is to be referenced.
-*
-* UPLO = 'L' or 'l' Only the lower triangular part of A
-* is to be referenced.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X (input) COMPLEX array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* A (input/output) COMPLEX array, dimension ( LDA, N )
-* Before entry, with UPLO = 'U' or 'u', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular part of the symmetric matrix and the strictly
-* lower triangular part of A is not referenced. On exit, the
-* upper triangular part of the array A is overwritten by the
-* upper triangular part of the updated matrix.
-* Before entry, with UPLO = 'L' or 'l', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular part of the symmetric matrix and the strictly
-* upper triangular part of A is not referenced. On exit, the
-* lower triangular part of the array A is overwritten by the
-* lower triangular part of the updated matrix.
-*
-* LDA (input) INTEGER
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least
-* max( 1, N ).
-* Unchanged on exit.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csyrfs"></A>
- <H2>csyrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.csyrfs( uplo, a, af, ipiv, b, x)
- or
- NumRu::Lapack.csyrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by CSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSYTRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by CSYTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csyrfsx"></A>
- <H2>csyrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.csyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)
- or
- NumRu::Lapack.csyrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYRFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the
-* solution. In addition to normwise error bound, the code provides
-* maximum componentwise error bound if possible. See comments for
-* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or A =
-* L*D*L**T as computed by SSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csysv"></A>
- <H2>csysv</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a, b = NumRu::Lapack.csysv( uplo, a, b, lwork)
- or
- NumRu::Lapack.csysv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
-* used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the block diagonal matrix D and the
-* multipliers used to obtain the factor U or L from the
-* factorization A = U*D*U**T or A = L*D*L**T as computed by
-* CSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by CSYTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= 1, and for best performance
-* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
-* CSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LWKOPT, NB
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CSYTRF, CSYTRS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csysvx"></A>
- <H2>csysvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.csysvx( fact, uplo, a, af, ipiv, b, lwork)
- or
- NumRu::Lapack.csysvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYSVX uses the diagonal pivoting factorization to compute the
-* solution to a complex system of linear equations A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
-* The form of the factorization is
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AF and IPIV contain the factored form
-* of A. A, AF and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by CSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by CSYTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by CSYTRF.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= max(1,2*N), and for best
-* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
-* NB is the optimal blocksize for CSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csysvxx"></A>
- <H2>csysvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.csysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)
- or
- NumRu::Lapack.csysvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYSVXX uses the diagonal pivoting factorization to compute the
-* solution to a complex system of linear equations A * X = B, where
-* A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. CSYSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* CSYSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* CSYSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what CSYSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 3. If some D(i,i)=0, so that D is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is
-* less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(R) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T as computed by SSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block
-* structure of D, as determined by SSYTRF. If IPIV(k) > 0,
-* then rows and columns k and IPIV(k) were interchanged and
-* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and
-* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and
-* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2
-* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,
-* then rows and columns k+1 and -IPIV(k) were interchanged
-* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block
-* structure of D, as determined by SSYTRF.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csyswapr"></A>
- <H2>csyswapr</H2>
-
- <PRE>
-USAGE:
- a = NumRu::Lapack.csyswapr( uplo, a, i1, i2)
- or
- NumRu::Lapack.csyswapr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYSWAPR( UPLO, N, A, I1, I2)
-
-* Purpose
-* =======
-*
-* CSYSWAPR applies an elementary permutation on the rows and the columns of
-* a symmetric matrix.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by CSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* I1 (input) INTEGER
-* Index of the first row to swap
-*
-* I2 (input) INTEGER
-* Index of the second row to swap
-*
-
-* =====================================================================
-*
-* ..
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
- COMPLEX TMP
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CSWAP
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csytf2"></A>
- <H2>csytf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.csytf2( uplo, a)
- or
- NumRu::Lapack.csytf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* CSYTF2 computes the factorization of a complex symmetric matrix A
-* using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U' or A = L*D*L'
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, U' is the transpose of U, and D is symmetric and
-* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 09-29-06 - patch from
-* Bobby Cheng, MathWorks
-*
-* Replace l.209 and l.377
-* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
-* by
-* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
-*
-* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csytrf"></A>
- <H2>csytrf</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a = NumRu::Lapack.csytrf( uplo, a, lwork)
- or
- NumRu::Lapack.csytrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYTRF computes the factorization of a complex symmetric matrix A
-* using the Bunch-Kaufman diagonal pivoting method. The form of the
-* factorization is
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1. For best performance
-* LWORK >= N*NB, where NB is the block size returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER
- INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL CLASYF, CSYTF2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csytri"></A>
- <H2>csytri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.csytri( uplo, a, ipiv)
- or
- NumRu::Lapack.csytri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYTRI computes the inverse of a complex symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* CSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by CSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSYTRF.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csytri2"></A>
- <H2>csytri2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.csytri2( uplo, a, ipiv, lwork)
- or
- NumRu::Lapack.csytri2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYTRI2 computes the inverse of a complex symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* CSYTRF. CSYTRI2 sets the LEADING DIMENSION of the workspace
-* before calling CSYTRI2X that actually computes the inverse.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by CSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NB structure of D
-* as determined by CSYTRF.
-*
-* WORK (workspace) COMPLEX array, dimension (N+NB+1)*(NB+3)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* WORK is size >= (N+NB+1)*(NB+3)
-* If LDWORK = -1, then a workspace query is assumed; the routine
-* calculates:
-* - the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array,
-* - and no error message related to LDWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, LQUERY
- INTEGER MINSIZE, NBMAX
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL CSYTRI2X
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csytri2x"></A>
- <H2>csytri2x</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.csytri2x( uplo, a, ipiv, nb)
- or
- NumRu::Lapack.csytri2x # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )
-
-* Purpose
-* =======
-*
-* CSYTRI2X computes the inverse of a real symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* CSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the NNB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by CSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NNB structure of D
-* as determined by CSYTRF.
-*
-* WORK (workspace) COMPLEX array, dimension (N+NNB+1,NNB+3)
-*
-* NB (input) INTEGER
-* Block size
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csytrs"></A>
- <H2>csytrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.csytrs( uplo, a, ipiv, b)
- or
- NumRu::Lapack.csytrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CSYTRS solves a system of linear equations A*X = B with a complex
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by CSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSYTRF.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="csytrs2"></A>
- <H2>csytrs2</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.csytrs2( uplo, a, ipiv, b)
- or
- NumRu::Lapack.csytrs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CSYTRS2 solves a system of linear equations A*X = B with a COMPLEX
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by CSYTRF and converted by CSYCONV.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by CSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by CSYTRF.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ctb.html b/doc/ctb.html
deleted file mode 100644
index 7b8960f..0000000
--- a/doc/ctb.html
+++ /dev/null
@@ -1,292 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for triangular band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for triangular band matrix</H1>
- <UL>
- <LI><A HREF="#ctbcon">ctbcon</A> : </LI>
- <LI><A HREF="#ctbrfs">ctbrfs</A> : </LI>
- <LI><A HREF="#ctbtrs">ctbtrs</A> : </LI>
- </UL>
-
- <A NAME="ctbcon"></A>
- <H2>ctbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.ctbcon( norm, uplo, diag, kd, ab)
- or
- NumRu::Lapack.ctbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTBCON estimates the reciprocal of the condition number of a
-* triangular band matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctbrfs"></A>
- <H2>ctbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.ctbrfs( uplo, trans, diag, kd, ab, b, x)
- or
- NumRu::Lapack.ctbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTBRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular band
-* coefficient matrix.
-*
-* The solution matrix X must be computed by CTBTRS or some other
-* means before entering this routine. CTBRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) COMPLEX array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctbtrs"></A>
- <H2>ctbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ctbtrs( uplo, trans, diag, kd, ab, b)
- or
- NumRu::Lapack.ctbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CTBTRS solves a triangular system of the form
-*
-* A * X = B, A**T * X = B, or A**H * X = B,
-*
-* where A is a triangular band matrix of order N, and B is an
-* N-by-NRHS matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) COMPLEX array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of AB. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ctg.html b/doc/ctg.html
deleted file mode 100644
index f2de8af..0000000
--- a/doc/ctg.html
+++ /dev/null
@@ -1,1567 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</H1>
- <UL>
- <LI><A HREF="#ctgevc">ctgevc</A> : </LI>
- <LI><A HREF="#ctgex2">ctgex2</A> : </LI>
- <LI><A HREF="#ctgexc">ctgexc</A> : </LI>
- <LI><A HREF="#ctgsen">ctgsen</A> : </LI>
- <LI><A HREF="#ctgsja">ctgsja</A> : </LI>
- <LI><A HREF="#ctgsna">ctgsna</A> : </LI>
- <LI><A HREF="#ctgsy2">ctgsy2</A> : </LI>
- <LI><A HREF="#ctgsyl">ctgsyl</A> : </LI>
- </UL>
-
- <A NAME="ctgevc"></A>
- <H2>ctgevc</H2>
-
- <PRE>
-USAGE:
- m, info, vl, vr = NumRu::Lapack.ctgevc( side, howmny, select, s, p, vl, vr)
- or
- NumRu::Lapack.ctgevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTGEVC computes some or all of the right and/or left eigenvectors of
-* a pair of complex matrices (S,P), where S and P are upper triangular.
-* Matrix pairs of this type are produced by the generalized Schur
-* factorization of a complex matrix pair (A,B):
-*
-* A = Q*S*Z**H, B = Q*P*Z**H
-*
-* as computed by CGGHRD + CHGEQZ.
-*
-* The right eigenvector x and the left eigenvector y of (S,P)
-* corresponding to an eigenvalue w are defined by:
-*
-* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
-*
-* where y**H denotes the conjugate tranpose of y.
-* The eigenvalues are not input to this routine, but are computed
-* directly from the diagonal elements of S and P.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
-* where Z and Q are input matrices.
-* If Q and Z are the unitary factors from the generalized Schur
-* factorization of a matrix pair (A,B), then Z*X and Q*Y
-* are the matrices of right and left eigenvectors of (A,B).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed by the matrices in VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* specified by the logical array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY='S', SELECT specifies the eigenvectors to be
-* computed. The eigenvector corresponding to the j-th
-* eigenvalue is computed if SELECT(j) = .TRUE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrices S and P. N >= 0.
-*
-* S (input) COMPLEX array, dimension (LDS,N)
-* The upper triangular matrix S from a generalized Schur
-* factorization, as computed by CHGEQZ.
-*
-* LDS (input) INTEGER
-* The leading dimension of array S. LDS >= max(1,N).
-*
-* P (input) COMPLEX array, dimension (LDP,N)
-* The upper triangular matrix P from a generalized Schur
-* factorization, as computed by CHGEQZ. P must have real
-* diagonal elements.
-*
-* LDP (input) INTEGER
-* The leading dimension of array P. LDP >= max(1,N).
-*
-* VL (input/output) COMPLEX array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the unitary matrix Q
-* of left Schur vectors returned by CHGEQZ).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
-* SELECT, stored consecutively in the columns of
-* VL, in the same order as their eigenvalues.
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
-*
-* VR (input/output) COMPLEX array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Q (usually the unitary matrix Z
-* of right Schur vectors returned by CHGEQZ).
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
-* if HOWMNY = 'B', the matrix Z*X;
-* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by
-* SELECT, stored consecutively in the columns of
-* VR, in the same order as their eigenvalues.
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B', LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
-* is set to N. Each selected eigenvector occupies one column.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctgex2"></A>
- <H2>ctgex2</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.ctgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1)
- or
- NumRu::Lapack.ctgex2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )
-
-* Purpose
-* =======
-*
-* CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)
-* in an upper triangular matrix pair (A, B) by an unitary equivalence
-* transformation.
-*
-* (A, B) must be in generalized Schur canonical form, that is, A and
-* B are both upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX arrays, dimensions (LDA,N)
-* On entry, the matrix A in the pair (A, B).
-* On exit, the updated matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX arrays, dimensions (LDB,N)
-* On entry, the matrix B in the pair (A, B).
-* On exit, the updated matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) COMPLEX array, dimension (LDZ,N)
-* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,
-* the updated matrix Q.
-* Not referenced if WANTQ = .FALSE..
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1;
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ,N)
-* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,
-* the updated matrix Z.
-* Not referenced if WANTZ = .FALSE..
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1;
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* J1 (input) INTEGER
-* The index to the first block (A11, B11).
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* =1: The transformed matrix pair (A, B) would be too far
-* from generalized Schur form; the problem is ill-
-* conditioned.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* In the current code both weak and strong stability tests are
-* performed. The user can omit the strong stability test by changing
-* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
-* details.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report UMINF-94.04,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, 1994. Also as LAPACK Working Note 87. To appear in
-* Numerical Algorithms, 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctgexc"></A>
- <H2>ctgexc</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z, ilst = NumRu::Lapack.ctgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst)
- or
- NumRu::Lapack.ctgexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )
-
-* Purpose
-* =======
-*
-* CTGEXC reorders the generalized Schur decomposition of a complex
-* matrix pair (A,B), using an unitary equivalence transformation
-* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with
-* row index IFST is moved to row ILST.
-*
-* (A, B) must be in generalized Schur canonical form, that is, A and
-* B are both upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the upper triangular matrix A in the pair (A, B).
-* On exit, the updated matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB,N)
-* On entry, the upper triangular matrix B in the pair (A, B).
-* On exit, the updated matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) COMPLEX array, dimension (LDZ,N)
-* On entry, if WANTQ = .TRUE., the unitary matrix Q.
-* On exit, the updated matrix Q.
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1;
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., the unitary matrix Z.
-* On exit, the updated matrix Z.
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1;
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* IFST (input) INTEGER
-* ILST (input/output) INTEGER
-* Specify the reordering of the diagonal blocks of (A, B).
-* The block with row index IFST is moved to row ILST, by a
-* sequence of swapping between adjacent blocks.
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* <0: if INFO = -i, the i-th argument had an illegal value.
-* =1: The transformed matrix pair (A, B) would be too far
-* from generalized Schur form; the problem is ill-
-* conditioned. (A, B) may have been partially reordered,
-* and ILST points to the first row of the current
-* position of the block being moved.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report
-* UMINF - 94.04, Department of Computing Science, Umea University,
-* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
-* To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
-* 1996.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER HERE
-* ..
-* .. External Subroutines ..
- EXTERNAL CTGEX2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctgsen"></A>
- <H2>ctgsen</H2>
-
- <PRE>
-USAGE:
- alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ctgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)
- or
- NumRu::Lapack.ctgsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTGSEN reorders the generalized Schur decomposition of a complex
-* matrix pair (A, B) (in terms of an unitary equivalence trans-
-* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
-* appears in the leading diagonal blocks of the pair (A,B). The leading
-* columns of Q and Z form unitary bases of the corresponding left and
-* right eigenspaces (deflating subspaces). (A, B) must be in
-* generalized Schur canonical form, that is, A and B are both upper
-* triangular.
-*
-* CTGSEN also computes the generalized eigenvalues
-*
-* w(j)= ALPHA(j) / BETA(j)
-*
-* of the reordered matrix pair (A, B).
-*
-* Optionally, the routine computes estimates of reciprocal condition
-* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
-* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
-* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
-* the selected cluster and the eigenvalues outside the cluster, resp.,
-* and norms of "projections" onto left and right eigenspaces w.r.t.
-* the selected cluster in the (1,1)-block.
-*
-*
-
-* Arguments
-* =========
-*
-* IJOB (input) integer
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (PL and PR) or the deflating subspaces
-* (Difu and Difl):
-* =0: Only reorder w.r.t. SELECT. No extras.
-* =1: Reciprocal of norms of "projections" onto left and right
-* eigenspaces w.r.t. the selected cluster (PL and PR).
-* =2: Upper bounds on Difu and Difl. F-norm-based estimate
-* (DIF(1:2)).
-* =3: Estimate of Difu and Difl. 1-norm-based estimate
-* (DIF(1:2)).
-* About 5 times as expensive as IJOB = 2.
-* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
-* version to get it all.
-* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster. To
-* select an eigenvalue w(j), SELECT(j) must be set to
-* .TRUE..
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension(LDA,N)
-* On entry, the upper triangular matrix A, in generalized
-* Schur canonical form.
-* On exit, A is overwritten by the reordered matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension(LDB,N)
-* On entry, the upper triangular matrix B, in generalized
-* Schur canonical form.
-* On exit, B is overwritten by the reordered matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX array, dimension (N)
-* BETA (output) COMPLEX array, dimension (N)
-* The diagonal elements of A and B, respectively,
-* when the pair (A,B) has been reduced to generalized Schur
-* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized
-* eigenvalues.
-*
-* Q (input/output) COMPLEX array, dimension (LDQ,N)
-* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
-* On exit, Q has been postmultiplied by the left unitary
-* transformation matrix which reorder (A, B); The leading M
-* columns of Q form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) COMPLEX array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
-* On exit, Z has been postmultiplied by the left unitary
-* transformation matrix which reorder (A, B); The leading M
-* columns of Z form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* M (output) INTEGER
-* The dimension of the specified pair of left and right
-* eigenspaces, (deflating subspaces) 0 <= M <= N.
-*
-* PL (output) REAL
-* PR (output) REAL
-* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
-* reciprocal of the norm of "projections" onto left and right
-* eigenspace with respect to the selected cluster.
-* 0 < PL, PR <= 1.
-* If M = 0 or M = N, PL = PR = 1.
-* If IJOB = 0, 2 or 3 PL, PR are not referenced.
-*
-* DIF (output) REAL array, dimension (2).
-* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
-* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
-* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
-* estimates of Difu and Difl, computed using reversed
-* communication with CLACN2.
-* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
-* If IJOB = 0 or 1, DIF is not referenced.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1
-* If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
-* If IJOB = 3 or 5, LWORK >= 4*M*(N-M)
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= 1.
-* If IJOB = 1, 2 or 4, LIWORK >= N+2;
-* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* =1: Reordering of (A, B) failed because the transformed
-* matrix pair (A, B) would be too far from generalized
-* Schur form; the problem is very ill-conditioned.
-* (A, B) may have been partially reordered.
-* If requested, 0 is returned in DIF(*), PL and PR.
-*
-*
-
-* Further Details
-* ===============
-*
-* CTGSEN first collects the selected eigenvalues by computing unitary
-* U and W that move them to the top left corner of (A, B). In other
-* words, the selected eigenvalues are the eigenvalues of (A11, B11) in
-*
-* U'*(A, B)*W = (A11 A12) (B11 B12) n1
-* ( 0 A22),( 0 B22) n2
-* n1 n2 n1 n2
-*
-* where N = n1+n2 and U' means the conjugate transpose of U. The first
-* n1 columns of U and W span the specified pair of left and right
-* eigenspaces (deflating subspaces) of (A, B).
-*
-* If (A, B) has been obtained from the generalized real Schur
-* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
-* reordered generalized Schur form of (C, D) is given by
-*
-* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
-*
-* and the first n1 columns of Q*U and Z*W span the corresponding
-* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
-*
-* Note that if the selected eigenvalue is sufficiently ill-conditioned,
-* then its value may differ significantly from its value before
-* reordering.
-*
-* The reciprocal condition numbers of the left and right eigenspaces
-* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
-* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
-*
-* The Difu and Difl are defined as:
-*
-* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
-* and
-* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
-*
-* where sigma-min(Zu) is the smallest singular value of the
-* (2*n1*n2)-by-(2*n1*n2) matrix
-*
-* Zu = [ kron(In2, A11) -kron(A22', In1) ]
-* [ kron(In2, B11) -kron(B22', In1) ].
-*
-* Here, Inx is the identity matrix of size nx and A22' is the
-* transpose of A22. kron(X, Y) is the Kronecker product between
-* the matrices X and Y.
-*
-* When DIF(2) is small, small changes in (A, B) can cause large changes
-* in the deflating subspace. An approximate (asymptotic) bound on the
-* maximum angular error in the computed deflating subspaces is
-*
-* EPS * norm((A, B)) / DIF(2),
-*
-* where EPS is the machine precision.
-*
-* The reciprocal norm of the projectors on the left and right
-* eigenspaces associated with (A11, B11) may be returned in PL and PR.
-* They are computed as follows. First we compute L and R so that
-* P*(A, B)*Q is block diagonal, where
-*
-* P = ( I -L ) n1 Q = ( I R ) n1
-* ( 0 I ) n2 and ( 0 I ) n2
-* n1 n2 n1 n2
-*
-* and (L, R) is the solution to the generalized Sylvester equation
-*
-* A11*R - L*A22 = -A12
-* B11*R - L*B22 = -B12
-*
-* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
-* An approximate (asymptotic) bound on the average absolute error of
-* the selected eigenvalues is
-*
-* EPS * norm((A, B)) / PL.
-*
-* There are also global error bounds which valid for perturbations up
-* to a certain restriction: A lower bound (x) on the smallest
-* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
-* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
-* (i.e. (A + E, B + F), is
-*
-* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
-*
-* An approximate bound on x can be computed from DIF(1:2), PL and PR.
-*
-* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
-* (L', R') and unperturbed (L, R) left and right deflating subspaces
-* associated with the selected cluster in the (1,1)-blocks can be
-* bounded as
-*
-* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
-* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
-*
-* See LAPACK User's Guide section 4.11 or the following references
-* for more information.
-*
-* Note that if the default method for computing the Frobenius-norm-
-* based estimate DIF is not wanted (see CLATDF), then the parameter
-* IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF
-* (IJOB = 2 will be used)). See CTGSYL for more details.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report
-* UMINF - 94.04, Department of Computing Science, Umea University,
-* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
-* To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
-* 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctgsja"></A>
- <H2>ctgsja</H2>
-
- <PRE>
-USAGE:
- alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ctgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)
- or
- NumRu::Lapack.ctgsja # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )
-
-* Purpose
-* =======
-*
-* CTGSJA computes the generalized singular value decomposition (GSVD)
-* of two complex upper triangular (or trapezoidal) matrices A and B.
-*
-* On entry, it is assumed that matrices A and B have the following
-* forms, which may be obtained by the preprocessing subroutine CGGSVP
-* from a general M-by-N matrix A and P-by-N matrix B:
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* B = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal.
-*
-* On exit,
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
-*
-* where U, V and Q are unitary matrices, Z' denotes the conjugate
-* transpose of Z, R is a nonsingular upper triangular matrix, and D1
-* and D2 are ``diagonal'' matrices, which are of the following
-* structures:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 ) K
-* L ( 0 0 R22 ) L
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The computation of the unitary transformation matrices U, V or Q
-* is optional. These matrices may either be formed explicitly, or they
-* may be postmultiplied into input matrices U1, V1, or Q1.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': U must contain a unitary matrix U1 on entry, and
-* the product U1*U is returned;
-* = 'I': U is initialized to the unit matrix, and the
-* unitary matrix U is returned;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': V must contain a unitary matrix V1 on entry, and
-* the product V1*V is returned;
-* = 'I': V is initialized to the unit matrix, and the
-* unitary matrix V is returned;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Q must contain a unitary matrix Q1 on entry, and
-* the product Q1*Q is returned;
-* = 'I': Q is initialized to the unit matrix, and the
-* unitary matrix Q is returned;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* K (input) INTEGER
-* L (input) INTEGER
-* K and L specify the subblocks in the input matrices A and B:
-* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)
-* of A and B, whose GSVD is going to be computed by CTGSJA.
-* See Further Details.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
-* matrix R or part of R. See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
-* a part of R. See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) REAL
-* TOLB (input) REAL
-* TOLA and TOLB are the convergence criteria for the Jacobi-
-* Kogbetliantz iteration procedure. Generally, they are the
-* same as used in the preprocessing step, say
-* TOLA = MAX(M,N)*norm(A)*MACHEPS,
-* TOLB = MAX(P,N)*norm(B)*MACHEPS.
-*
-* ALPHA (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = diag(C),
-* BETA(K+1:K+L) = diag(S),
-* or if M-K-L < 0,
-* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
-* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
-* Furthermore, if K+L < N,
-* ALPHA(K+L+1:N) = 0
-* BETA(K+L+1:N) = 0.
-*
-* U (input/output) COMPLEX array, dimension (LDU,M)
-* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
-* the unitary matrix returned by CGGSVP).
-* On exit,
-* if JOBU = 'I', U contains the unitary matrix U;
-* if JOBU = 'U', U contains the product U1*U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (input/output) COMPLEX array, dimension (LDV,P)
-* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
-* the unitary matrix returned by CGGSVP).
-* On exit,
-* if JOBV = 'I', V contains the unitary matrix V;
-* if JOBV = 'V', V contains the product V1*V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (input/output) COMPLEX array, dimension (LDQ,N)
-* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
-* the unitary matrix returned by CGGSVP).
-* On exit,
-* if JOBQ = 'I', Q contains the unitary matrix Q;
-* if JOBQ = 'Q', Q contains the product Q1*Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* NCYCLE (output) INTEGER
-* The number of cycles required for convergence.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the procedure does not converge after MAXIT cycles.
-*
-* Internal Parameters
-* ===================
-*
-* MAXIT INTEGER
-* MAXIT specifies the total loops that the iterative procedure
-* may take. If after MAXIT cycles, the routine fails to
-* converge, we return INFO = 1.
-*
-
-* Further Details
-* ===============
-*
-* CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
-* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
-* matrix B13 to the form:
-*
-* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
-*
-* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate
-* transpose of Z. C1 and S1 are diagonal matrices satisfying
-*
-* C1**2 + S1**2 = I,
-*
-* and R1 is an L-by-L nonsingular upper triangular matrix.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctgsna"></A>
- <H2>ctgsna</H2>
-
- <PRE>
-USAGE:
- s, dif, m, work, info = NumRu::Lapack.ctgsna( job, howmny, select, a, b, vl, vr, lwork)
- or
- NumRu::Lapack.ctgsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTGSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or eigenvectors of a matrix pair (A, B).
-*
-* (A, B) must be in generalized Schur canonical form, that is, A and
-* B are both upper triangular.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (DIF):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (DIF);
-* = 'B': for both eigenvalues and eigenvectors (S and DIF).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the corresponding j-th eigenvalue and/or eigenvector,
-* SELECT(j) must be set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the square matrix pair (A, B). N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The upper triangular matrix A in the pair (A,B).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX array, dimension (LDB,N)
-* The upper triangular matrix B in the pair (A, B).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) COMPLEX array, dimension (LDVL,M)
-* IF JOB = 'E' or 'B', VL must contain left eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns of VL, as returned by CTGEVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; and
-* If JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) COMPLEX array, dimension (LDVR,M)
-* IF JOB = 'E' or 'B', VR must contain right eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns of VR, as returned by CTGEVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1;
-* If JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) REAL array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array.
-* If JOB = 'V', S is not referenced.
-*
-* DIF (output) REAL array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array.
-* If the eigenvalues cannot be reordered to compute DIF(j),
-* DIF(j) is set to 0; this can only occur when the true value
-* would be very small anyway.
-* For each eigenvalue/vector specified by SELECT, DIF stores
-* a Frobenius norm-based estimate of Difl.
-* If JOB = 'E', DIF is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S and DIF. MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and DIF used to store
-* the specified condition numbers; for each selected eigenvalue
-* one element is used. If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).
-*
-* IWORK (workspace) INTEGER array, dimension (N+2)
-* If JOB = 'E', IWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: Successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of the i-th generalized
-* eigenvalue w = (a, b) is defined as
-*
-* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))
-*
-* where u and v are the right and left eigenvectors of (A, B)
-* corresponding to w; |z| denotes the absolute value of the complex
-* number, and norm(u) denotes the 2-norm of the vector u. The pair
-* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the
-* matrix pair (A, B). If both a and b equal zero, then (A,B) is
-* singular and S(I) = -1 is returned.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(A, B) / S(I),
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number of the right eigenvector u
-* and left eigenvector v corresponding to the generalized eigenvalue w
-* is defined as follows. Suppose
-*
-* (A, B) = ( a * ) ( b * ) 1
-* ( 0 A22 ),( 0 B22 ) n-1
-* 1 n-1 1 n-1
-*
-* Then the reciprocal condition number DIF(I) is
-*
-* Difl[(a, b), (A22, B22)] = sigma-min( Zl )
-*
-* where sigma-min(Zl) denotes the smallest singular value of
-*
-* Zl = [ kron(a, In-1) -kron(1, A22) ]
-* [ kron(b, In-1) -kron(1, B22) ].
-*
-* Here In-1 is the identity matrix of size n-1 and X' is the conjugate
-* transpose of X. kron(X, Y) is the Kronecker product between the
-* matrices X and Y.
-*
-* We approximate the smallest singular value of Zl with an upper
-* bound. This is done by CLATDF.
-*
-* An approximate error bound for a computed eigenvector VL(i) or
-* VR(i) is given by
-*
-* EPS * norm(A, B) / DIF(i).
-*
-* See ref. [2-3] for more details and further references.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report
-* UMINF - 94.04, Department of Computing Science, Umea University,
-* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
-* To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75.
-* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctgsy2"></A>
- <H2>ctgsy2</H2>
-
- <PRE>
-USAGE:
- scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ctgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)
- or
- NumRu::Lapack.ctgsy2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )
-
-* Purpose
-* =======
-*
-* CTGSY2 solves the generalized Sylvester equation
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F
-*
-* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,
-* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
-* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular
-* (i.e., (A,D) and (B,E) in generalized Schur form).
-*
-* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
-* scaling factor chosen to avoid overflow.
-*
-* In matrix notation solving equation (1) corresponds to solve
-* Zx = scale * b, where Z is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ],
-*
-* Ik is the identity matrix of size k and X' is the transpose of X.
-* kron(X, Y) is the Kronecker product between the matrices X and Y.
-*
-* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b
-* is solved for, which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * -F
-*
-* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
-* = sigma_min(Z) using reverse communicaton with CLACON.
-*
-* CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL
-* of an upper bound on the separation between to matrix pairs. Then
-* the input (A, D), (B, E) are sub-pencils of two matrix pairs in
-* CTGSYL.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N', solve the generalized Sylvester equation (1).
-* = 'T': solve the 'transposed' system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* =0: solve (1) only.
-* =1: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (look ahead strategy is used).
-* =2: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (SGECON on sub-systems is used.)
-* Not referenced if TRANS = 'T'.
-*
-* M (input) INTEGER
-* On entry, M specifies the order of A and D, and the row
-* dimension of C, F, R and L.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of B and E, and the column
-* dimension of C, F, R and L.
-*
-* A (input) COMPLEX array, dimension (LDA, M)
-* On entry, A contains an upper triangular matrix.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1, M).
-*
-* B (input) COMPLEX array, dimension (LDB, N)
-* On entry, B contains an upper triangular matrix.
-*
-* LDB (input) INTEGER
-* The leading dimension of the matrix B. LDB >= max(1, N).
-*
-* C (input/output) COMPLEX array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1).
-* On exit, if IJOB = 0, C has been overwritten by the solution
-* R.
-*
-* LDC (input) INTEGER
-* The leading dimension of the matrix C. LDC >= max(1, M).
-*
-* D (input) COMPLEX array, dimension (LDD, M)
-* On entry, D contains an upper triangular matrix.
-*
-* LDD (input) INTEGER
-* The leading dimension of the matrix D. LDD >= max(1, M).
-*
-* E (input) COMPLEX array, dimension (LDE, N)
-* On entry, E contains an upper triangular matrix.
-*
-* LDE (input) INTEGER
-* The leading dimension of the matrix E. LDE >= max(1, N).
-*
-* F (input/output) COMPLEX array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1).
-* On exit, if IJOB = 0, F has been overwritten by the solution
-* L.
-*
-* LDF (input) INTEGER
-* The leading dimension of the matrix F. LDF >= max(1, M).
-*
-* SCALE (output) REAL
-* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
-* R and L (C and F on entry) will hold the solutions to a
-* slightly perturbed system but the input matrices A, B, D and
-* E have not been changed. If SCALE = 0, R and L will hold the
-* solutions to the homogeneous system with C = F = 0.
-* Normally, SCALE = 1.
-*
-* RDSUM (input/output) REAL
-* On entry, the sum of squares of computed contributions to
-* the Dif-estimate under computation by CTGSYL, where the
-* scaling factor RDSCAL (see below) has been factored out.
-* On exit, the corresponding sum of squares updated with the
-* contributions from the current sub-system.
-* If TRANS = 'T' RDSUM is not touched.
-* NOTE: RDSUM only makes sense when CTGSY2 is called by
-* CTGSYL.
-*
-* RDSCAL (input/output) REAL
-* On entry, scaling factor used to prevent overflow in RDSUM.
-* On exit, RDSCAL is updated w.r.t. the current contributions
-* in RDSUM.
-* If TRANS = 'T', RDSCAL is not touched.
-* NOTE: RDSCAL only makes sense when CTGSY2 is called by
-* CTGSYL.
-*
-* INFO (output) INTEGER
-* On exit, if INFO is set to
-* =0: Successful exit
-* <0: If INFO = -i, input argument number i is illegal.
-* >0: The matrix pairs (A, D) and (B, E) have common or very
-* close eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctgsyl"></A>
- <H2>ctgsyl</H2>
-
- <PRE>
-USAGE:
- scale, dif, work, info, c, f = NumRu::Lapack.ctgsyl( trans, ijob, a, b, c, d, e, f, lwork)
- or
- NumRu::Lapack.ctgsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTGSYL solves the generalized Sylvester equation:
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F
-*
-* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
-* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
-* respectively, with complex entries. A, B, D and E are upper
-* triangular (i.e., (A,D) and (B,E) in generalized Schur form).
-*
-* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
-* is an output scaling factor chosen to avoid overflow.
-*
-* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
-* is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ],
-*
-* Here Ix is the identity matrix of size x and X' is the conjugate
-* transpose of X. Kron(X, Y) is the Kronecker product between the
-* matrices X and Y.
-*
-* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b
-* is solved for, which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * -F
-*
-* This case (TRANS = 'C') is used to compute an one-norm-based estimate
-* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
-* and (B,E), using CLACON.
-*
-* If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of
-* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
-* reciprocal of the smallest singular value of Z.
-*
-* This is a level-3 BLAS algorithm.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N': solve the generalized sylvester equation (1).
-* = 'C': solve the "conjugate transposed" system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* =0: solve (1) only.
-* =1: The functionality of 0 and 3.
-* =2: The functionality of 0 and 4.
-* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* (look ahead strategy is used).
-* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* (CGECON on sub-systems is used).
-* Not referenced if TRANS = 'C'.
-*
-* M (input) INTEGER
-* The order of the matrices A and D, and the row dimension of
-* the matrices C, F, R and L.
-*
-* N (input) INTEGER
-* The order of the matrices B and E, and the column dimension
-* of the matrices C, F, R and L.
-*
-* A (input) COMPLEX array, dimension (LDA, M)
-* The upper triangular matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, M).
-*
-* B (input) COMPLEX array, dimension (LDB, N)
-* The upper triangular matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1, N).
-*
-* C (input/output) COMPLEX array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
-* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1, M).
-*
-* D (input) COMPLEX array, dimension (LDD, M)
-* The upper triangular matrix D.
-*
-* LDD (input) INTEGER
-* The leading dimension of the array D. LDD >= max(1, M).
-*
-* E (input) COMPLEX array, dimension (LDE, N)
-* The upper triangular matrix E.
-*
-* LDE (input) INTEGER
-* The leading dimension of the array E. LDE >= max(1, N).
-*
-* F (input/output) COMPLEX array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
-* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDF (input) INTEGER
-* The leading dimension of the array F. LDF >= max(1, M).
-*
-* DIF (output) REAL
-* On exit DIF is the reciprocal of a lower bound of the
-* reciprocal of the Dif-function, i.e. DIF is an upper bound of
-* Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
-* IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
-*
-* SCALE (output) REAL
-* On exit SCALE is the scaling factor in (1) or (3).
-* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
-* to a slightly perturbed system but the input matrices A, B,
-* D and E have not been changed. If SCALE = 0, R and L will
-* hold the solutions to the homogenious system with C = F = 0.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK > = 1.
-* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M+N+2)
-*
-* INFO (output) INTEGER
-* =0: successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* >0: (A, D) and (B, E) have common or very close
-* eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
-* No 1, 1996.
-*
-* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
-* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
-* Appl., 15(4):1045-1060, 1994.
-*
-* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
-* Condition Estimators for Solving the Generalized Sylvester
-* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
-* July 1989, pp 745-751.
-*
-* =====================================================================
-* Replaced various illegal calls to CCOPY by calls to CLASET.
-* Sven Hammarling, 1/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ctp.html b/doc/ctp.html
deleted file mode 100644
index d49b068..0000000
--- a/doc/ctp.html
+++ /dev/null
@@ -1,570 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for triangular, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for triangular, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#ctpcon">ctpcon</A> : </LI>
- <LI><A HREF="#ctprfs">ctprfs</A> : </LI>
- <LI><A HREF="#ctptri">ctptri</A> : </LI>
- <LI><A HREF="#ctptrs">ctptrs</A> : </LI>
- <LI><A HREF="#ctpttf">ctpttf</A> : </LI>
- <LI><A HREF="#ctpttr">ctpttr</A> : </LI>
- </UL>
-
- <A NAME="ctpcon"></A>
- <H2>ctpcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.ctpcon( norm, uplo, diag, ap)
- or
- NumRu::Lapack.ctpcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTPCON estimates the reciprocal of the condition number of a packed
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctprfs"></A>
- <H2>ctprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.ctprfs( uplo, trans, diag, ap, b, x)
- or
- NumRu::Lapack.ctprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTPRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular packed
-* coefficient matrix.
-*
-* The solution matrix X must be computed by CTPTRS or some other
-* means before entering this routine. CTPRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) COMPLEX array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctptri"></A>
- <H2>ctptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.ctptri( uplo, diag, n, ap)
- or
- NumRu::Lapack.ctptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* CTPTRI computes the inverse of a complex upper or lower triangular
-* matrix A stored in packed format.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangular matrix A, stored
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same packed storage format.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* Further Details
-* ===============
-*
-* A triangular matrix A can be transferred to packed storage using one
-* of the following program segments:
-*
-* UPLO = 'U': UPLO = 'L':
-*
-* JC = 1 JC = 1
-* DO 2 J = 1, N DO 2 J = 1, N
-* DO 1 I = 1, J DO 1 I = J, N
-* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
-* 1 CONTINUE 1 CONTINUE
-* JC = JC + J JC = JC + N - J + 1
-* 2 CONTINUE 2 CONTINUE
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctptrs"></A>
- <H2>ctptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ctptrs( uplo, trans, diag, n, ap, b)
- or
- NumRu::Lapack.ctptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CTPTRS solves a triangular system of the form
-*
-* A * X = B, A**T * X = B, or A**H * X = B,
-*
-* where A is a triangular matrix of order N stored in packed format,
-* and B is an N-by-NRHS matrix. A check is made to verify that A is
-* nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctpttf"></A>
- <H2>ctpttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.ctpttf( transr, uplo, n, ap)
- or
- NumRu::Lapack.ctpttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )
-
-* Purpose
-* =======
-*
-* CTPTTF copies a triangular matrix A from standard packed format (TP)
-* to rectangular full packed format (TF).
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal format is wanted;
-* = 'C': ARF in Conjugate-transpose format is wanted.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* ARF (output) COMPLEX array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A stored in
-* RFP format. For a further discussion see Notes below.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Standard Packed Format when N is even.
-* We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* conjugate-transpose of the first three columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* conjugate-transpose of the last three columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N even and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* -- -- --
-* 03 04 05 33 43 53
-* -- --
-* 13 14 15 00 44 54
-* --
-* 23 24 25 10 11 55
-*
-* 33 34 35 20 21 22
-* --
-* 00 44 45 30 31 32
-* -- --
-* 01 11 55 40 41 42
-* -- -- --
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- -- --
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* -- -- -- -- -- -- -- -- -- --
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We next consider Standard Packed Format when N is odd.
-* We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* conjugate-transpose of the first two columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* conjugate-transpose of the last two columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N odd and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* -- --
-* 02 03 04 00 33 43
-* --
-* 12 13 14 10 11 44
-*
-* 22 23 24 20 21 22
-* --
-* 00 33 34 30 31 32
-* -- --
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- --
-* 02 12 22 00 01 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- --
-* 03 13 23 33 11 33 11 21 31 41 51
-* -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctpttr"></A>
- <H2>ctpttr</H2>
-
- <PRE>
-USAGE:
- a, info = NumRu::Lapack.ctpttr( uplo, ap)
- or
- NumRu::Lapack.ctpttr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* CTPTTR copies a triangular matrix A from standard packed format (TP)
-* to standard full format (TR).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular.
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* A (output) COMPLEX array, dimension ( LDA, N )
-* On exit, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ctr.html b/doc/ctr.html
deleted file mode 100644
index 6b797d9..0000000
--- a/doc/ctr.html
+++ /dev/null
@@ -1,1316 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for triangular (or in some cases quasi-triangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for triangular (or in some cases quasi-triangular) matrix</H1>
- <UL>
- <LI><A HREF="#ctrcon">ctrcon</A> : </LI>
- <LI><A HREF="#ctrevc">ctrevc</A> : </LI>
- <LI><A HREF="#ctrexc">ctrexc</A> : </LI>
- <LI><A HREF="#ctrrfs">ctrrfs</A> : </LI>
- <LI><A HREF="#ctrsen">ctrsen</A> : </LI>
- <LI><A HREF="#ctrsna">ctrsna</A> : </LI>
- <LI><A HREF="#ctrsyl">ctrsyl</A> : </LI>
- <LI><A HREF="#ctrti2">ctrti2</A> : </LI>
- <LI><A HREF="#ctrtri">ctrtri</A> : </LI>
- <LI><A HREF="#ctrtrs">ctrtrs</A> : </LI>
- <LI><A HREF="#ctrttf">ctrttf</A> : </LI>
- <LI><A HREF="#ctrttp">ctrttp</A> : </LI>
- </UL>
-
- <A NAME="ctrcon"></A>
- <H2>ctrcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.ctrcon( norm, uplo, diag, a)
- or
- NumRu::Lapack.ctrcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTRCON estimates the reciprocal of the condition number of a
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrevc"></A>
- <H2>ctrevc</H2>
-
- <PRE>
-USAGE:
- m, info, t, vl, vr = NumRu::Lapack.ctrevc( side, howmny, select, t, vl, vr)
- or
- NumRu::Lapack.ctrevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTREVC computes some or all of the right and/or left eigenvectors of
-* a complex upper triangular matrix T.
-* Matrices of this type are produced by the Schur factorization of
-* a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR.
-*
-* The right eigenvector x and the left eigenvector y of T corresponding
-* to an eigenvalue w are defined by:
-*
-* T*x = w*x, (y**H)*T = w*(y**H)
-*
-* where y**H denotes the conjugate transpose of the vector y.
-* The eigenvalues are not input to this routine, but are read directly
-* from the diagonal of T.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
-* input matrix. If Q is the unitary factor that reduces a matrix A to
-* Schur form T, then Q*X and Q*Y are the matrices of right and left
-* eigenvectors of A.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed using the matrices supplied in
-* VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* as indicated by the logical array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
-* computed.
-* The eigenvector corresponding to the j-th eigenvalue is
-* computed if SELECT(j) = .TRUE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) COMPLEX array, dimension (LDT,N)
-* The upper triangular matrix T. T is modified, but restored
-* on exit.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input/output) COMPLEX array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the unitary matrix Q of
-* Schur vectors returned by CHSEQR).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VL, in the same order as their
-* eigenvalues.
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'B', LDVL >= N.
-*
-* VR (input/output) COMPLEX array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Q (usually the unitary matrix Q of
-* Schur vectors returned by CHSEQR).
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*X;
-* if HOWMNY = 'S', the right eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VR, in the same order as their
-* eigenvalues.
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B'; LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
-* is set to N. Each selected eigenvector occupies one
-* column.
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The algorithm used in this program is basically backward (forward)
-* substitution, with scaling to make the the code robust against
-* possible overflow.
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x| + |y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrexc"></A>
- <H2>ctrexc</H2>
-
- <PRE>
-USAGE:
- info, t, q = NumRu::Lapack.ctrexc( compq, t, q, ifst, ilst)
- or
- NumRu::Lapack.ctrexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
-
-* Purpose
-* =======
-*
-* CTREXC reorders the Schur factorization of a complex matrix
-* A = Q*T*Q**H, so that the diagonal element of T with row index IFST
-* is moved to row ILST.
-*
-* The Schur form T is reordered by a unitary similarity transformation
-* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
-* postmultplying it with Z.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) COMPLEX array, dimension (LDT,N)
-* On entry, the upper triangular matrix T.
-* On exit, the reordered upper triangular matrix.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) COMPLEX array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* unitary transformation matrix Z which reorders T.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* IFST (input) INTEGER
-* ILST (input) INTEGER
-* Specify the reordering of the diagonal elements of T:
-* The element with row index IFST is moved to row ILST by a
-* sequence of transpositions between adjacent elements.
-* 1 <= IFST <= N; 1 <= ILST <= N.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL WANTQ
- INTEGER K, M1, M2, M3
- REAL CS
- COMPLEX SN, T11, T22, TEMP
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CLARTG, CROT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC CONJG, MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrrfs"></A>
- <H2>ctrrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.ctrrfs( uplo, trans, diag, a, b, x)
- or
- NumRu::Lapack.ctrrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTRRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular
-* coefficient matrix.
-*
-* The solution matrix X must be computed by CTRTRS or some other
-* means before entering this routine. CTRRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) COMPLEX array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX array, dimension (2*N)
-*
-* RWORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrsen"></A>
- <H2>ctrsen</H2>
-
- <PRE>
-USAGE:
- w, m, s, sep, work, info, t, q = NumRu::Lapack.ctrsen( job, compq, select, t, q, lwork)
- or
- NumRu::Lapack.ctrsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTRSEN reorders the Schur factorization of a complex matrix
-* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
-* the leading positions on the diagonal of the upper triangular matrix
-* T, and the leading columns of Q form an orthonormal basis of the
-* corresponding right invariant subspace.
-*
-* Optionally the routine computes the reciprocal condition numbers of
-* the cluster of eigenvalues and/or the invariant subspace.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (S) or the invariant subspace (SEP):
-* = 'N': none;
-* = 'E': for eigenvalues only (S);
-* = 'V': for invariant subspace only (SEP);
-* = 'B': for both eigenvalues and invariant subspace (S and
-* SEP).
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster. To
-* select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) COMPLEX array, dimension (LDT,N)
-* On entry, the upper triangular matrix T.
-* On exit, T is overwritten by the reordered matrix T, with the
-* selected eigenvalues as the leading diagonal elements.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) COMPLEX array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* unitary transformation matrix which reorders T; the leading M
-* columns of Q form an orthonormal basis for the specified
-* invariant subspace.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
-*
-* W (output) COMPLEX array, dimension (N)
-* The reordered eigenvalues of T, in the same order as they
-* appear on the diagonal of T.
-*
-* M (output) INTEGER
-* The dimension of the specified invariant subspace.
-* 0 <= M <= N.
-*
-* S (output) REAL
-* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
-* condition number for the selected cluster of eigenvalues.
-* S cannot underestimate the true reciprocal condition number
-* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
-* If JOB = 'N' or 'V', S is not referenced.
-*
-* SEP (output) REAL
-* If JOB = 'V' or 'B', SEP is the estimated reciprocal
-* condition number of the specified invariant subspace. If
-* M = 0 or N, SEP = norm(T).
-* If JOB = 'N' or 'E', SEP is not referenced.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If JOB = 'N', LWORK >= 1;
-* if JOB = 'E', LWORK = max(1,M*(N-M));
-* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* CTRSEN first collects the selected eigenvalues by computing a unitary
-* transformation Z to move them to the top left corner of T. In other
-* words, the selected eigenvalues are the eigenvalues of T11 in:
-*
-* Z'*T*Z = ( T11 T12 ) n1
-* ( 0 T22 ) n2
-* n1 n2
-*
-* where N = n1+n2 and Z' means the conjugate transpose of Z. The first
-* n1 columns of Z span the specified invariant subspace of T.
-*
-* If T has been obtained from the Schur factorization of a matrix
-* A = Q*T*Q', then the reordered Schur factorization of A is given by
-* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the
-* corresponding invariant subspace of A.
-*
-* The reciprocal condition number of the average of the eigenvalues of
-* T11 may be returned in S. S lies between 0 (very badly conditioned)
-* and 1 (very well conditioned). It is computed as follows. First we
-* compute R so that
-*
-* P = ( I R ) n1
-* ( 0 0 ) n2
-* n1 n2
-*
-* is the projector on the invariant subspace associated with T11.
-* R is the solution of the Sylvester equation:
-*
-* T11*R - R*T22 = T12.
-*
-* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
-* the two-norm of M. Then S is computed as the lower bound
-*
-* (1 + F-norm(R)**2)**(-1/2)
-*
-* on the reciprocal of 2-norm(P), the true reciprocal condition number.
-* S cannot underestimate 1 / 2-norm(P) by more than a factor of
-* sqrt(N).
-*
-* An approximate error bound for the computed average of the
-* eigenvalues of T11 is
-*
-* EPS * norm(T) / S
-*
-* where EPS is the machine precision.
-*
-* The reciprocal condition number of the right invariant subspace
-* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
-* SEP is defined as the separation of T11 and T22:
-*
-* sep( T11, T22 ) = sigma-min( C )
-*
-* where sigma-min(C) is the smallest singular value of the
-* n1*n2-by-n1*n2 matrix
-*
-* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
-*
-* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
-* product. We estimate sigma-min(C) by the reciprocal of an estimate of
-* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
-* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
-*
-* When SEP is small, small changes in T can cause large changes in
-* the invariant subspace. An approximate bound on the maximum angular
-* error in the computed right invariant subspace is
-*
-* EPS * norm(T) / SEP
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrsna"></A>
- <H2>ctrsna</H2>
-
- <PRE>
-USAGE:
- s, sep, m, info = NumRu::Lapack.ctrsna( job, howmny, select, t, vl, vr, ldwork)
- or
- NumRu::Lapack.ctrsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTRSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or right eigenvectors of a complex upper triangular
-* matrix T (or of any matrix Q*T*Q**H with Q unitary).
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (SEP):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (SEP);
-* = 'B': for both eigenvalues and eigenvectors (S and SEP).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the j-th eigenpair, SELECT(j) must be set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input) COMPLEX array, dimension (LDT,N)
-* The upper triangular matrix T.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input) COMPLEX array, dimension (LDVL,M)
-* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
-* (or of any Q*T*Q**H with Q unitary), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VL, as returned by
-* CHSEIN or CTREVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) COMPLEX array, dimension (LDVR,M)
-* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
-* (or of any Q*T*Q**H with Q unitary), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VR, as returned by
-* CHSEIN or CTREVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) REAL array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array. Thus S(j), SEP(j), and the j-th columns of VL and VR
-* all correspond to the same eigenpair (but not in general the
-* j-th eigenpair, unless all eigenpairs are selected).
-* If JOB = 'V', S is not referenced.
-*
-* SEP (output) REAL array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array.
-* If JOB = 'E', SEP is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S (if JOB = 'E' or 'B')
-* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and/or SEP actually
-* used to store the estimated condition numbers.
-* If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace) COMPLEX array, dimension (LDWORK,N+6)
-* If JOB = 'E', WORK is not referenced.
-*
-* LDWORK (input) INTEGER
-* The leading dimension of the array WORK.
-* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
-*
-* RWORK (workspace) REAL array, dimension (N)
-* If JOB = 'E', RWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of an eigenvalue lambda is
-* defined as
-*
-* S(lambda) = |v'*u| / (norm(u)*norm(v))
-*
-* where u and v are the right and left eigenvectors of T corresponding
-* to lambda; v' denotes the conjugate transpose of v, and norm(u)
-* denotes the Euclidean norm. These reciprocal condition numbers always
-* lie between zero (very badly conditioned) and one (very well
-* conditioned). If n = 1, S(lambda) is defined to be 1.
-*
-* An approximate error bound for a computed eigenvalue W(i) is given by
-*
-* EPS * norm(T) / S(i)
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number of the right eigenvector u
-* corresponding to lambda is defined as follows. Suppose
-*
-* T = ( lambda c )
-* ( 0 T22 )
-*
-* Then the reciprocal condition number is
-*
-* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
-*
-* where sigma-min denotes the smallest singular value. We approximate
-* the smallest singular value by the reciprocal of an estimate of the
-* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
-* defined to be abs(T(1,1)).
-*
-* An approximate error bound for a computed right eigenvector VR(i)
-* is given by
-*
-* EPS * norm(T) / SEP(i)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrsyl"></A>
- <H2>ctrsyl</H2>
-
- <PRE>
-USAGE:
- scale, info, c = NumRu::Lapack.ctrsyl( trana, tranb, isgn, a, b, c)
- or
- NumRu::Lapack.ctrsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* CTRSYL solves the complex Sylvester matrix equation:
-*
-* op(A)*X + X*op(B) = scale*C or
-* op(A)*X - X*op(B) = scale*C,
-*
-* where op(A) = A or A**H, and A and B are both upper triangular. A is
-* M-by-M and B is N-by-N; the right hand side C and the solution X are
-* M-by-N; and scale is an output scale factor, set <= 1 to avoid
-* overflow in X.
-*
-
-* Arguments
-* =========
-*
-* TRANA (input) CHARACTER*1
-* Specifies the option op(A):
-* = 'N': op(A) = A (No transpose)
-* = 'C': op(A) = A**H (Conjugate transpose)
-*
-* TRANB (input) CHARACTER*1
-* Specifies the option op(B):
-* = 'N': op(B) = B (No transpose)
-* = 'C': op(B) = B**H (Conjugate transpose)
-*
-* ISGN (input) INTEGER
-* Specifies the sign in the equation:
-* = +1: solve op(A)*X + X*op(B) = scale*C
-* = -1: solve op(A)*X - X*op(B) = scale*C
-*
-* M (input) INTEGER
-* The order of the matrix A, and the number of rows in the
-* matrices X and C. M >= 0.
-*
-* N (input) INTEGER
-* The order of the matrix B, and the number of columns in the
-* matrices X and C. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,M)
-* The upper triangular matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input) COMPLEX array, dimension (LDB,N)
-* The upper triangular matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N right hand side matrix C.
-* On exit, C is overwritten by the solution matrix X.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M)
-*
-* SCALE (output) REAL
-* The scale factor, scale, set <= 1 to avoid overflow in X.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: A and B have common or very close eigenvalues; perturbed
-* values were used to solve the equation (but the matrices
-* A and B are unchanged).
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrti2"></A>
- <H2>ctrti2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ctrti2( uplo, diag, a)
- or
- NumRu::Lapack.ctrti2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* CTRTI2 computes the inverse of a complex upper or lower triangular
-* matrix.
-*
-* This is the Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the matrix A is upper or lower triangular.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* DIAG (input) CHARACTER*1
-* Specifies whether or not the matrix A is unit triangular.
-* = 'N': Non-unit triangular
-* = 'U': Unit triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading n by n upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-*
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrtri"></A>
- <H2>ctrtri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ctrtri( uplo, diag, a)
- or
- NumRu::Lapack.ctrtri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* CTRTRI computes the inverse of a complex upper or lower triangular
-* matrix A.
-*
-* This is the Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrtrs"></A>
- <H2>ctrtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ctrtrs( uplo, trans, diag, a, b)
- or
- NumRu::Lapack.ctrtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* CTRTRS solves a triangular system of the form
-*
-* A * X = B, A**T * X = B, or A**H * X = B,
-*
-* where A is a triangular matrix of order N, and B is an N-by-NRHS
-* matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the solutions
-* X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrttf"></A>
- <H2>ctrttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.ctrttf( transr, uplo, a)
- or
- NumRu::Lapack.ctrttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )
-
-* Purpose
-* =======
-*
-* CTRTTF copies a triangular matrix A from standard full format (TR)
-* to rectangular full packed format (TF) .
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal mode is wanted;
-* = 'C': ARF in Conjugate Transpose mode is wanted;
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX array, dimension ( LDA, N )
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1,N).
-*
-* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A stored in
-* RFP format. For a further discussion see Notes below.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Standard Packed Format when N is even.
-* We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = `N'. RFP holds AP as follows:
-* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* conjugate-transpose of the first three columns of AP upper.
-* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* conjugate-transpose of the last three columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N even and TRANSR = `N'.
-*
-* RFP A RFP A
-*
-* -- -- --
-* 03 04 05 33 43 53
-* -- --
-* 13 14 15 00 44 54
-* --
-* 23 24 25 10 11 55
-*
-* 33 34 35 20 21 22
-* --
-* 00 44 45 30 31 32
-* -- --
-* 01 11 55 40 41 42
-* -- -- --
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- -- --
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* -- -- -- -- -- -- -- -- -- --
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We next consider Standard Packed Format when N is odd.
-* We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = `N'. RFP holds AP as follows:
-* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* conjugate-transpose of the first two columns of AP upper.
-* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* conjugate-transpose of the last two columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N odd and TRANSR = `N'.
-*
-* RFP A RFP A
-*
-* -- --
-* 02 03 04 00 33 43
-* --
-* 12 13 14 10 11 44
-*
-* 22 23 24 20 21 22
-* --
-* 00 33 34 30 31 32
-* -- --
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- --
-* 02 12 22 00 01 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- --
-* 03 13 23 33 11 33 11 21 31 41 51
-* -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctrttp"></A>
- <H2>ctrttp</H2>
-
- <PRE>
-USAGE:
- ap, info = NumRu::Lapack.ctrttp( uplo, a)
- or
- NumRu::Lapack.ctrttp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO )
-
-* Purpose
-* =======
-*
-* CTRTTP copies a triangular matrix A from full format (TR) to standard
-* packed format (TP).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrices AP and A. N >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ctz.html b/doc/ctz.html
deleted file mode 100644
index 229c725..0000000
--- a/doc/ctz.html
+++ /dev/null
@@ -1,216 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for trapezoidal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for trapezoidal matrix</H1>
- <UL>
- <LI><A HREF="#ctzrqf">ctzrqf</A> : </LI>
- <LI><A HREF="#ctzrzf">ctzrzf</A> : </LI>
- </UL>
-
- <A NAME="ctzrqf"></A>
- <H2>ctzrqf</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.ctzrqf( a)
- or
- NumRu::Lapack.ctzrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine CTZRZF.
-*
-* CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
-* to upper triangular form by means of unitary transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N unitary matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* unitary matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), whose conjugate transpose is used to
-* introduce zeros into the (m - k + 1)th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ctzrzf"></A>
- <H2>ctzrzf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.ctzrzf( a, lwork)
- or
- NumRu::Lapack.ctzrzf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
-* to upper triangular form by means of unitary transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N unitary matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* unitary matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), which is used to introduce zeros into
-* the ( m - k + 1 )th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cun.html b/doc/cun.html
deleted file mode 100644
index a0ef7b0..0000000
--- a/doc/cun.html
+++ /dev/null
@@ -1,2630 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for (complex) unitary matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for (complex) unitary matrix</H1>
- <UL>
- <LI><A HREF="#cunbdb">cunbdb</A> : </LI>
- <LI><A HREF="#cuncsd">cuncsd</A> : </LI>
- <LI><A HREF="#cung2l">cung2l</A> : </LI>
- <LI><A HREF="#cung2r">cung2r</A> : </LI>
- <LI><A HREF="#cungbr">cungbr</A> : </LI>
- <LI><A HREF="#cunghr">cunghr</A> : </LI>
- <LI><A HREF="#cungl2">cungl2</A> : </LI>
- <LI><A HREF="#cunglq">cunglq</A> : </LI>
- <LI><A HREF="#cungql">cungql</A> : </LI>
- <LI><A HREF="#cungqr">cungqr</A> : </LI>
- <LI><A HREF="#cungr2">cungr2</A> : </LI>
- <LI><A HREF="#cungrq">cungrq</A> : </LI>
- <LI><A HREF="#cungtr">cungtr</A> : </LI>
- <LI><A HREF="#cunm2l">cunm2l</A> : </LI>
- <LI><A HREF="#cunm2r">cunm2r</A> : </LI>
- <LI><A HREF="#cunmbr">cunmbr</A> : </LI>
- <LI><A HREF="#cunmhr">cunmhr</A> : </LI>
- <LI><A HREF="#cunml2">cunml2</A> : </LI>
- <LI><A HREF="#cunmlq">cunmlq</A> : </LI>
- <LI><A HREF="#cunmql">cunmql</A> : </LI>
- <LI><A HREF="#cunmqr">cunmqr</A> : </LI>
- <LI><A HREF="#cunmr2">cunmr2</A> : </LI>
- <LI><A HREF="#cunmr3">cunmr3</A> : </LI>
- <LI><A HREF="#cunmrq">cunmrq</A> : </LI>
- <LI><A HREF="#cunmrz">cunmrz</A> : </LI>
- <LI><A HREF="#cunmtr">cunmtr</A> : </LI>
- </UL>
-
- <A NAME="cunbdb"></A>
- <H2>cunbdb</H2>
-
- <PRE>
-USAGE:
- theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.cunbdb( trans, signs, m, x11, x12, x21, x22, lwork)
- or
- NumRu::Lapack.cunbdb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNBDB simultaneously bidiagonalizes the blocks of an M-by-M
-* partitioned unitary matrix X:
-*
-* [ B11 | B12 0 0 ]
-* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H
-* X = [-----------] = [---------] [----------------] [---------] .
-* [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]
-* [ 0 | 0 0 I ]
-*
-* X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is
-* not the case, then X must be transposed and/or permuted. This can be
-* done in constant time using the TRANS and SIGNS options. See CUNCSD
-* for details.)
-*
-* The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-
-* (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are
-* represented implicitly by Householder vectors.
-*
-* B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented
-* implicitly by angles THETA, PHI.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <=
-* MIN(P,M-P,M-Q).
-*
-* X11 (input/output) COMPLEX array, dimension (LDX11,Q)
-* On entry, the top-left block of the unitary matrix to be
-* reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X11) specify reflectors for P1,
-* the rows of triu(X11,1) specify reflectors for Q1;
-* else TRANS = 'T', and
-* the rows of triu(X11) specify reflectors for P1,
-* the columns of tril(X11,-1) specify reflectors for Q1.
-*
-* LDX11 (input) INTEGER
-* The leading dimension of X11. If TRANS = 'N', then LDX11 >=
-* P; else LDX11 >= Q.
-*
-* X12 (input/output) CMPLX array, dimension (LDX12,M-Q)
-* On entry, the top-right block of the unitary matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X12) specify the first P reflectors for
-* Q2;
-* else TRANS = 'T', and
-* the columns of tril(X12) specify the first P reflectors
-* for Q2.
-*
-* LDX12 (input) INTEGER
-* The leading dimension of X12. If TRANS = 'N', then LDX12 >=
-* P; else LDX11 >= M-Q.
-*
-* X21 (input/output) COMPLEX array, dimension (LDX21,Q)
-* On entry, the bottom-left block of the unitary matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X21) specify reflectors for P2;
-* else TRANS = 'T', and
-* the rows of triu(X21) specify reflectors for P2.
-*
-* LDX21 (input) INTEGER
-* The leading dimension of X21. If TRANS = 'N', then LDX21 >=
-* M-P; else LDX21 >= Q.
-*
-* X22 (input/output) COMPLEX array, dimension (LDX22,M-Q)
-* On entry, the bottom-right block of the unitary matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last
-* M-P-Q reflectors for Q2,
-* else TRANS = 'T', and
-* the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last
-* M-P-Q reflectors for P2.
-*
-* LDX22 (input) INTEGER
-* The leading dimension of X22. If TRANS = 'N', then LDX22 >=
-* M-P; else LDX22 >= M-Q.
-*
-* THETA (output) REAL array, dimension (Q)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* PHI (output) REAL array, dimension (Q-1)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* TAUP1 (output) COMPLEX array, dimension (P)
-* The scalar factors of the elementary reflectors that define
-* P1.
-*
-* TAUP2 (output) COMPLEX array, dimension (M-P)
-* The scalar factors of the elementary reflectors that define
-* P2.
-*
-* TAUQ1 (output) COMPLEX array, dimension (Q)
-* The scalar factors of the elementary reflectors that define
-* Q1.
-*
-* TAUQ2 (output) COMPLEX array, dimension (M-Q)
-* The scalar factors of the elementary reflectors that define
-* Q2.
-*
-* WORK (workspace) COMPLEX array, dimension (LWORK)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= M-Q.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The bidiagonal blocks B11, B12, B21, and B22 are represented
-* implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,
-* PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are
-* lower bidiagonal. Every entry in each bidiagonal band is a product
-* of a sine or cosine of a THETA with a sine or cosine of a PHI. See
-* [1] or CUNCSD for details.
-*
-* P1, P2, Q1, and Q2 are represented as products of elementary
-* reflectors. See CUNCSD for details on generating P1, P2, Q1, and Q2
-* using CUNGQR and CUNGLQ.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cuncsd"></A>
- <H2>cuncsd</H2>
-
- <PRE>
-USAGE:
- theta, u1, u2, v1t, v2t, info = NumRu::Lapack.cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, ldu1, ldu2, ldv1t, ldv2t, lwork, lrwork)
- or
- NumRu::Lapack.cuncsd # print help
-
-
-FORTRAN MANUAL
- RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNCSD computes the CS decomposition of an M-by-M partitioned
-* unitary matrix X:
-*
-* [ I 0 0 | 0 0 0 ]
-* [ 0 C 0 | 0 -S 0 ]
-* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H
-* X = [-----------] = [---------] [---------------------] [---------] .
-* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]
-* [ 0 S 0 | 0 C 0 ]
-* [ 0 0 I | 0 0 0 ]
-*
-* X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
-* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
-* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
-* which R = MIN(P,M-P,Q,M-Q).
-*
-
-* Arguments
-* =========
-*
-* JOBU1 (input) CHARACTER
-* = 'Y': U1 is computed;
-* otherwise: U1 is not computed.
-*
-* JOBU2 (input) CHARACTER
-* = 'Y': U2 is computed;
-* otherwise: U2 is not computed.
-*
-* JOBV1T (input) CHARACTER
-* = 'Y': V1T is computed;
-* otherwise: V1T is not computed.
-*
-* JOBV2T (input) CHARACTER
-* = 'Y': V2T is computed;
-* otherwise: V2T is not computed.
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <= M.
-*
-* X (input/workspace) COMPLEX array, dimension (LDX,M)
-* On entry, the unitary matrix whose CSD is desired.
-*
-* LDX (input) INTEGER
-* The leading dimension of X. LDX >= MAX(1,M).
-*
-* THETA (output) REAL array, dimension (R), in which R =
-* MIN(P,M-P,Q,M-Q).
-* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
-* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
-*
-* U1 (output) COMPLEX array, dimension (P)
-* If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
-*
-* LDU1 (input) INTEGER
-* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
-* MAX(1,P).
-*
-* U2 (output) COMPLEX array, dimension (M-P)
-* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
-* matrix U2.
-*
-* LDU2 (input) INTEGER
-* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
-* MAX(1,M-P).
-*
-* V1T (output) COMPLEX array, dimension (Q)
-* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
-* matrix V1**H.
-*
-* LDV1T (input) INTEGER
-* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
-* MAX(1,Q).
-*
-* V2T (output) COMPLEX array, dimension (M-Q)
-* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary
-* matrix V2**H.
-*
-* LDV2T (input) INTEGER
-* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=
-* MAX(1,M-Q).
-*
-* WORK (workspace) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the work array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension MAX(1,LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-* If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
-* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
-* define the matrix in intermediate bidiagonal-block form
-* remaining after nonconvergence. INFO specifies the number
-* of nonzero PHI's.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-*
-* If LRWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the RWORK array, returns
-* this value as the first entry of the work array, and no error
-* message related to LRWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M-Q)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: CBBCSD did not converge. See the description of RWORK
-* above for details.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cung2l"></A>
- <H2>cung2l</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.cung2l( m, a, tau)
- or
- NumRu::Lapack.cung2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNG2L generates an m by n complex matrix Q with orthonormal columns,
-* which is defined as the last n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by CGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by CGEQLF in the last k columns of its array
-* argument A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQLF.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cung2r"></A>
- <H2>cung2r</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.cung2r( m, a, tau)
- or
- NumRu::Lapack.cung2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNG2R generates an m by n complex matrix Q with orthonormal columns,
-* which is defined as the first n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by CGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by CGEQRF in the first k columns of its array
-* argument A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQRF.
-*
-* WORK (workspace) COMPLEX array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cungbr"></A>
- <H2>cungbr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cungbr( vect, m, k, a, tau, lwork)
- or
- NumRu::Lapack.cungbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGBR generates one of the complex unitary matrices Q or P**H
-* determined by CGEBRD when reducing a complex matrix A to bidiagonal
-* form: A = Q * B * P**H. Q and P**H are defined as products of
-* elementary reflectors H(i) or G(i) respectively.
-*
-* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
-* is of order M:
-* if m >= k, Q = H(1) H(2) . . . H(k) and CUNGBR returns the first n
-* columns of Q, where m >= n >= k;
-* if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR returns Q as an
-* M-by-M matrix.
-*
-* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
-* is of order N:
-* if k < n, P**H = G(k) . . . G(2) G(1) and CUNGBR returns the first m
-* rows of P**H, where n >= m >= k;
-* if k >= n, P**H = G(n-1) . . . G(2) G(1) and CUNGBR returns P**H as
-* an N-by-N matrix.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether the matrix Q or the matrix P**H is
-* required, as defined in the transformation applied by CGEBRD:
-* = 'Q': generate Q;
-* = 'P': generate P**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q or P**H to be returned.
-* M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q or P**H to be returned.
-* N >= 0.
-* If VECT = 'Q', M >= N >= min(M,K);
-* if VECT = 'P', N >= M >= min(N,K).
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original M-by-K
-* matrix reduced by CGEBRD.
-* If VECT = 'P', the number of rows in the original K-by-N
-* matrix reduced by CGEBRD.
-* K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by CGEBRD.
-* On exit, the M-by-N matrix Q or P**H.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= M.
-*
-* TAU (input) COMPLEX array, dimension
-* (min(M,K)) if VECT = 'Q'
-* (min(N,K)) if VECT = 'P'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i), which determines Q or P**H, as
-* returned by CGEBRD in its array argument TAUQ or TAUP.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,min(M,N)).
-* For optimum performance LWORK >= min(M,N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunghr"></A>
- <H2>cunghr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cunghr( ilo, ihi, a, tau, lwork)
- or
- NumRu::Lapack.cunghr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGHR generates a complex unitary matrix Q which is defined as the
-* product of IHI-ILO elementary reflectors of order N, as returned by
-* CGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of CGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by CGEHRD.
-* On exit, the N-by-N unitary matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (input) COMPLEX array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEHRD.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= IHI-ILO.
-* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cungl2"></A>
- <H2>cungl2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.cungl2( a, tau)
- or
- NumRu::Lapack.cungl2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
-* which is defined as the first m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by CGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by CGELQF in the first k rows of its array argument A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGELQF.
-*
-* WORK (workspace) COMPLEX array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunglq"></A>
- <H2>cunglq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cunglq( m, a, tau, lwork)
- or
- NumRu::Lapack.cunglq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
-* which is defined as the first M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by CGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by CGELQF in the first k rows of its array argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGELQF.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit;
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cungql"></A>
- <H2>cungql</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cungql( m, a, tau, lwork)
- or
- NumRu::Lapack.cungql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
-* which is defined as the last N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by CGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by CGEQLF in the last k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQLF.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cungqr"></A>
- <H2>cungqr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cungqr( m, a, tau, lwork)
- or
- NumRu::Lapack.cungqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
-* which is defined as the first N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by CGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by CGEQRF in the first k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQRF.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cungr2"></A>
- <H2>cungr2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.cungr2( a, tau)
- or
- NumRu::Lapack.cungr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGR2 generates an m by n complex matrix Q with orthonormal rows,
-* which is defined as the last m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by CGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by CGERQF in the last k rows of its array argument
-* A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGERQF.
-*
-* WORK (workspace) COMPLEX array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cungrq"></A>
- <H2>cungrq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cungrq( m, a, tau, lwork)
- or
- NumRu::Lapack.cungrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,
-* which is defined as the last M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by CGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by CGERQF in the last k rows of its array argument
-* A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGERQF.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cungtr"></A>
- <H2>cungtr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.cungtr( uplo, a, tau, lwork)
- or
- NumRu::Lapack.cungtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNGTR generates a complex unitary matrix Q which is defined as the
-* product of n-1 elementary reflectors of order N, as returned by
-* CHETRD:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from CHETRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from CHETRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* A (input/output) COMPLEX array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by CHETRD.
-* On exit, the N-by-N unitary matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= N.
-*
-* TAU (input) COMPLEX array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CHETRD.
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= N-1.
-* For optimum performance LWORK >= (N-1)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunm2l"></A>
- <H2>cunm2l</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.cunm2l( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.cunm2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNM2L overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQLF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunm2r"></A>
- <H2>cunm2r</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.cunm2r( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.cunm2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNM2R overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQRF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmbr"></A>
- <H2>cunmbr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmbr( vect, side, trans, m, k, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': P * C C * P
-* TRANS = 'C': P**H * C C * P**H
-*
-* Here Q and P**H are the unitary matrices determined by CGEBRD when
-* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
-* and P**H are defined as products of elementary reflectors H(i) and
-* G(i) respectively.
-*
-* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
-* order of the unitary matrix Q or P**H that is applied.
-*
-* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
-* if nq >= k, Q = H(1) H(2) . . . H(k);
-* if nq < k, Q = H(1) H(2) . . . H(nq-1).
-*
-* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
-* if k < nq, P = G(1) G(2) . . . G(k);
-* if k >= nq, P = G(1) G(2) . . . G(nq-1).
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'Q': apply Q or Q**H;
-* = 'P': apply P or P**H.
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q, Q**H, P or P**H from the Left;
-* = 'R': apply Q, Q**H, P or P**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q or P;
-* = 'C': Conjugate transpose, apply Q**H or P**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original
-* matrix reduced by CGEBRD.
-* If VECT = 'P', the number of rows in the original
-* matrix reduced by CGEBRD.
-* K >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,min(nq,K)) if VECT = 'Q'
-* (LDA,nq) if VECT = 'P'
-* The vectors which define the elementary reflectors H(i) and
-* G(i), whose products determine the matrices Q and P, as
-* returned by CGEBRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If VECT = 'Q', LDA >= max(1,nq);
-* if VECT = 'P', LDA >= max(1,min(nq,K)).
-*
-* TAU (input) COMPLEX array, dimension (min(nq,K))
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i) which determines Q or P, as returned
-* by CGEBRD in the array argument TAUQ or TAUP.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
-* or P*C or P**H*C or C*P or C*P**H.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M);
-* if N = 0 or M = 0, LWORK >= 1.
-* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',
-* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the
-* optimal blocksize. (NB = 0 if M = 0 or N = 0.)
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
- CHARACTER TRANST
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CUNMLQ, CUNMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmhr"></A>
- <H2>cunmhr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmhr( side, trans, ilo, ihi, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmhr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMHR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* IHI-ILO elementary reflectors, as returned by CGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q**H (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of CGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
-* ILO = 1 and IHI = 0, if M = 0;
-* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
-* ILO = 1 and IHI = 0, if N = 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by CGEHRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) COMPLEX array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEHRD.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CUNMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunml2"></A>
- <H2>cunml2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.cunml2( side, trans, a, tau, c)
- or
- NumRu::Lapack.cunml2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNML2 overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGELQF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmlq"></A>
- <H2>cunmlq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmlq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmlq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMLQ overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGELQF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmql"></A>
- <H2>cunmql</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmql( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMQL overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQLF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmqr"></A>
- <H2>cunmqr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmqr( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMQR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGEQRF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmr2"></A>
- <H2>cunmr2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.cunmr2( side, trans, a, tau, c)
- or
- NumRu::Lapack.cunmr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMR2 overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGERQF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmr3"></A>
- <H2>cunmr3</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.cunmr3( side, trans, l, a, tau, c)
- or
- NumRu::Lapack.cunmr3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMR3 overwrites the general complex m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by CTZRZF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CTZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CTZRZF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, NOTRAN
- INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
- COMPLEX TAUI
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CLARZ, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC CONJG, MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmrq"></A>
- <H2>cunmrq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmrq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMRQ overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CGERQF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmrz"></A>
- <H2>cunmrz</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmrz( side, trans, l, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmrz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMRZ overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* CTZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CTZRZF.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cunmtr"></A>
- <H2>cunmtr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.cunmtr( side, uplo, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.cunmtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* CUNMTR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by CHETRD:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from CHETRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from CHETRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* A (input) COMPLEX array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by CHETRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) COMPLEX array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CHETRD.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >=M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, UPPER
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CUNMQL, CUNMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/cup.html b/doc/cup.html
deleted file mode 100644
index 940619e..0000000
--- a/doc/cup.html
+++ /dev/null
@@ -1,171 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX routines for (complex) unitary, packed storageBDbidiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX routines for (complex) unitary, packed storageBDbidiagonal matrix</H1>
- <UL>
- <LI><A HREF="#cupgtr">cupgtr</A> : </LI>
- <LI><A HREF="#cupmtr">cupmtr</A> : </LI>
- </UL>
-
- <A NAME="cupgtr"></A>
- <H2>cupgtr</H2>
-
- <PRE>
-USAGE:
- q, info = NumRu::Lapack.cupgtr( uplo, ap, tau)
- or
- NumRu::Lapack.cupgtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUPGTR generates a complex unitary matrix Q which is defined as the
-* product of n-1 elementary reflectors H(i) of order n, as returned by
-* CHPTRD using packed storage:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to CHPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to CHPTRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* AP (input) COMPLEX array, dimension (N*(N+1)/2)
-* The vectors which define the elementary reflectors, as
-* returned by CHPTRD.
-*
-* TAU (input) COMPLEX array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CHPTRD.
-*
-* Q (output) COMPLEX array, dimension (LDQ,N)
-* The N-by-N unitary matrix Q.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* WORK (workspace) COMPLEX array, dimension (N-1)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="cupmtr"></A>
- <H2>cupmtr</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.cupmtr( side, uplo, trans, m, ap, tau, c)
- or
- NumRu::Lapack.cupmtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* CUPMTR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by CHPTRD using packed
-* storage:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to CHPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to CHPTRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* AP (input) COMPLEX array, dimension
-* (M*(M+1)/2) if SIDE = 'L'
-* (N*(N+1)/2) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by CHPTRD. AP is modified by the routine but
-* restored on exit.
-*
-* TAU (input) COMPLEX array, dimension (M-1) if SIDE = 'L'
-* or (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by CHPTRD.
-*
-* C (input/output) COMPLEX array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX array, dimension
-* (N) if SIDE = 'L'
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="c.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/d.html b/doc/d.html
deleted file mode 100644
index 4b5115d..0000000
--- a/doc/d.html
+++ /dev/null
@@ -1,36 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines</TITLE>
- </HEAD>
- <BODY>
- <H1>DOUBLE PRECISION routines</H1>
- <UL>
- <LI><A HREF="dbd.html">BD: bidiagonal</A></LI>
- <LI><A HREF="ddi.html">DI: diagonal</A></LI>
- <LI><A HREF="dgb.html">GB: general band</A></LI>
- <LI><A HREF="dge.html">GE: general (i.e., unsymmetric, in some cases rectangular)</A></LI>
- <LI><A HREF="dgg.html">GG: general matrices, generalized problem (i.e., a pair of general matrices)</A></LI>
- <LI><A HREF="dgt.html">GT: general tridiagonal</A></LI>
- <LI><A HREF="dhg.html">HG: upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix)</A></LI>
- <LI><A HREF="dhs.html">HS: upper Hessenberg</A></LI>
- <LI><A HREF="dop.html">OP: (real) orthogonal, packed storage</A></LI>
- <LI><A HREF="dor.html">OR: (real) orthogonal</A></LI>
- <LI><A HREF="dpb.html">PB: symmetric or Hermitian positive definite band</A></LI>
- <LI><A HREF="dpo.html">PO: symmetric or Hermitian positive definite</A></LI>
- <LI><A HREF="dpp.html">PP: symmetric or Hermitian positive definite, packed storage</A></LI>
- <LI><A HREF="dpt.html">PT: symmetric or Hermitian positive definite tridiagonal</A></LI>
- <LI><A HREF="dsb.html">SB: (real) symmetric band</A></LI>
- <LI><A HREF="dsp.html">SP: symmetric, packed storage</A></LI>
- <LI><A HREF="dst.html">ST: (real) symmetric tridiagonal</A></LI>
- <LI><A HREF="dsy.html">SY: symmetric</A></LI>
- <LI><A HREF="dtb.html">TB: triangular band</A></LI>
- <LI><A HREF="dtg.html">TG: triangular matrices, generalized problem (i.e., a pair of triangular matrices)</A></LI>
- <LI><A HREF="dtp.html">TP: triangular, packed storage</A></LI>
- <LI><A HREF="dtr.html">TR: triangular (or in some cases quasi-triangular)</A></LI>
- <LI><A HREF="dtz.html">TZ: trapezoidal</A></LI>
- <LI><A HREF="dup.html">UP: (complex) unitary, packed storageBDbidiagonal</A></LI>
- </UL>
- <HR />
- <A HREF="index.html">back to data types</A>
- </BODY>
-</HTML>
diff --git a/doc/dbd.html b/doc/dbd.html
deleted file mode 100644
index f413cfc..0000000
--- a/doc/dbd.html
+++ /dev/null
@@ -1,309 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for bidiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for bidiagonal matrix</H1>
- <UL>
- <LI><A HREF="#dbdsdc">dbdsdc</A> : </LI>
- <LI><A HREF="#dbdsqr">dbdsqr</A> : </LI>
- </UL>
-
- <A NAME="dbdsdc"></A>
- <H2>dbdsdc</H2>
-
- <PRE>
-USAGE:
- u, vt, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, ldu, ldvt)
- or
- NumRu::Lapack.dbdsdc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DBDSDC computes the singular value decomposition (SVD) of a real
-* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
-* using a divide and conquer method, where S is a diagonal matrix
-* with non-negative diagonal elements (the singular values of B), and
-* U and VT are orthogonal matrices of left and right singular vectors,
-* respectively. DBDSDC can be used to compute all singular values,
-* and optionally, singular vectors or singular vectors in compact form.
-*
-* This code makes very mild assumptions about floating point
-* arithmetic. It will work on machines with a guard digit in
-* add/subtract, or on those binary machines without guard digits
-* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
-* It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none. See DLASD3 for details.
-*
-* The code currently calls DLASDQ if singular values only are desired.
-* However, it can be slightly modified to compute singular values
-* using the divide and conquer method.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': B is upper bidiagonal.
-* = 'L': B is lower bidiagonal.
-*
-* COMPQ (input) CHARACTER*1
-* Specifies whether singular vectors are to be computed
-* as follows:
-* = 'N': Compute singular values only;
-* = 'P': Compute singular values and compute singular
-* vectors in compact form;
-* = 'I': Compute singular values and singular vectors.
-*
-* N (input) INTEGER
-* The order of the matrix B. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the bidiagonal matrix B.
-* On exit, if INFO=0, the singular values of B.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the elements of E contain the offdiagonal
-* elements of the bidiagonal matrix whose SVD is desired.
-* On exit, E has been destroyed.
-*
-* U (output) DOUBLE PRECISION array, dimension (LDU,N)
-* If COMPQ = 'I', then:
-* On exit, if INFO = 0, U contains the left singular vectors
-* of the bidiagonal matrix.
-* For other values of COMPQ, U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1.
-* If singular vectors are desired, then LDU >= max( 1, N ).
-*
-* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
-* If COMPQ = 'I', then:
-* On exit, if INFO = 0, VT' contains the right singular
-* vectors of the bidiagonal matrix.
-* For other values of COMPQ, VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1.
-* If singular vectors are desired, then LDVT >= max( 1, N ).
-*
-* Q (output) DOUBLE PRECISION array, dimension (LDQ)
-* If COMPQ = 'P', then:
-* On exit, if INFO = 0, Q and IQ contain the left
-* and right singular vectors in a compact form,
-* requiring O(N log N) space instead of 2*N**2.
-* In particular, Q contains all the DOUBLE PRECISION data in
-* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
-* words of memory, where SMLSIZ is returned by ILAENV and
-* is equal to the maximum size of the subproblems at the
-* bottom of the computation tree (usually about 25).
-* For other values of COMPQ, Q is not referenced.
-*
-* IQ (output) INTEGER array, dimension (LDIQ)
-* If COMPQ = 'P', then:
-* On exit, if INFO = 0, Q and IQ contain the left
-* and right singular vectors in a compact form,
-* requiring O(N log N) space instead of 2*N**2.
-* In particular, IQ contains all INTEGER data in
-* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
-* words of memory, where SMLSIZ is returned by ILAENV and
-* is equal to the maximum size of the subproblems at the
-* bottom of the computation tree (usually about 25).
-* For other values of COMPQ, IQ is not referenced.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* If COMPQ = 'N' then LWORK >= (4 * N).
-* If COMPQ = 'P' then LWORK >= (6 * N).
-* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
-*
-* IWORK (workspace) INTEGER array, dimension (8*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The algorithm failed to compute a singular value.
-* The update process of divide and conquer failed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-* Changed dimension statement in comment describing E from (N) to
-* (N-1). Sven, 17 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dbdsqr"></A>
- <H2>dbdsqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, vt, u, c = NumRu::Lapack.dbdsqr( uplo, nru, d, e, vt, u, c)
- or
- NumRu::Lapack.dbdsqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DBDSQR computes the singular values and, optionally, the right and/or
-* left singular vectors from the singular value decomposition (SVD) of
-* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
-* zero-shift QR algorithm. The SVD of B has the form
-*
-* B = Q * S * P**T
-*
-* where S is the diagonal matrix of singular values, Q is an orthogonal
-* matrix of left singular vectors, and P is an orthogonal matrix of
-* right singular vectors. If left singular vectors are requested, this
-* subroutine actually returns U*Q instead of Q, and, if right singular
-* vectors are requested, this subroutine returns P**T*VT instead of
-* P**T, for given real input matrices U and VT. When U and VT are the
-* orthogonal matrices that reduce a general matrix A to bidiagonal
-* form: A = U*B*VT, as computed by DGEBRD, then
-*
-* A = (U*Q) * S * (P**T*VT)
-*
-* is the SVD of A. Optionally, the subroutine may also compute Q**T*C
-* for a given real input matrix C.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices With
-* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
-* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
-* no. 5, pp. 873-912, Sept 1990) and
-* "Accurate singular values and differential qd algorithms," by
-* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
-* Department, University of California at Berkeley, July 1992
-* for a detailed description of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': B is upper bidiagonal;
-* = 'L': B is lower bidiagonal.
-*
-* N (input) INTEGER
-* The order of the matrix B. N >= 0.
-*
-* NCVT (input) INTEGER
-* The number of columns of the matrix VT. NCVT >= 0.
-*
-* NRU (input) INTEGER
-* The number of rows of the matrix U. NRU >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the bidiagonal matrix B.
-* On exit, if INFO=0, the singular values of B in decreasing
-* order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the N-1 offdiagonal elements of the bidiagonal
-* matrix B.
-* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
-* will contain the diagonal and superdiagonal elements of a
-* bidiagonal matrix orthogonally equivalent to the one given
-* as input.
-*
-* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
-* On entry, an N-by-NCVT matrix VT.
-* On exit, VT is overwritten by P**T * VT.
-* Not referenced if NCVT = 0.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT.
-* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
-*
-* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
-* On entry, an NRU-by-N matrix U.
-* On exit, U is overwritten by U * Q.
-* Not referenced if NRU = 0.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,NRU).
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
-* On entry, an N-by-NCC matrix C.
-* On exit, C is overwritten by Q**T * C.
-* Not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0:
-* if NCVT = NRU = NCC = 0,
-* = 1, a split was marked by a positive value in E
-* = 2, current block of Z not diagonalized after 30*N
-* iterations (in inner while loop)
-* = 3, termination criterion of outer while loop not met
-* (program created more than N unreduced blocks)
-* else NCVT = NRU = NCC = 0,
-* the algorithm did not converge; D and E contain the
-* elements of a bidiagonal matrix which is orthogonally
-* similar to the input matrix B; if INFO = i, i
-* elements of E have not converged to zero.
-*
-* Internal Parameters
-* ===================
-*
-* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
-* TOLMUL controls the convergence criterion of the QR loop.
-* If it is positive, TOLMUL*EPS is the desired relative
-* precision in the computed singular values.
-* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
-* desired absolute accuracy in the computed singular
-* values (corresponds to relative accuracy
-* abs(TOLMUL*EPS) in the largest singular value.
-* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
-* between 10 (for fast convergence) and .1/EPS
-* (for there to be some accuracy in the results).
-* Default is to lose at either one eighth or 2 of the
-* available decimal digits in each computed singular value
-* (whichever is smaller).
-*
-* MAXITR INTEGER, default = 6
-* MAXITR controls the maximum number of passes of the
-* algorithm through its inner loop. The algorithms stops
-* (and so fails to converge) if the number of passes
-* through the inner loop exceeds MAXITR*N**2.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ddi.html b/doc/ddi.html
deleted file mode 100644
index 76494b8..0000000
--- a/doc/ddi.html
+++ /dev/null
@@ -1,89 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for diagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for diagonal matrix</H1>
- <UL>
- <LI><A HREF="#ddisna">ddisna</A> : </LI>
- </UL>
-
- <A NAME="ddisna"></A>
- <H2>ddisna</H2>
-
- <PRE>
-USAGE:
- sep, info = NumRu::Lapack.ddisna( job, n, d)
- or
- NumRu::Lapack.ddisna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )
-
-* Purpose
-* =======
-*
-* DDISNA computes the reciprocal condition numbers for the eigenvectors
-* of a real symmetric or complex Hermitian matrix or for the left or
-* right singular vectors of a general m-by-n matrix. The reciprocal
-* condition number is the 'gap' between the corresponding eigenvalue or
-* singular value and the nearest other one.
-*
-* The bound on the error, measured by angle in radians, in the I-th
-* computed vector is given by
-*
-* DLAMCH( 'E' ) * ( ANORM / SEP( I ) )
-*
-* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed
-* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of
-* the error bound.
-*
-* DDISNA may also be used to compute error bounds for eigenvectors of
-* the generalized symmetric definite eigenproblem.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies for which problem the reciprocal condition numbers
-* should be computed:
-* = 'E': the eigenvectors of a symmetric/Hermitian matrix;
-* = 'L': the left singular vectors of a general matrix;
-* = 'R': the right singular vectors of a general matrix.
-*
-* M (input) INTEGER
-* The number of rows of the matrix. M >= 0.
-*
-* N (input) INTEGER
-* If JOB = 'L' or 'R', the number of columns of the matrix,
-* in which case N >= 0. Ignored if JOB = 'E'.
-*
-* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
-* dimension (min(M,N)) if JOB = 'L' or 'R'
-* The eigenvalues (if JOB = 'E') or singular values (if JOB =
-* 'L' or 'R') of the matrix, in either increasing or decreasing
-* order. If singular values, they must be non-negative.
-*
-* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
-* dimension (min(M,N)) if JOB = 'L' or 'R'
-* The reciprocal condition numbers of the vectors.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dgb.html b/doc/dgb.html
deleted file mode 100644
index c8000aa..0000000
--- a/doc/dgb.html
+++ /dev/null
@@ -1,1892 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for general band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for general band matrix</H1>
- <UL>
- <LI><A HREF="#dgbbrd">dgbbrd</A> : </LI>
- <LI><A HREF="#dgbcon">dgbcon</A> : </LI>
- <LI><A HREF="#dgbequ">dgbequ</A> : </LI>
- <LI><A HREF="#dgbequb">dgbequb</A> : </LI>
- <LI><A HREF="#dgbrfs">dgbrfs</A> : </LI>
- <LI><A HREF="#dgbrfsx">dgbrfsx</A> : </LI>
- <LI><A HREF="#dgbsv">dgbsv</A> : </LI>
- <LI><A HREF="#dgbsvx">dgbsvx</A> : </LI>
- <LI><A HREF="#dgbsvxx">dgbsvxx</A> : </LI>
- <LI><A HREF="#dgbtf2">dgbtf2</A> : </LI>
- <LI><A HREF="#dgbtrf">dgbtrf</A> : </LI>
- <LI><A HREF="#dgbtrs">dgbtrs</A> : </LI>
- </UL>
-
- <A NAME="dgbbrd"></A>
- <H2>dgbbrd</H2>
-
- <PRE>
-USAGE:
- d, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c)
- or
- NumRu::Lapack.dgbbrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGBBRD reduces a real general m-by-n band matrix A to upper
-* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
-*
-* The routine computes B, and optionally forms Q or P', or computes
-* Q'*C for a given matrix C.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether or not the matrices Q and P' are to be
-* formed.
-* = 'N': do not form Q or P';
-* = 'Q': form Q only;
-* = 'P': form P' only;
-* = 'B': form both.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals of the matrix A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals of the matrix A. KU >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the m-by-n band matrix A, stored in rows 1 to
-* KL+KU+1. The j-th column of A is stored in the j-th column of
-* the array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-* On exit, A is overwritten by values generated during the
-* reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KL+KU+1.
-*
-* D (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B.
-*
-* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
-* The superdiagonal elements of the bidiagonal matrix B.
-*
-* Q (output) DOUBLE PRECISION array, dimension (LDQ,M)
-* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
-* If VECT = 'N' or 'P', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
-*
-* PT (output) DOUBLE PRECISION array, dimension (LDPT,N)
-* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
-* If VECT = 'N' or 'Q', the array PT is not referenced.
-*
-* LDPT (input) INTEGER
-* The leading dimension of the array PT.
-* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)
-* On entry, an m-by-ncc matrix C.
-* On exit, C is overwritten by Q'*C.
-* C is not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbcon"></A>
- <H2>dgbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dgbcon( norm, kl, ku, ab, ipiv, anorm)
- or
- NumRu::Lapack.dgbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGBCON estimates the reciprocal of the condition number of a real
-* general band matrix A, in either the 1-norm or the infinity-norm,
-* using the LU factorization computed by DGBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* ANORM (input) DOUBLE PRECISION
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbequ"></A>
- <H2>dgbequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequ( m, kl, ku, ab)
- or
- NumRu::Lapack.dgbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DGBEQU computes row and column scalings intended to equilibrate an
-* M-by-N band matrix A and reduce its condition number. R returns the
-* row scale factors and C the column scale factors, chosen to try to
-* make the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
-* column of A is stored in the j-th column of the array AB as
-* follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0, or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbequb"></A>
- <H2>dgbequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequb( kl, ku, ab)
- or
- NumRu::Lapack.dgbequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DGBEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from DGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= max(1,M).
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbrfs"></A>
- <H2>dgbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)
- or
- NumRu::Lapack.dgbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is banded, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from DGBTRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbrfsx"></A>
- <H2>dgbrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.dgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.dgbrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGBRFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from DGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbsv"></A>
- <H2>dgbsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab, b = NumRu::Lapack.dgbsv( kl, ku, ab, b)
- or
- NumRu::Lapack.dgbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DGBSV computes the solution to a real system of linear equations
-* A * X = B, where A is a band matrix of order N with KL subdiagonals
-* and KU superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as A = L * U, where L is a product of permutation
-* and unit lower triangular matrices with KL subdiagonals, and U is
-* upper triangular with KL+KU superdiagonals. The factored form of A
-* is then used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL DGBTRF, DGBTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbsvx"></A>
- <H2>dgbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.dgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.dgbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGBSVX uses the LU factorization to compute the solution to a real
-* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
-* where A is a band matrix of order N with KL subdiagonals and KU
-* superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed by this subroutine:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = L * U,
-* where L is a product of permutation and unit lower triangular
-* matrices with KL subdiagonals, and U is upper triangular with
-* KL+KU superdiagonals.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB and IPIV contain the factored form of
-* A. If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* AB, AFB, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then A must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by DGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns details of the LU factorization of A.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns details of the LU factorization of the equilibrated
-* matrix A (see the description of AB for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = L*U
-* as computed by DGBTRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N)
-* On exit, WORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If WORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* WORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbsvxx"></A>
- <H2>dgbsvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.dgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.dgbsvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGBSVXX uses the LU factorization to compute the solution to a
-* double precision system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. DGBSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* DGBSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* DGBSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what DGBSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose = Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then AB must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by DGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by DGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In DGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbtf2"></A>
- <H2>dgbtf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.dgbtf2( m, kl, ku, ab)
- or
- NumRu::Lapack.dgbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DGBTF2 computes an LU factorization of a real m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U, because of fill-in resulting from the row
-* interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbtrf"></A>
- <H2>dgbtrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.dgbtrf( m, kl, ku, ab)
- or
- NumRu::Lapack.dgbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DGBTRF computes an LU factorization of a real m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgbtrs"></A>
- <H2>dgbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dgbtrs( trans, kl, ku, ab, ipiv, b)
- or
- NumRu::Lapack.dgbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DGBTRS solves a system of linear equations
-* A * X = B or A' * X = B
-* with a general band matrix A using the LU factorization computed
-* by DGBTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A'* X = B (Transpose)
-* = 'C': A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dge.html b/doc/dge.html
deleted file mode 100644
index cd8b2e7..0000000
--- a/doc/dge.html
+++ /dev/null
@@ -1,7407 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for general (i.e., unsymmetric, in some cases rectangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for general (i.e., unsymmetric, in some cases rectangular) matrix</H1>
- <UL>
- <LI><A HREF="#dgebak">dgebak</A> : </LI>
- <LI><A HREF="#dgebal">dgebal</A> : </LI>
- <LI><A HREF="#dgebd2">dgebd2</A> : </LI>
- <LI><A HREF="#dgebrd">dgebrd</A> : </LI>
- <LI><A HREF="#dgecon">dgecon</A> : </LI>
- <LI><A HREF="#dgeequ">dgeequ</A> : </LI>
- <LI><A HREF="#dgeequb">dgeequb</A> : </LI>
- <LI><A HREF="#dgees">dgees</A> : </LI>
- <LI><A HREF="#dgeesx">dgeesx</A> : </LI>
- <LI><A HREF="#dgeev">dgeev</A> : </LI>
- <LI><A HREF="#dgeevx">dgeevx</A> : </LI>
- <LI><A HREF="#dgegs">dgegs</A> : </LI>
- <LI><A HREF="#dgegv">dgegv</A> : </LI>
- <LI><A HREF="#dgehd2">dgehd2</A> : </LI>
- <LI><A HREF="#dgehrd">dgehrd</A> : </LI>
- <LI><A HREF="#dgejsv">dgejsv</A> : </LI>
- <LI><A HREF="#dgelq2">dgelq2</A> : </LI>
- <LI><A HREF="#dgelqf">dgelqf</A> : </LI>
- <LI><A HREF="#dgels">dgels</A> : </LI>
- <LI><A HREF="#dgelsd">dgelsd</A> : </LI>
- <LI><A HREF="#dgelss">dgelss</A> : </LI>
- <LI><A HREF="#dgelsx">dgelsx</A> : </LI>
- <LI><A HREF="#dgelsy">dgelsy</A> : </LI>
- <LI><A HREF="#dgeql2">dgeql2</A> : </LI>
- <LI><A HREF="#dgeqlf">dgeqlf</A> : </LI>
- <LI><A HREF="#dgeqp3">dgeqp3</A> : </LI>
- <LI><A HREF="#dgeqpf">dgeqpf</A> : </LI>
- <LI><A HREF="#dgeqr2">dgeqr2</A> : </LI>
- <LI><A HREF="#dgeqr2p">dgeqr2p</A> : </LI>
- <LI><A HREF="#dgeqrf">dgeqrf</A> : </LI>
- <LI><A HREF="#dgeqrfp">dgeqrfp</A> : </LI>
- <LI><A HREF="#dgerfs">dgerfs</A> : </LI>
- <LI><A HREF="#dgerfsx">dgerfsx</A> : </LI>
- <LI><A HREF="#dgerq2">dgerq2</A> : </LI>
- <LI><A HREF="#dgerqf">dgerqf</A> : </LI>
- <LI><A HREF="#dgesc2">dgesc2</A> : </LI>
- <LI><A HREF="#dgesdd">dgesdd</A> : </LI>
- <LI><A HREF="#dgesv">dgesv</A> : </LI>
- <LI><A HREF="#dgesvd">dgesvd</A> : </LI>
- <LI><A HREF="#dgesvj">dgesvj</A> : </LI>
- <LI><A HREF="#dgesvx">dgesvx</A> : </LI>
- <LI><A HREF="#dgesvxx">dgesvxx</A> : </LI>
- <LI><A HREF="#dgetc2">dgetc2</A> : </LI>
- <LI><A HREF="#dgetf2">dgetf2</A> : </LI>
- <LI><A HREF="#dgetrf">dgetrf</A> : </LI>
- <LI><A HREF="#dgetri">dgetri</A> : </LI>
- <LI><A HREF="#dgetrs">dgetrs</A> : </LI>
- </UL>
-
- <A NAME="dgebak"></A>
- <H2>dgebak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.dgebak( job, side, ilo, ihi, scale, v)
- or
- NumRu::Lapack.dgebak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* DGEBAK forms the right or left eigenvectors of a real general matrix
-* by backward transformation on the computed eigenvectors of the
-* balanced matrix output by DGEBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N', do nothing, return immediately;
-* = 'P', do backward transformation for permutation only;
-* = 'S', do backward transformation for scaling only;
-* = 'B', do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to DGEBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by DGEBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* SCALE (input) DOUBLE PRECISION array, dimension (N)
-* Details of the permutation and scaling factors, as returned
-* by DGEBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by DHSEIN or DTREVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgebal"></A>
- <H2>dgebal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, scale, info, a = NumRu::Lapack.dgebal( job, a)
- or
- NumRu::Lapack.dgebal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* DGEBAL balances a general real matrix A. This involves, first,
-* permuting A by a similarity transformation to isolate eigenvalues
-* in the first 1 to ILO-1 and last IHI+1 to N elements on the
-* diagonal; and second, applying a diagonal similarity transformation
-* to rows and columns ILO to IHI to make the rows and columns as
-* close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrix, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A:
-* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
-* for i = 1,...,N;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* SCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied to
-* A. If P(j) is the index of the row and column interchanged
-* with row and column j and D(j) is the scaling factor
-* applied to row and column j, then
-* SCALE(j) = P(j) for j = 1,...,ILO-1
-* = D(j) for j = ILO,...,IHI
-* = P(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The permutations consist of row and column interchanges which put
-* the matrix in the form
-*
-* ( T1 X Y )
-* P A P = ( 0 B Z )
-* ( 0 0 T2 )
-*
-* where T1 and T2 are upper triangular matrices whose eigenvalues lie
-* along the diagonal. The column indices ILO and IHI mark the starting
-* and ending columns of the submatrix B. Balancing consists of applying
-* a diagonal similarity transformation inv(D) * B * D to make the
-* 1-norms of each row of B and its corresponding column nearly equal.
-* The output matrix is
-*
-* ( T1 X*D Y )
-* ( 0 inv(D)*B*D inv(D)*Z ).
-* ( 0 0 T2 )
-*
-* Information about the permutations P and the diagonal matrix D is
-* returned in the vector SCALE.
-*
-* This subroutine is based on the EISPACK routine BALANC.
-*
-* Modified by Tzu-Yi Chen, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgebd2"></A>
- <H2>dgebd2</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, info, a = NumRu::Lapack.dgebd2( m, a)
- or
- NumRu::Lapack.dgebd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEBD2 reduces a real general m by n matrix A to upper or lower
-* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the m by n general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the orthogonal matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the orthogonal matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q. See Further Details.
-*
-* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix P. See Further Details.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
-* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
-* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgebrd"></A>
- <H2>dgebrd</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, work, info, a = NumRu::Lapack.dgebrd( m, a, lwork)
- or
- NumRu::Lapack.dgebrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEBRD reduces a general real M-by-N matrix A to upper or lower
-* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the orthogonal matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the orthogonal matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q. See Further Details.
-*
-* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix P. See Further Details.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,M,N).
-* For optimum performance LWORK >= (M+N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
-* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
-* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgecon"></A>
- <H2>dgecon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dgecon( norm, a, anorm)
- or
- NumRu::Lapack.dgecon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGECON estimates the reciprocal of the condition number of a general
-* real matrix A, in either the 1-norm or the infinity-norm, using
-* the LU factorization computed by DGETRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by DGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) DOUBLE PRECISION
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeequ"></A>
- <H2>dgeequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequ( a)
- or
- NumRu::Lapack.dgeequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DGEEQU computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeequb"></A>
- <H2>dgeequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequb( a)
- or
- NumRu::Lapack.dgeequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DGEEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from DGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgees"></A>
- <H2>dgees</H2>
-
- <PRE>
-USAGE:
- sdim, wr, wi, vs, work, info, a = NumRu::Lapack.dgees( jobvs, sort, a, lwork){|a,b| ... }
- or
- NumRu::Lapack.dgees # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEES computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues, the real Schur form T, and, optionally, the matrix of
-* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* real Schur form so that selected eigenvalues are at the top left.
-* The leading columns of Z then form an orthonormal basis for the
-* invariant subspace corresponding to the selected eigenvalues.
-*
-* A matrix is in real Schur form if it is upper quasi-triangular with
-* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
-* form
-* [ a b ]
-* [ c a ]
-*
-* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* If SORT = 'N', SELECT is not referenced.
-* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
-* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
-* conjugate pair of eigenvalues is selected, then both complex
-* eigenvalues are selected.
-* Note that a selected complex eigenvalue may no longer
-* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned); in this
-* case INFO is set to N+2 (see INFO below).
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten by its real Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELECT is true. (Complex conjugate
-* pairs for which SELECT is true for either
-* eigenvalue count as 2.)
-*
-* WR (output) DOUBLE PRECISION array, dimension (N)
-* WI (output) DOUBLE PRECISION array, dimension (N)
-* WR and WI contain the real and imaginary parts,
-* respectively, of the computed eigenvalues in the same order
-* that they appear on the diagonal of the output Schur form T.
-* Complex conjugate pairs of eigenvalues will appear
-* consecutively with the eigenvalue having the positive
-* imaginary part first.
-*
-* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1; if
-* JOBVS = 'V', LDVS >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,3*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
-* contain those eigenvalues which have converged; if
-* JOBVS = 'V', VS contains the matrix which reduces A
-* to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because some
-* eigenvalues were too close to separate (the problem
-* is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of some
-* complex eigenvalues so that leading eigenvalues in
-* the Schur form no longer satisfy SELECT=.TRUE. This
-* could also be caused by underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeesx"></A>
- <H2>dgeesx</H2>
-
- <PRE>
-USAGE:
- sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.dgeesx( jobvs, sort, sense, a, lwork, liwork){|a,b| ... }
- or
- NumRu::Lapack.dgeesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEESX computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues, the real Schur form T, and, optionally, the matrix of
-* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* real Schur form so that selected eigenvalues are at the top left;
-* computes a reciprocal condition number for the average of the
-* selected eigenvalues (RCONDE); and computes a reciprocal condition
-* number for the right invariant subspace corresponding to the
-* selected eigenvalues (RCONDV). The leading columns of Z form an
-* orthonormal basis for this invariant subspace.
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
-* these quantities are called s and sep respectively).
-*
-* A real matrix is in real Schur form if it is upper quasi-triangular
-* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
-* the form
-* [ a b ]
-* [ c a ]
-*
-* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* If SORT = 'N', SELECT is not referenced.
-* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
-* SELECT(WR(j),WI(j)) is true; i.e., if either one of a
-* complex conjugate pair of eigenvalues is selected, then both
-* are. Note that a selected complex eigenvalue may no longer
-* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned); in this
-* case INFO may be set to N+3 (see INFO below).
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for average of selected eigenvalues only;
-* = 'V': Computed for selected right invariant subspace only;
-* = 'B': Computed for both.
-* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the N-by-N matrix A.
-* On exit, A is overwritten by its real Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELECT is true. (Complex conjugate
-* pairs for which SELECT is true for either
-* eigenvalue count as 2.)
-*
-* WR (output) DOUBLE PRECISION array, dimension (N)
-* WI (output) DOUBLE PRECISION array, dimension (N)
-* WR and WI contain the real and imaginary parts, respectively,
-* of the computed eigenvalues, in the same order that they
-* appear on the diagonal of the output Schur form T. Complex
-* conjugate pairs of eigenvalues appear consecutively with the
-* eigenvalue having the positive imaginary part first.
-*
-* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1, and if
-* JOBVS = 'V', LDVS >= N.
-*
-* RCONDE (output) DOUBLE PRECISION
-* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
-* condition number for the average of the selected eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) DOUBLE PRECISION
-* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
-* condition number for the selected right invariant subspace.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,3*N).
-* Also, if SENSE = 'E' or 'V' or 'B',
-* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
-* selected eigenvalues computed by this routine. Note that
-* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
-* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
-* 'B' this may not be large enough.
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates upper bounds on the optimal sizes of the
-* arrays WORK and IWORK, returns these values as the first
-* entries of the WORK and IWORK arrays, and no error messages
-* related to LWORK or LIWORK are issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
-* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
-* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
-* may not be large enough.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates upper bounds on the optimal sizes of
-* the arrays WORK and IWORK, returns these values as the first
-* entries of the WORK and IWORK arrays, and no error messages
-* related to LWORK or LIWORK are issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
-* contain those eigenvalues which have converged; if
-* JOBVS = 'V', VS contains the transformation which
-* reduces A to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because some
-* eigenvalues were too close to separate (the problem
-* is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of some
-* complex eigenvalues so that leading eigenvalues in
-* the Schur form no longer satisfy SELECT=.TRUE. This
-* could also be caused by underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeev"></A>
- <H2>dgeev</H2>
-
- <PRE>
-USAGE:
- wr, wi, vl, vr, work, info, a = NumRu::Lapack.dgeev( jobvl, jobvr, a, lwork)
- or
- NumRu::Lapack.dgeev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEEV computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of A are computed.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* WR (output) DOUBLE PRECISION array, dimension (N)
-* WI (output) DOUBLE PRECISION array, dimension (N)
-* WR and WI contain the real and imaginary parts,
-* respectively, of the computed eigenvalues. Complex
-* conjugate pairs of eigenvalues appear consecutively
-* with the eigenvalue having the positive imaginary part
-* first.
-*
-* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* If the j-th eigenvalue is real, then u(j) = VL(:,j),
-* the j-th column of VL.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
-* u(j+1) = VL(:,j) - i*VL(:,j+1).
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* If the j-th eigenvalue is real, then v(j) = VR(:,j),
-* the j-th column of VR.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
-* v(j+1) = VR(:,j) - i*VR(:,j+1).
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1; if
-* JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,3*N), and
-* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
-* performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors have been computed;
-* elements i+1:N of WR and WI contain eigenvalues which
-* have converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeevx"></A>
- <H2>dgeevx</H2>
-
- <PRE>
-USAGE:
- wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.dgeevx( balanc, jobvl, jobvr, sense, a, lwork)
- or
- NumRu::Lapack.dgeevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* Optionally also, it computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
-* (RCONDE), and reciprocal condition numbers for the right
-* eigenvectors (RCONDV).
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-* Balancing a matrix means permuting the rows and columns to make it
-* more nearly upper triangular, and applying a diagonal similarity
-* transformation D * A * D**(-1), where D is a diagonal matrix, to
-* make its rows and columns closer in norm and the condition numbers
-* of its eigenvalues and eigenvectors smaller. The computed
-* reciprocal condition numbers correspond to the balanced matrix.
-* Permuting rows and columns will not change the condition numbers
-* (in exact arithmetic) but diagonal scaling will. For further
-* explanation of balancing, see section 4.10.2 of the LAPACK
-* Users' Guide.
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Indicates how the input matrix should be diagonally scaled
-* and/or permuted to improve the conditioning of its
-* eigenvalues.
-* = 'N': Do not diagonally scale or permute;
-* = 'P': Perform permutations to make the matrix more nearly
-* upper triangular. Do not diagonally scale;
-* = 'S': Diagonally scale the matrix, i.e. replace A by
-* D*A*D**(-1), where D is a diagonal matrix chosen
-* to make the rows and columns of A more equal in
-* norm. Do not permute;
-* = 'B': Both diagonally scale and permute A.
-*
-* Computed reciprocal condition numbers will be for the matrix
-* after balancing and/or permuting. Permuting does not change
-* condition numbers (in exact arithmetic), but balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVL must = 'V'.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVR must = 'V'.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for eigenvalues only;
-* = 'V': Computed for right eigenvectors only;
-* = 'B': Computed for eigenvalues and right eigenvectors.
-*
-* If SENSE = 'E' or 'B', both left and right eigenvectors
-* must also be computed (JOBVL = 'V' and JOBVR = 'V').
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten. If JOBVL = 'V' or
-* JOBVR = 'V', A contains the real Schur form of the balanced
-* version of the input matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* WR (output) DOUBLE PRECISION array, dimension (N)
-* WI (output) DOUBLE PRECISION array, dimension (N)
-* WR and WI contain the real and imaginary parts,
-* respectively, of the computed eigenvalues. Complex
-* conjugate pairs of eigenvalues will appear consecutively
-* with the eigenvalue having the positive imaginary part
-* first.
-*
-* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* If the j-th eigenvalue is real, then u(j) = VL(:,j),
-* the j-th column of VL.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
-* u(j+1) = VL(:,j) - i*VL(:,j+1).
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* If the j-th eigenvalue is real, then v(j) = VR(:,j),
-* the j-th column of VR.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
-* v(j+1) = VR(:,j) - i*VR(:,j+1).
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values determined when A was
-* balanced. The balanced A(i,j) = 0 if I > J and
-* J = 1,...,ILO-1 or I = IHI+1,...,N.
-*
-* SCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* when balancing A. If P(j) is the index of the row and column
-* interchanged with row and column j, and D(j) is the scaling
-* factor applied to row and column j, then
-* SCALE(J) = P(J), for J = 1,...,ILO-1
-* = D(J), for J = ILO,...,IHI
-* = P(J) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) DOUBLE PRECISION
-* The one-norm of the balanced matrix (the maximum
-* of the sum of absolute values of elements of any column).
-*
-* RCONDE (output) DOUBLE PRECISION array, dimension (N)
-* RCONDE(j) is the reciprocal condition number of the j-th
-* eigenvalue.
-*
-* RCONDV (output) DOUBLE PRECISION array, dimension (N)
-* RCONDV(j) is the reciprocal condition number of the j-th
-* right eigenvector.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. If SENSE = 'N' or 'E',
-* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
-* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (2*N-2)
-* If SENSE = 'N' or 'E', not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors or condition numbers
-* have been computed; elements 1:ILO-1 and i+1:N of WR
-* and WI contain eigenvalues which have converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgegs"></A>
- <H2>dgegs</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgegs( jobvsl, jobvsr, a, b, lwork)
- or
- NumRu::Lapack.dgegs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine DGGES.
-*
-* DGEGS computes the eigenvalues, real Schur form, and, optionally,
-* left and or/right Schur vectors of a real matrix pair (A,B).
-* Given two square matrices A and B, the generalized real Schur
-* factorization has the form
-*
-* A = Q*S*Z**T, B = Q*T*Z**T
-*
-* where Q and Z are orthogonal matrices, T is upper triangular, and S
-* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal
-* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs
-* of eigenvalues of (A,B). The columns of Q are the left Schur vectors
-* and the columns of Z are the right Schur vectors.
-*
-* If only the eigenvalues of (A,B) are needed, the driver routine
-* DGEGV should be used instead. See DGEGV for a description of the
-* eigenvalues of the generalized nonsymmetric eigenvalue problem
-* (GNEP).
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors (returned in VSL).
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors (returned in VSR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the matrix A.
-* On exit, the upper quasi-triangular matrix S from the
-* generalized real Schur factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the matrix B.
-* On exit, the upper triangular matrix T from the generalized
-* real Schur factorization.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* The real parts of each scalar alpha defining an eigenvalue
-* of GNEP.
-*
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* The imaginary parts of each scalar alpha defining an
-* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
-* eigenvalue is real; if positive, then the j-th and (j+1)-st
-* eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) = -ALPHAI(j).
-*
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* The scalars beta that define the eigenvalues of GNEP.
-* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
-* beta = BETA(j) represent the j-th eigenvalue of the matrix
-* pair (A,B), in one of the forms lambda = alpha/beta or
-* mu = beta/alpha. Since either lambda or mu may overflow,
-* they should not, in general, be computed.
-*
-* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
-* If JOBVSL = 'V', the matrix of left Schur vectors Q.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
-* If JOBVSR = 'V', the matrix of right Schur vectors Z.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,4*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:
-* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR
-* The optimal LWORK is 2*N + N*(NB+1).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
-* be correct for j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from DGGBAL
-* =N+2: error return from DGEQRF
-* =N+3: error return from DORMQR
-* =N+4: error return from DORGQR
-* =N+5: error return from DGGHRD
-* =N+6: error return from DHGEQZ (other than failed
-* iteration)
-* =N+7: error return from DGGBAK (computing VSL)
-* =N+8: error return from DGGBAK (computing VSR)
-* =N+9: error return from DLASCL (various places)
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgegv"></A>
- <H2>dgegv</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dgegv( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.dgegv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine DGGEV.
-*
-* DGEGV computes the eigenvalues and, optionally, the left and/or right
-* eigenvectors of a real matrix pair (A,B).
-* Given two square matrices A and B,
-* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
-* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
-* that
-*
-* A*x = lambda*B*x.
-*
-* An alternate form is to find the eigenvalues mu and corresponding
-* eigenvectors y such that
-*
-* mu*A*y = B*y.
-*
-* These two forms are equivalent with mu = 1/lambda and x = y if
-* neither lambda nor mu is zero. In order to deal with the case that
-* lambda or mu is zero or small, two values alpha and beta are returned
-* for each eigenvalue, such that lambda = alpha/beta and
-* mu = beta/alpha.
-*
-* The vectors x and y in the above equations are right eigenvectors of
-* the matrix pair (A,B). Vectors u and v satisfying
-*
-* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
-*
-* are left eigenvectors of (A,B).
-*
-* Note: this routine performs "full balancing" on A and B -- see
-* "Further Details", below.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors (returned
-* in VL).
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors (returned
-* in VR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the matrix A.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit A
-* contains the real Schur form of A from the generalized Schur
-* factorization of the pair (A,B) after balancing.
-* If no eigenvectors were computed, then only the diagonal
-* blocks from the Schur form will be correct. See DGGHRD and
-* DHGEQZ for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the matrix B.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
-* upper triangular matrix obtained from B in the generalized
-* Schur factorization of the pair (A,B) after balancing.
-* If no eigenvectors were computed, then only those elements of
-* B corresponding to the diagonal blocks from the Schur form of
-* A will be correct. See DGGHRD and DHGEQZ for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* The real parts of each scalar alpha defining an eigenvalue of
-* GNEP.
-*
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* The imaginary parts of each scalar alpha defining an
-* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
-* eigenvalue is real; if positive, then the j-th and
-* (j+1)-st eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) = -ALPHAI(j).
-*
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* The scalars beta that define the eigenvalues of GNEP.
-*
-* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
-* beta = BETA(j) represent the j-th eigenvalue of the matrix
-* pair (A,B), in one of the forms lambda = alpha/beta or
-* mu = beta/alpha. Since either lambda or mu may overflow,
-* they should not, in general, be computed.
-*
-* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored
-* in the columns of VL, in the same order as their eigenvalues.
-* If the j-th eigenvalue is real, then u(j) = VL(:,j).
-* If the j-th and (j+1)-st eigenvalues form a complex conjugate
-* pair, then
-* u(j) = VL(:,j) + i*VL(:,j+1)
-* and
-* u(j+1) = VL(:,j) - i*VL(:,j+1).
-*
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvectors
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors x(j) are stored
-* in the columns of VR, in the same order as their eigenvalues.
-* If the j-th eigenvalue is real, then x(j) = VR(:,j).
-* If the j-th and (j+1)-st eigenvalues form a complex conjugate
-* pair, then
-* x(j) = VR(:,j) + i*VR(:,j+1)
-* and
-* x(j+1) = VR(:,j) - i*VR(:,j+1).
-*
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvalues
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,8*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:
-* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;
-* The optimal LWORK is:
-* 2*N + MAX( 6*N, N*(NB+1) ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
-* should be correct for j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from DGGBAL
-* =N+2: error return from DGEQRF
-* =N+3: error return from DORMQR
-* =N+4: error return from DORGQR
-* =N+5: error return from DGGHRD
-* =N+6: error return from DHGEQZ (other than failed
-* iteration)
-* =N+7: error return from DTGEVC
-* =N+8: error return from DGGBAK (computing VL)
-* =N+9: error return from DGGBAK (computing VR)
-* =N+10: error return from DLASCL (various calls)
-*
-
-* Further Details
-* ===============
-*
-* Balancing
-* ---------
-*
-* This driver calls DGGBAL to both permute and scale rows and columns
-* of A and B. The permutations PL and PR are chosen so that PL*A*PR
-* and PL*B*R will be upper triangular except for the diagonal blocks
-* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
-* possible. The diagonal scaling matrices DL and DR are chosen so
-* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
-* one (except for the elements that start out zero.)
-*
-* After the eigenvalues and eigenvectors of the balanced matrices
-* have been computed, DGGBAK transforms the eigenvectors back to what
-* they would have been (in perfect arithmetic) if they had not been
-* balanced.
-*
-* Contents of A and B on Exit
-* -------- -- - --- - -- ----
-*
-* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
-* both), then on exit the arrays A and B will contain the real Schur
-* form[*] of the "balanced" versions of A and B. If no eigenvectors
-* are computed, then only the diagonal blocks will be correct.
-*
-* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations",
-* by Golub & van Loan, pub. by Johns Hopkins U. Press.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgehd2"></A>
- <H2>dgehd2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.dgehd2( ilo, ihi, a)
- or
- NumRu::Lapack.dgehd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
-* an orthogonal similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to DGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= max(1,N).
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the n by n general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the orthogonal matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgehrd"></A>
- <H2>dgehrd</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.dgehrd( ilo, ihi, a, lwork)
- or
- NumRu::Lapack.dgehrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEHRD reduces a real general matrix A to upper Hessenberg form H by
-* an orthogonal similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to DGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the orthogonal matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
-* zero.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* This file is a slight modification of LAPACK-3.0's DGEHRD
-* subroutine incorporating improvements proposed by Quintana-Orti and
-* Van de Geijn (2006). (See DLAHR2.)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgejsv"></A>
- <H2>dgejsv</H2>
-
- <PRE>
-USAGE:
- sva, u, v, iwork, info, work = NumRu::Lapack.dgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work)
- or
- NumRu::Lapack.dgejsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEJSV computes the singular value decomposition (SVD) of a real M-by-N
-* matrix [A], where M >= N. The SVD of [A] is written as
-*
-* [A] = [U] * [SIGMA] * [V]^t,
-*
-* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N
-* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and
-* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are
-* the singular values of [A]. The columns of [U] and [V] are the left and
-* the right singular vectors of [A], respectively. The matrices [U] and [V]
-* are computed and stored in the arrays U and V, respectively. The diagonal
-* of [SIGMA] is computed and stored in the array SVA.
-*
-
-* Arguments
-* =========
-*
-* JOBA (input) CHARACTER*1
-* Specifies the level of accuracy:
-* = 'C': This option works well (high relative accuracy) if A = B * D,
-* with well-conditioned B and arbitrary diagonal matrix D.
-* The accuracy cannot be spoiled by COLUMN scaling. The
-* accuracy of the computed output depends on the condition of
-* B, and the procedure aims at the best theoretical accuracy.
-* The relative error max_{i=1:N}|d sigma_i| / sigma_i is
-* bounded by f(M,N)*epsilon* cond(B), independent of D.
-* The input matrix is preprocessed with the QRF with column
-* pivoting. This initial preprocessing and preconditioning by
-* a rank revealing QR factorization is common for all values of
-* JOBA. Additional actions are specified as follows:
-* = 'E': Computation as with 'C' with an additional estimate of the
-* condition number of B. It provides a realistic error bound.
-* = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings
-* D1, D2, and well-conditioned matrix C, this option gives
-* higher accuracy than the 'C' option. If the structure of the
-* input matrix is not known, and relative accuracy is
-* desirable, then this option is advisable. The input matrix A
-* is preprocessed with QR factorization with FULL (row and
-* column) pivoting.
-* = 'G' Computation as with 'F' with an additional estimate of the
-* condition number of B, where A=D*B. If A has heavily weighted
-* rows, then using this condition number gives too pessimistic
-* error bound.
-* = 'A': Small singular values are the noise and the matrix is treated
-* as numerically rank defficient. The error in the computed
-* singular values is bounded by f(m,n)*epsilon*||A||.
-* The computed SVD A = U * S * V^t restores A up to
-* f(m,n)*epsilon*||A||.
-* This gives the procedure the licence to discard (set to zero)
-* all singular values below N*epsilon*||A||.
-* = 'R': Similar as in 'A'. Rank revealing property of the initial
-* QR factorization is used do reveal (using triangular factor)
-* a gap sigma_{r+1} < epsilon * sigma_r in which case the
-* numerical RANK is declared to be r. The SVD is computed with
-* absolute error bounds, but more accurately than with 'A'.
-*
-* JOBU (input) CHARACTER*1
-* Specifies whether to compute the columns of U:
-* = 'U': N columns of U are returned in the array U.
-* = 'F': full set of M left sing. vectors is returned in the array U.
-* = 'W': U may be used as workspace of length M*N. See the description
-* of U.
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* Specifies whether to compute the matrix V:
-* = 'V': N columns of V are returned in the array V; Jacobi rotations
-* are not explicitly accumulated.
-* = 'J': N columns of V are returned in the array V, but they are
-* computed as the product of Jacobi rotations. This option is
-* allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.
-* = 'W': V may be used as workspace of length N*N. See the description
-* of V.
-* = 'N': V is not computed.
-*
-* JOBR (input) CHARACTER*1
-* Specifies the RANGE for the singular values. Issues the licence to
-* set to zero small positive singular values if they are outside
-* specified range. If A .NE. 0 is scaled so that the largest singular
-* value of c*A is around DSQRT(BIG), BIG=SLAMCH('O'), then JOBR issues
-* the licence to kill columns of A whose norm in c*A is less than
-* DSQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN,
-* where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').
-* = 'N': Do not kill small columns of c*A. This option assumes that
-* BLAS and QR factorizations and triangular solvers are
-* implemented to work in that range. If the condition of A
-* is greater than BIG, use DGESVJ.
-* = 'R': RESTRICTED range for sigma(c*A) is [DSQRT(SFMIN), DSQRT(BIG)]
-* (roughly, as described above). This option is recommended.
-* ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* For computing the singular values in the FULL range [SFMIN,BIG]
-* use DGESVJ.
-*
-* JOBT (input) CHARACTER*1
-* If the matrix is square then the procedure may determine to use
-* transposed A if A^t seems to be better with respect to convergence.
-* If the matrix is not square, JOBT is ignored. This is subject to
-* changes in the future.
-* The decision is based on two values of entropy over the adjoint
-* orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).
-* = 'T': transpose if entropy test indicates possibly faster
-* convergence of Jacobi process if A^t is taken as input. If A is
-* replaced with A^t, then the row pivoting is included automatically.
-* = 'N': do not speculate.
-* This option can be used to compute only the singular values, or the
-* full SVD (U, SIGMA and V). For only one set of singular vectors
-* (U or V), the caller should provide both U and V, as one of the
-* matrices is used as workspace if the matrix A is transposed.
-* The implementer can easily remove this constraint and make the
-* code more complicated. See the descriptions of U and V.
-*
-* JOBP (input) CHARACTER*1
-* Issues the licence to introduce structured perturbations to drown
-* denormalized numbers. This licence should be active if the
-* denormals are poorly implemented, causing slow computation,
-* especially in cases of fast convergence (!). For details see [1,2].
-* For the sake of simplicity, this perturbations are included only
-* when the full SVD or only the singular values are requested. The
-* implementer/user can easily add the perturbation for the cases of
-* computing one set of singular vectors.
-* = 'P': introduce perturbation
-* = 'N': do not perturb
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. M >= N >= 0.
-*
-* A (input/workspace) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* SVA (workspace/output) DOUBLE PRECISION array, dimension (N)
-* On exit,
-* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the
-* computation SVA contains Euclidean column norms of the
-* iterated matrices in the array A.
-* - For WORK(1) .NE. WORK(2): The singular values of A are
-* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if
-* sigma_max(A) overflows or if small singular values have been
-* saved from underflow by scaling the input matrix A.
-* - If JOBR='R' then some of the singular values may be returned
-* as exact zeros obtained by "set to zero" because they are
-* below the numerical rank threshold or are denormalized numbers.
-*
-* U (workspace/output) DOUBLE PRECISION array, dimension ( LDU, N )
-* If JOBU = 'U', then U contains on exit the M-by-N matrix of
-* the left singular vectors.
-* If JOBU = 'F', then U contains on exit the M-by-M matrix of
-* the left singular vectors, including an ONB
-* of the orthogonal complement of the Range(A).
-* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N),
-* then U is used as workspace if the procedure
-* replaces A with A^t. In that case, [V] is computed
-* in U as left singular vectors of A^t and then
-* copied back to the V array. This 'W' option is just
-* a reminder to the caller that in this case U is
-* reserved as workspace of length N*N.
-* If JOBU = 'N' U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U, LDU >= 1.
-* IF JOBU = 'U' or 'F' or 'W', then LDU >= M.
-*
-* V (workspace/output) DOUBLE PRECISION array, dimension ( LDV, N )
-* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of
-* the right singular vectors;
-* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N),
-* then V is used as workspace if the pprocedure
-* replaces A with A^t. In that case, [U] is computed
-* in V as right singular vectors of A^t and then
-* copied back to the U array. This 'W' option is just
-* a reminder to the caller that in this case V is
-* reserved as workspace of length N*N.
-* If JOBV = 'N' V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V, LDV >= 1.
-* If JOBV = 'V' or 'J' or 'W', then LDV >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension at least LWORK.
-* On exit,
-* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such
-* that SCALE*SVA(1:N) are the computed singular values
-* of A. (See the description of SVA().)
-* WORK(2) = See the description of WORK(1).
-* WORK(3) = SCONDA is an estimate for the condition number of
-* column equilibrated A. (If JOBA .EQ. 'E' or 'G')
-* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).
-* It is computed using DPOCON. It holds
-* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA
-* where R is the triangular factor from the QRF of A.
-* However, if R is truncated and the numerical rank is
-* determined to be strictly smaller than N, SCONDA is
-* returned as -1, thus indicating that the smallest
-* singular values might be lost.
-*
-* If full SVD is needed, the following two condition numbers are
-* useful for the analysis of the algorithm. They are provied for
-* a developer/implementer who is familiar with the details of
-* the method.
-*
-* WORK(4) = an estimate of the scaled condition number of the
-* triangular factor in the first QR factorization.
-* WORK(5) = an estimate of the scaled condition number of the
-* triangular factor in the second QR factorization.
-* The following two parameters are computed if JOBT .EQ. 'T'.
-* They are provided for a developer/implementer who is familiar
-* with the details of the method.
-*
-* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy
-* of diag(A^t*A) / Trace(A^t*A) taken as point in the
-* probability simplex.
-* WORK(7) = the entropy of A*A^t.
-*
-* LWORK (input) INTEGER
-* Length of WORK to confirm proper allocation of work space.
-* LWORK depends on the job:
-*
-* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and
-* -> .. no scaled condition estimate required ( JOBE.EQ.'N'):
-* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.
-* For optimal performance (blocked code) the optimal value
-* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal
-* block size for xGEQP3/xGEQRF.
-* -> .. an estimate of the scaled condition number of A is
-* required (JOBA='E', 'G'). In this case, LWORK is the maximum
-* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7).
-*
-* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'),
-* -> the minimal requirement is LWORK >= max(2*N+M,7).
-* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),
-* where NB is the optimal block size.
-*
-* If SIGMA and the left singular vectors are needed
-* -> the minimal requirement is LWORK >= max(2*N+M,7).
-* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),
-* where NB is the optimal block size.
-*
-* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and
-* -> .. the singular vectors are computed without explicit
-* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N
-* -> .. in the iterative part, the Jacobi rotations are
-* explicitly accumulated (option, see the description of JOBV),
-* then the minimal requirement is LWORK >= max(M+3*N+N*N,7).
-* For better performance, if NB is the optimal block size,
-* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7).
-*
-* IWORK (workspace/output) INTEGER array, dimension M+3*N.
-* On exit,
-* IWORK(1) = the numerical rank determined after the initial
-* QR factorization with pivoting. See the descriptions
-* of JOBA and JOBR.
-* IWORK(2) = the number of the computed nonzero singular values
-* IWORK(3) = if nonzero, a warning message:
-* If IWORK(3).EQ.1 then some of the column norms of A
-* were denormalized floats. The requested high accuracy
-* is not warranted by the data.
-*
-* INFO (output) INTEGER
-* < 0 : if INFO = -i, then the i-th argument had an illegal value.
-* = 0 : successfull exit;
-* > 0 : DGEJSV did not converge in the maximal allowed number
-* of sweeps. The computed values may be inaccurate.
-*
-
-* Further Details
-* ===============
-*
-* DGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,
-* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an
-* additional row pivoting can be used as a preprocessor, which in some
-* cases results in much higher accuracy. An example is matrix A with the
-* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned
-* diagonal matrices and C is well-conditioned matrix. In that case, complete
-* pivoting in the first QR factorizations provides accuracy dependent on the
-* condition number of C, and independent of D1, D2. Such higher accuracy is
-* not completely understood theoretically, but it works well in practice.
-* Further, if A can be written as A = B*D, with well-conditioned B and some
-* diagonal D, then the high accuracy is guaranteed, both theoretically and
-* in software, independent of D. For more details see [1], [2].
-* The computational range for the singular values can be the full range
-* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS
-* & LAPACK routines called by DGEJSV are implemented to work in that range.
-* If that is not the case, then the restriction for safe computation with
-* the singular values in the range of normalized IEEE numbers is that the
-* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not
-* overflow. This code (DGEJSV) is best used in this restricted range,
-* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are
-* returned as zeros. See JOBR for details on this.
-* Further, this implementation is somewhat slower than the one described
-* in [1,2] due to replacement of some non-LAPACK components, and because
-* the choice of some tuning parameters in the iterative part (DGESVJ) is
-* left to the implementer on a particular machine.
-* The rank revealing QR factorization (in this code: SGEQP3) should be
-* implemented as in [3]. We have a new version of SGEQP3 under development
-* that is more robust than the current one in LAPACK, with a cleaner cut in
-* rank defficient cases. It will be available in the SIGMA library [4].
-* If M is much larger than N, it is obvious that the inital QRF with
-* column pivoting can be preprocessed by the QRF without pivoting. That
-* well known trick is not used in DGEJSV because in some cases heavy row
-* weighting can be treated with complete pivoting. The overhead in cases
-* M much larger than N is then only due to pivoting, but the benefits in
-* terms of accuracy have prevailed. The implementer/user can incorporate
-* this extra QRF step easily. The implementer can also improve data movement
-* (matrix transpose, matrix copy, matrix transposed copy) - this
-* implementation of DGEJSV uses only the simplest, naive data movement.
-*
-* Contributors
-*
-* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
-*
-* References
-*
-* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.
-* LAPACK Working note 169.
-* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.
-* LAPACK Working note 170.
-* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR
-* factorization software - a case study.
-* ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28.
-* LAPACK Working note 176.
-* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
-* QSVD, (H,K)-SVD computations.
-* Department of Mathematics, University of Zagreb, 2008.
-*
-* Bugs, examples and comments
-*
-* Please report all bugs and send interesting examples and/or comments to
-* drmac at math.hr. Thank you.
-*
-* ==========================================================================
-*
-* .. Local Parameters ..
- DOUBLE PRECISION ZERO, ONE
- PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
-* ..
-* .. Local Scalars ..
- DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK,
- & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM,
- & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC
- INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING
- LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC,
- & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN,
- & NOSCAL, ROWPIV, RSVEC, TRANSP
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DABS, DLOG, DMAX1, DMIN1, DBLE,
- & MAX0, MIN0, IDNINT, DSIGN, DSQRT
-* ..
-* .. External Functions ..
- DOUBLE PRECISION DLAMCH, DNRM2
- INTEGER IDAMAX
- LOGICAL LSAME
- EXTERNAL IDAMAX, LSAME, DLAMCH, DNRM2
-* ..
-* .. External Subroutines ..
- EXTERNAL DCOPY, DGELQF, DGEQP3, DGEQRF, DLACPY, DLASCL,
- & DLASET, DLASSQ, DLASWP, DORGQR, DORMLQ,
- & DORMQR, DPOCON, DSCAL, DSWAP, DTRSM, XERBLA
-*
- EXTERNAL DGESVJ
-* ..
-*
-* Test the input arguments
-*
- LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' )
- JRACC = LSAME( JOBV, 'J' )
- RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC
- ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' )
- L2RANK = LSAME( JOBA, 'R' )
- L2ABER = LSAME( JOBA, 'A' )
- ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' )
- L2TRAN = LSAME( JOBT, 'T' )
- L2KILL = LSAME( JOBR, 'R' )
- DEFR = LSAME( JOBR, 'N' )
- L2PERT = LSAME( JOBP, 'P' )
-*
- IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR.
- & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN
- INFO = - 1
- ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR.
- & LSAME( JOBU, 'W' )) ) THEN
- INFO = - 2
- ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR.
- & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN
- INFO = - 3
- ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN
- INFO = - 4
- ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN
- INFO = - 5
- ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN
- INFO = - 6
- ELSE IF ( M .LT. 0 ) THEN
- INFO = - 7
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN
- INFO = - 8
- ELSE IF ( LDA .LT. M ) THEN
- INFO = - 10
- ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN
- INFO = - 13
- ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN
- INFO = - 14
- ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND.
- & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR.
- & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND.
- & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR.
- & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.
- & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.
- & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N))
- & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N)))
- & THEN
- INFO = - 17
- ELSE
-* #:)
- INFO = 0
- END IF
-*
- IF ( INFO .NE. 0 ) THEN
-* #:(
- CALL XERBLA( 'DGEJSV', - INFO )
- END IF
-*
-* Quick return for void matrix (Y3K safe)
-* #:)
- IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN
-*
-* Determine whether the matrix U should be M x N or M x M
-*
- IF ( LSVEC ) THEN
- N1 = N
- IF ( LSAME( JOBU, 'F' ) ) N1 = M
- END IF
-*
-* Set numerical parameters
-*
-*! NOTE: Make sure DLAMCH() does not fail on the target architecture.
-*
-
- EPSLN = DLAMCH('Epsilon')
- SFMIN = DLAMCH('SafeMinimum')
- SMALL = SFMIN / EPSLN
- BIG = DLAMCH('O')
-* BIG = ONE / SFMIN
-*
-* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N
-*
-*(!) If necessary, scale SVA() to protect the largest norm from
-* overflow. It is possible that this scaling pushes the smallest
-* column norm left from the underflow threshold (extreme case).
-*
- SCALEM = ONE / DSQRT(DBLE(M)*DBLE(N))
- NOSCAL = .TRUE.
- GOSCAL = .TRUE.
- DO 1874 p = 1, N
- AAPP = ZERO
- AAQQ = ONE
- CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 9
- CALL XERBLA( 'DGEJSV', -INFO )
- RETURN
- END IF
- AAQQ = DSQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN
- SVA(p) = AAPP * AAQQ
- ELSE
- NOSCAL = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALEM )
- IF ( GOSCAL ) THEN
- GOSCAL = .FALSE.
- CALL DSCAL( p-1, SCALEM, SVA, 1 )
- END IF
- END IF
- 1874 CONTINUE
-*
- IF ( NOSCAL ) SCALEM = ONE
-*
- AAPP = ZERO
- AAQQ = BIG
- DO 4781 p = 1, N
- AAPP = DMAX1( AAPP, SVA(p) )
- IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) )
- 4781 CONTINUE
-*
-* Quick return for zero M x N matrix
-* #:)
- IF ( AAPP .EQ. ZERO ) THEN
- IF ( LSVEC ) CALL DLASET( 'G', M, N1, ZERO, ONE, U, LDU )
- IF ( RSVEC ) CALL DLASET( 'G', N, N, ZERO, ONE, V, LDV )
- WORK(1) = ONE
- WORK(2) = ONE
- IF ( ERREST ) WORK(3) = ONE
- IF ( LSVEC .AND. RSVEC ) THEN
- WORK(4) = ONE
- WORK(5) = ONE
- END IF
- IF ( L2TRAN ) THEN
- WORK(6) = ZERO
- WORK(7) = ZERO
- END IF
- IWORK(1) = 0
- IWORK(2) = 0
- RETURN
- END IF
-*
-* Issue warning if denormalized column norms detected. Override the
-* high relative accuracy request. Issue licence to kill columns
-* (set them to zero) whose norm is less than sigma_max / BIG (roughly).
-* #:(
- WARNING = 0
- IF ( AAQQ .LE. SFMIN ) THEN
- L2RANK = .TRUE.
- L2KILL = .TRUE.
- WARNING = 1
- END IF
-*
-* Quick return for one-column matrix
-* #:)
- IF ( N .EQ. 1 ) THEN
-*
- IF ( LSVEC ) THEN
- CALL DLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )
- CALL DLACPY( 'A', M, 1, A, LDA, U, LDU )
-* computing all M left singular vectors of the M x 1 matrix
- IF ( N1 .NE. N ) THEN
- CALL DGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )
- CALL DORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )
- CALL DCOPY( M, A(1,1), 1, U(1,1), 1 )
- END IF
- END IF
- IF ( RSVEC ) THEN
- V(1,1) = ONE
- END IF
- IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN
- SVA(1) = SVA(1) / SCALEM
- SCALEM = ONE
- END IF
- WORK(1) = ONE / SCALEM
- WORK(2) = ONE
- IF ( SVA(1) .NE. ZERO ) THEN
- IWORK(1) = 1
- IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN
- IWORK(2) = 1
- ELSE
- IWORK(2) = 0
- END IF
- ELSE
- IWORK(1) = 0
- IWORK(2) = 0
- END IF
- IF ( ERREST ) WORK(3) = ONE
- IF ( LSVEC .AND. RSVEC ) THEN
- WORK(4) = ONE
- WORK(5) = ONE
- END IF
- IF ( L2TRAN ) THEN
- WORK(6) = ZERO
- WORK(7) = ZERO
- END IF
- RETURN
-*
- END IF
-*
- TRANSP = .FALSE.
- L2TRAN = L2TRAN .AND. ( M .EQ. N )
-*
- AATMAX = -ONE
- AATMIN = BIG
- IF ( ROWPIV .OR. L2TRAN ) THEN
-*
-* Compute the row norms, needed to determine row pivoting sequence
-* (in the case of heavily row weighted A, row pivoting is strongly
-* advised) and to collect information needed to compare the
-* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).
-*
- IF ( L2TRAN ) THEN
- DO 1950 p = 1, M
- XSC = ZERO
- TEMP1 = ONE
- CALL DLASSQ( N, A(p,1), LDA, XSC, TEMP1 )
-* DLASSQ gets both the ell_2 and the ell_infinity norm
-* in one pass through the vector
- WORK(M+N+p) = XSC * SCALEM
- WORK(N+p) = XSC * (SCALEM*DSQRT(TEMP1))
- AATMAX = DMAX1( AATMAX, WORK(N+p) )
- IF (WORK(N+p) .NE. ZERO) AATMIN = DMIN1(AATMIN,WORK(N+p))
- 1950 CONTINUE
- ELSE
- DO 1904 p = 1, M
- WORK(M+N+p) = SCALEM*DABS( A(p,IDAMAX(N,A(p,1),LDA)) )
- AATMAX = DMAX1( AATMAX, WORK(M+N+p) )
- AATMIN = DMIN1( AATMIN, WORK(M+N+p) )
- 1904 CONTINUE
- END IF
-*
- END IF
-*
-* For square matrix A try to determine whether A^t would be better
-* input for the preconditioned Jacobi SVD, with faster convergence.
-* The decision is based on an O(N) function of the vector of column
-* and row norms of A, based on the Shannon entropy. This should give
-* the right choice in most cases when the difference actually matters.
-* It may fail and pick the slower converging side.
-*
- ENTRA = ZERO
- ENTRAT = ZERO
- IF ( L2TRAN ) THEN
-*
- XSC = ZERO
- TEMP1 = ONE
- CALL DLASSQ( N, SVA, 1, XSC, TEMP1 )
- TEMP1 = ONE / TEMP1
-*
- ENTRA = ZERO
- DO 1113 p = 1, N
- BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1
- IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1)
- 1113 CONTINUE
- ENTRA = - ENTRA / DLOG(DBLE(N))
-*
-* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.
-* It is derived from the diagonal of A^t * A. Do the same with the
-* diagonal of A * A^t, compute the entropy of the corresponding
-* probability distribution. Note that A * A^t and A^t * A have the
-* same trace.
-*
- ENTRAT = ZERO
- DO 1114 p = N+1, N+M
- BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1
- IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1)
- 1114 CONTINUE
- ENTRAT = - ENTRAT / DLOG(DBLE(M))
-*
-* Analyze the entropies and decide A or A^t. Smaller entropy
-* usually means better input for the algorithm.
-*
- TRANSP = ( ENTRAT .LT. ENTRA )
-*
-* If A^t is better than A, transpose A.
-*
- IF ( TRANSP ) THEN
-* In an optimal implementation, this trivial transpose
-* should be replaced with faster transpose.
- DO 1115 p = 1, N - 1
- DO 1116 q = p + 1, N
- TEMP1 = A(q,p)
- A(q,p) = A(p,q)
- A(p,q) = TEMP1
- 1116 CONTINUE
- 1115 CONTINUE
- DO 1117 p = 1, N
- WORK(M+N+p) = SVA(p)
- SVA(p) = WORK(N+p)
- 1117 CONTINUE
- TEMP1 = AAPP
- AAPP = AATMAX
- AATMAX = TEMP1
- TEMP1 = AAQQ
- AAQQ = AATMIN
- AATMIN = TEMP1
- KILL = LSVEC
- LSVEC = RSVEC
- RSVEC = KILL
- IF ( LSVEC ) N1 = N
-*
- ROWPIV = .TRUE.
- END IF
-*
- END IF
-* END IF L2TRAN
-*
-* Scale the matrix so that its maximal singular value remains less
-* than DSQRT(BIG) -- the matrix is scaled so that its maximal column
-* has Euclidean norm equal to DSQRT(BIG/N). The only reason to keep
-* DSQRT(BIG) instead of BIG is the fact that DGEJSV uses LAPACK and
-* BLAS routines that, in some implementations, are not capable of
-* working in the full interval [SFMIN,BIG] and that they may provoke
-* overflows in the intermediate results. If the singular values spread
-* from SFMIN to BIG, then DGESVJ will compute them. So, in that case,
-* one should use DGESVJ instead of DGEJSV.
-*
- BIG1 = DSQRT( BIG )
- TEMP1 = DSQRT( BIG / DBLE(N) )
-*
- CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR )
- IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN
- AAQQ = ( AAQQ / AAPP ) * TEMP1
- ELSE
- AAQQ = ( AAQQ * TEMP1 ) / AAPP
- END IF
- TEMP1 = TEMP1 * SCALEM
- CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR )
-*
-* To undo scaling at the end of this procedure, multiply the
-* computed singular values with USCAL2 / USCAL1.
-*
- USCAL1 = TEMP1
- USCAL2 = AAPP
-*
- IF ( L2KILL ) THEN
-* L2KILL enforces computation of nonzero singular values in
-* the restricted range of condition number of the initial A,
-* sigma_max(A) / sigma_min(A) approx. DSQRT(BIG)/DSQRT(SFMIN).
- XSC = DSQRT( SFMIN )
- ELSE
- XSC = SMALL
-*
-* Now, if the condition number of A is too big,
-* sigma_max(A) / sigma_min(A) .GT. DSQRT(BIG/N) * EPSLN / SFMIN,
-* as a precaution measure, the full SVD is computed using DGESVJ
-* with accumulated Jacobi rotations. This provides numerically
-* more robust computation, at the cost of slightly increased run
-* time. Depending on the concrete implementation of BLAS and LAPACK
-* (i.e. how they behave in presence of extreme ill-conditioning) the
-* implementor may decide to remove this switch.
- IF ( ( AAQQ.LT.DSQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN
- JRACC = .TRUE.
- END IF
-*
- END IF
- IF ( AAQQ .LT. XSC ) THEN
- DO 700 p = 1, N
- IF ( SVA(p) .LT. XSC ) THEN
- CALL DLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA )
- SVA(p) = ZERO
- END IF
- 700 CONTINUE
- END IF
-*
-* Preconditioning using QR factorization with pivoting
-*
- IF ( ROWPIV ) THEN
-* Optional row permutation (Bjoerck row pivoting):
-* A result by Cox and Higham shows that the Bjoerck's
-* row pivoting combined with standard column pivoting
-* has similar effect as Powell-Reid complete pivoting.
-* The ell-infinity norms of A are made nonincreasing.
- DO 1952 p = 1, M - 1
- q = IDAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1
- IWORK(2*N+p) = q
- IF ( p .NE. q ) THEN
- TEMP1 = WORK(M+N+p)
- WORK(M+N+p) = WORK(M+N+q)
- WORK(M+N+q) = TEMP1
- END IF
- 1952 CONTINUE
- CALL DLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 )
- END IF
-*
-* End of the preparation phase (scaling, optional sorting and
-* transposing, optional flushing of small columns).
-*
-* Preconditioning
-*
-* If the full SVD is needed, the right singular vectors are computed
-* from a matrix equation, and for that we need theoretical analysis
-* of the Businger-Golub pivoting. So we use DGEQP3 as the first RR QRF.
-* In all other cases the first RR QRF can be chosen by other criteria
-* (eg speed by replacing global with restricted window pivoting, such
-* as in SGEQPX from TOMS # 782). Good results will be obtained using
-* SGEQPX with properly (!) chosen numerical parameters.
-* Any improvement of DGEQP3 improves overal performance of DGEJSV.
-*
-* A * P1 = Q1 * [ R1^t 0]^t:
- DO 1963 p = 1, N
-* .. all columns are free columns
- IWORK(p) = 0
- 1963 CONTINUE
- CALL DGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR )
-*
-* The upper triangular matrix R1 from the first QRF is inspected for
-* rank deficiency and possibilities for deflation, or possible
-* ill-conditioning. Depending on the user specified flag L2RANK,
-* the procedure explores possibilities to reduce the numerical
-* rank by inspecting the computed upper triangular factor. If
-* L2RANK or L2ABER are up, then DGEJSV will compute the SVD of
-* A + dA, where ||dA|| <= f(M,N)*EPSLN.
-*
- NR = 1
- IF ( L2ABER ) THEN
-* Standard absolute error bound suffices. All sigma_i with
-* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an
-* agressive enforcement of lower numerical rank by introducing a
-* backward error of the order of N*EPSLN*||A||.
- TEMP1 = DSQRT(DBLE(N))*EPSLN
- DO 3001 p = 2, N
- IF ( DABS(A(p,p)) .GE. (TEMP1*DABS(A(1,1))) ) THEN
- NR = NR + 1
- ELSE
- GO TO 3002
- END IF
- 3001 CONTINUE
- 3002 CONTINUE
- ELSE IF ( L2RANK ) THEN
-* .. similarly as above, only slightly more gentle (less agressive).
-* Sudden drop on the diagonal of R1 is used as the criterion for
-* close-to-rank-defficient.
- TEMP1 = DSQRT(SFMIN)
- DO 3401 p = 2, N
- IF ( ( DABS(A(p,p)) .LT. (EPSLN*DABS(A(p-1,p-1))) ) .OR.
- & ( DABS(A(p,p)) .LT. SMALL ) .OR.
- & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402
- NR = NR + 1
- 3401 CONTINUE
- 3402 CONTINUE
-*
- ELSE
-* The goal is high relative accuracy. However, if the matrix
-* has high scaled condition number the relative accuracy is in
-* general not feasible. Later on, a condition number estimator
-* will be deployed to estimate the scaled condition number.
-* Here we just remove the underflowed part of the triangular
-* factor. This prevents the situation in which the code is
-* working hard to get the accuracy not warranted by the data.
- TEMP1 = DSQRT(SFMIN)
- DO 3301 p = 2, N
- IF ( ( DABS(A(p,p)) .LT. SMALL ) .OR.
- & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302
- NR = NR + 1
- 3301 CONTINUE
- 3302 CONTINUE
-*
- END IF
-*
- ALMORT = .FALSE.
- IF ( NR .EQ. N ) THEN
- MAXPRJ = ONE
- DO 3051 p = 2, N
- TEMP1 = DABS(A(p,p)) / SVA(IWORK(p))
- MAXPRJ = DMIN1( MAXPRJ, TEMP1 )
- 3051 CONTINUE
- IF ( MAXPRJ**2 .GE. ONE - DBLE(N)*EPSLN ) ALMORT = .TRUE.
- END IF
-*
-*
- SCONDA = - ONE
- CONDR1 = - ONE
- CONDR2 = - ONE
-*
- IF ( ERREST ) THEN
- IF ( N .EQ. NR ) THEN
- IF ( RSVEC ) THEN
-* .. V is available as workspace
- CALL DLACPY( 'U', N, N, A, LDA, V, LDV )
- DO 3053 p = 1, N
- TEMP1 = SVA(IWORK(p))
- CALL DSCAL( p, ONE/TEMP1, V(1,p), 1 )
- 3053 CONTINUE
- CALL DPOCON( 'U', N, V, LDV, ONE, TEMP1,
- & WORK(N+1), IWORK(2*N+M+1), IERR )
- ELSE IF ( LSVEC ) THEN
-* .. U is available as workspace
- CALL DLACPY( 'U', N, N, A, LDA, U, LDU )
- DO 3054 p = 1, N
- TEMP1 = SVA(IWORK(p))
- CALL DSCAL( p, ONE/TEMP1, U(1,p), 1 )
- 3054 CONTINUE
- CALL DPOCON( 'U', N, U, LDU, ONE, TEMP1,
- & WORK(N+1), IWORK(2*N+M+1), IERR )
- ELSE
- CALL DLACPY( 'U', N, N, A, LDA, WORK(N+1), N )
- DO 3052 p = 1, N
- TEMP1 = SVA(IWORK(p))
- CALL DSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 )
- 3052 CONTINUE
-* .. the columns of R are scaled to have unit Euclidean lengths.
- CALL DPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1,
- & WORK(N+N*N+1), IWORK(2*N+M+1), IERR )
- END IF
- SCONDA = ONE / DSQRT(TEMP1)
-* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).
-* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA
- ELSE
- SCONDA = - ONE
- END IF
- END IF
-*
- L2PERT = L2PERT .AND. ( DABS( A(1,1)/A(NR,NR) ) .GT. DSQRT(BIG1) )
-* If there is no violent scaling, artificial perturbation is not needed.
-*
-* Phase 3:
-*
-
- IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN
-*
-* Singular Values only
-*
-* .. transpose A(1:NR,1:N)
- DO 1946 p = 1, MIN0( N-1, NR )
- CALL DCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 )
- 1946 CONTINUE
-*
-* The following two DO-loops introduce small relative perturbation
-* into the strict upper triangle of the lower triangular matrix.
-* Small entries below the main diagonal are also changed.
-* This modification is useful if the computing environment does not
-* provide/allow FLUSH TO ZERO underflow, for it prevents many
-* annoying denormalized numbers in case of strongly scaled matrices.
-* The perturbation is structured so that it does not introduce any
-* new perturbation of the singular values, and it does not destroy
-* the job done by the preconditioner.
-* The licence for this perturbation is in the variable L2PERT, which
-* should be .FALSE. if FLUSH TO ZERO underflow is active.
-*
- IF ( .NOT. ALMORT ) THEN
-*
- IF ( L2PERT ) THEN
-* XSC = DSQRT(SMALL)
- XSC = EPSLN / DBLE(N)
- DO 4947 q = 1, NR
- TEMP1 = XSC*DABS(A(q,q))
- DO 4949 p = 1, N
- IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )
- & .OR. ( p .LT. q ) )
- & A(p,q) = DSIGN( TEMP1, A(p,q) )
- 4949 CONTINUE
- 4947 CONTINUE
- ELSE
- CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA )
- END IF
-*
-* .. second preconditioning using the QR factorization
-*
- CALL DGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR )
-*
-* .. and transpose upper to lower triangular
- DO 1948 p = 1, NR - 1
- CALL DCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 )
- 1948 CONTINUE
-*
- END IF
-*
-* Row-cyclic Jacobi SVD algorithm with column pivoting
-*
-* .. again some perturbation (a "background noise") is added
-* to drown denormals
- IF ( L2PERT ) THEN
-* XSC = DSQRT(SMALL)
- XSC = EPSLN / DBLE(N)
- DO 1947 q = 1, NR
- TEMP1 = XSC*DABS(A(q,q))
- DO 1949 p = 1, NR
- IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )
- & .OR. ( p .LT. q ) )
- & A(p,q) = DSIGN( TEMP1, A(p,q) )
- 1949 CONTINUE
- 1947 CONTINUE
- ELSE
- CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA )
- END IF
-*
-* .. and one-sided Jacobi rotations are started on a lower
-* triangular matrix (plus perturbation which is ignored in
-* the part which destroys triangular form (confusing?!))
-*
- CALL DGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,
- & N, V, LDV, WORK, LWORK, INFO )
-*
- SCALEM = WORK(1)
- NUMRANK = IDNINT(WORK(2))
-*
-*
- ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN
-*
-* -> Singular Values and Right Singular Vectors <-
-*
- IF ( ALMORT ) THEN
-*
-* .. in this case NR equals N
- DO 1998 p = 1, NR
- CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )
- 1998 CONTINUE
- CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
-*
- CALL DGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,
- & WORK, LWORK, INFO )
- SCALEM = WORK(1)
- NUMRANK = IDNINT(WORK(2))
-
- ELSE
-*
-* .. two more QR factorizations ( one QRF is not enough, two require
-* accumulated product of Jacobi rotations, three are perfect )
-*
- CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )
- CALL DGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)
- CALL DLACPY( 'Lower', NR, NR, A, LDA, V, LDV )
- CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
- CALL DGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
- DO 8998 p = 1, NR
- CALL DCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )
- 8998 CONTINUE
- CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
-*
- CALL DGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,
- & LDU, WORK(N+1), LWORK, INFO )
- SCALEM = WORK(N+1)
- NUMRANK = IDNINT(WORK(N+2))
- IF ( NR .LT. N ) THEN
- CALL DLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV )
- CALL DLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV )
- CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )
- END IF
-*
- CALL DORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK,
- & V, LDV, WORK(N+1), LWORK-N, IERR )
-*
- END IF
-*
- DO 8991 p = 1, N
- CALL DCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )
- 8991 CONTINUE
- CALL DLACPY( 'All', N, N, A, LDA, V, LDV )
-*
- IF ( TRANSP ) THEN
- CALL DLACPY( 'All', N, N, V, LDV, U, LDU )
- END IF
-*
- ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN
-*
-* .. Singular Values and Left Singular Vectors ..
-*
-* .. second preconditioning step to avoid need to accumulate
-* Jacobi rotations in the Jacobi iterations.
- DO 1965 p = 1, NR
- CALL DCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )
- 1965 CONTINUE
- CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )
-*
- CALL DGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
-*
- DO 1967 p = 1, NR - 1
- CALL DCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )
- 1967 CONTINUE
- CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )
-*
- CALL DGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A,
- & LDA, WORK(N+1), LWORK-N, INFO )
- SCALEM = WORK(N+1)
- NUMRANK = IDNINT(WORK(N+2))
-*
- IF ( NR .LT. M ) THEN
- CALL DLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )
- IF ( NR .LT. N1 ) THEN
- CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )
- CALL DLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )
- END IF
- END IF
-*
- CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
-*
- IF ( ROWPIV )
- & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
- DO 1974 p = 1, N1
- XSC = ONE / DNRM2( M, U(1,p), 1 )
- CALL DSCAL( M, XSC, U(1,p), 1 )
- 1974 CONTINUE
-*
- IF ( TRANSP ) THEN
- CALL DLACPY( 'All', N, N, U, LDU, V, LDV )
- END IF
-*
- ELSE
-*
-* .. Full SVD ..
-*
- IF ( .NOT. JRACC ) THEN
-*
- IF ( .NOT. ALMORT ) THEN
-*
-* Second Preconditioning Step (QRF [with pivoting])
-* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is
-* equivalent to an LQF CALL. Since in many libraries the QRF
-* seems to be better optimized than the LQF, we do explicit
-* transpose and use the QRF. This is subject to changes in an
-* optimized implementation of DGEJSV.
-*
- DO 1968 p = 1, NR
- CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )
- 1968 CONTINUE
-*
-* .. the following two loops perturb small entries to avoid
-* denormals in the second QR factorization, where they are
-* as good as zeros. This is done to avoid painfully slow
-* computation with denormals. The relative size of the perturbation
-* is a parameter that can be changed by the implementer.
-* This perturbation device will be obsolete on machines with
-* properly implemented arithmetic.
-* To switch it off, set L2PERT=.FALSE. To remove it from the
-* code, remove the action under L2PERT=.TRUE., leave the ELSE part.
-* The following two loops should be blocked and fused with the
-* transposed copy above.
-*
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL)
- DO 2969 q = 1, NR
- TEMP1 = XSC*DABS( V(q,q) )
- DO 2968 p = 1, N
- IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )
- & .OR. ( p .LT. q ) )
- & V(p,q) = DSIGN( TEMP1, V(p,q) )
- IF ( p. LT. q ) V(p,q) = - V(p,q)
- 2968 CONTINUE
- 2969 CONTINUE
- ELSE
- CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
- END IF
-*
-* Estimate the row scaled condition number of R1
-* (If R1 is rectangular, N > NR, then the condition number
-* of the leading NR x NR submatrix is estimated.)
-*
- CALL DLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )
- DO 3950 p = 1, NR
- TEMP1 = DNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)
- CALL DSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)
- 3950 CONTINUE
- CALL DPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1,
- & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR)
- CONDR1 = ONE / DSQRT(TEMP1)
-* .. here need a second oppinion on the condition number
-* .. then assume worst case scenario
-* R1 is OK for inverse <=> CONDR1 .LT. DBLE(N)
-* more conservative <=> CONDR1 .LT. DSQRT(DBLE(N))
-*
- COND_OK = DSQRT(DBLE(NR))
-*[TP] COND_OK is a tuning parameter.
-
- IF ( CONDR1 .LT. COND_OK ) THEN
-* .. the second QRF without pivoting. Note: in an optimized
-* implementation, this QRF should be implemented as the QRF
-* of a lower triangular matrix.
-* R1^t = Q2 * R2
- CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
-*
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL)/EPSLN
- DO 3959 p = 2, NR
- DO 3958 q = 1, p - 1
- TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))
- IF ( DABS(V(q,p)) .LE. TEMP1 )
- & V(q,p) = DSIGN( TEMP1, V(q,p) )
- 3958 CONTINUE
- 3959 CONTINUE
- END IF
-*
- IF ( NR .NE. N )
-* .. save ...
- & CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )
-*
-* .. this transposed copy should be better than naive
- DO 1969 p = 1, NR - 1
- CALL DCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 )
- 1969 CONTINUE
-*
- CONDR2 = CONDR1
-*
- ELSE
-*
-* .. ill-conditioned case: second QRF with pivoting
-* Note that windowed pivoting would be equaly good
-* numerically, and more run-time efficient. So, in
-* an optimal implementation, the next call to DGEQP3
-* should be replaced with eg. CALL SGEQPX (ACM TOMS #782)
-* with properly (carefully) chosen parameters.
-*
-* R1^t * P2 = Q2 * R2
- DO 3003 p = 1, NR
- IWORK(N+p) = 0
- 3003 CONTINUE
- CALL DGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),
- & WORK(2*N+1), LWORK-2*N, IERR )
-** CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),
-** & LWORK-2*N, IERR )
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL)
- DO 3969 p = 2, NR
- DO 3968 q = 1, p - 1
- TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))
- IF ( DABS(V(q,p)) .LE. TEMP1 )
- & V(q,p) = DSIGN( TEMP1, V(q,p) )
- 3968 CONTINUE
- 3969 CONTINUE
- END IF
-*
- CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )
-*
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL)
- DO 8970 p = 2, NR
- DO 8971 q = 1, p - 1
- TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))
- V(p,q) = - DSIGN( TEMP1, V(q,p) )
- 8971 CONTINUE
- 8970 CONTINUE
- ELSE
- CALL DLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV )
- END IF
-* Now, compute R2 = L3 * Q3, the LQ factorization.
- CALL DGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1),
- & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR )
-* .. and estimate the condition number
- CALL DLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )
- DO 4950 p = 1, NR
- TEMP1 = DNRM2( p, WORK(2*N+N*NR+NR+p), NR )
- CALL DSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )
- 4950 CONTINUE
- CALL DPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1,
- & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR )
- CONDR2 = ONE / DSQRT(TEMP1)
-*
- IF ( CONDR2 .GE. COND_OK ) THEN
-* .. save the Householder vectors used for Q3
-* (this overwrittes the copy of R2, as it will not be
-* needed in this branch, but it does not overwritte the
-* Huseholder vectors of Q2.).
- CALL DLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N )
-* .. and the rest of the information on Q3 is in
-* WORK(2*N+N*NR+1:2*N+N*NR+N)
- END IF
-*
- END IF
-*
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL)
- DO 4968 q = 2, NR
- TEMP1 = XSC * V(q,q)
- DO 4969 p = 1, q - 1
-* V(p,q) = - DSIGN( TEMP1, V(q,p) )
- V(p,q) = - DSIGN( TEMP1, V(p,q) )
- 4969 CONTINUE
- 4968 CONTINUE
- ELSE
- CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV )
- END IF
-*
-* Second preconditioning finished; continue with Jacobi SVD
-* The input matrix is lower trinagular.
-*
-* Recover the right singular vectors as solution of a well
-* conditioned triangular matrix equation.
-*
- IF ( CONDR1 .LT. COND_OK ) THEN
-*
- CALL DGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U,
- & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO )
- SCALEM = WORK(2*N+N*NR+NR+1)
- NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))
- DO 3970 p = 1, NR
- CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )
- CALL DSCAL( NR, SVA(p), V(1,p), 1 )
- 3970 CONTINUE
-
-* .. pick the right matrix equation and solve it
-*
- IF ( NR. EQ. N ) THEN
-* :)) .. best case, R1 is inverted. The solution of this matrix
-* equation is Q2*V2 = the product of the Jacobi rotations
-* used in DGESVJ, premultiplied with the orthogonal matrix
-* from the second QR factorization.
- CALL DTRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV )
- ELSE
-* .. R1 is well conditioned, but non-square. Transpose(R2)
-* is inverted to get the product of the Jacobi rotations
-* used in DGESVJ. The Q-factor from the second QR
-* factorization is then built in explicitly.
- CALL DTRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),
- & N,V,LDV)
- IF ( NR .LT. N ) THEN
- CALL DLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)
- CALL DLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)
- CALL DLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)
- END IF
- CALL DORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR)
- END IF
-*
- ELSE IF ( CONDR2 .LT. COND_OK ) THEN
-*
-* :) .. the input matrix A is very likely a relative of
-* the Kahan matrix :)
-* The matrix R2 is inverted. The solution of the matrix equation
-* is Q3^T*V3 = the product of the Jacobi rotations (appplied to
-* the lower triangular L3 from the LQ factorization of
-* R2=L3*Q3), pre-multiplied with the transposed Q3.
- CALL DGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U,
- & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )
- SCALEM = WORK(2*N+N*NR+NR+1)
- NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))
- DO 3870 p = 1, NR
- CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )
- CALL DSCAL( NR, SVA(p), U(1,p), 1 )
- 3870 CONTINUE
- CALL DTRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU)
-* .. apply the permutation from the second QR factorization
- DO 873 q = 1, NR
- DO 872 p = 1, NR
- WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)
- 872 CONTINUE
- DO 874 p = 1, NR
- U(p,q) = WORK(2*N+N*NR+NR+p)
- 874 CONTINUE
- 873 CONTINUE
- IF ( NR .LT. N ) THEN
- CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )
- CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )
- CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )
- END IF
- CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )
- ELSE
-* Last line of defense.
-* #:( This is a rather pathological case: no scaled condition
-* improvement after two pivoted QR factorizations. Other
-* possibility is that the rank revealing QR factorization
-* or the condition estimator has failed, or the COND_OK
-* is set very close to ONE (which is unnecessary). Normally,
-* this branch should never be executed, but in rare cases of
-* failure of the RRQR or condition estimator, the last line of
-* defense ensures that DGEJSV completes the task.
-* Compute the full SVD of L3 using DGESVJ with explicit
-* accumulation of Jacobi rotations.
- CALL DGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U,
- & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )
- SCALEM = WORK(2*N+N*NR+NR+1)
- NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))
- IF ( NR .LT. N ) THEN
- CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )
- CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )
- CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )
- END IF
- CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )
-*
- CALL DORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N,
- & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1),
- & LWORK-2*N-N*NR-NR, IERR )
- DO 773 q = 1, NR
- DO 772 p = 1, NR
- WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)
- 772 CONTINUE
- DO 774 p = 1, NR
- U(p,q) = WORK(2*N+N*NR+NR+p)
- 774 CONTINUE
- 773 CONTINUE
-*
- END IF
-*
-* Permute the rows of V using the (column) permutation from the
-* first QRF. Also, scale the columns to make them unit in
-* Euclidean norm. This applies to all cases.
-*
- TEMP1 = DSQRT(DBLE(N)) * EPSLN
- DO 1972 q = 1, N
- DO 972 p = 1, N
- WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)
- 972 CONTINUE
- DO 973 p = 1, N
- V(p,q) = WORK(2*N+N*NR+NR+p)
- 973 CONTINUE
- XSC = ONE / DNRM2( N, V(1,q), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL DSCAL( N, XSC, V(1,q), 1 )
- 1972 CONTINUE
-* At this moment, V contains the right singular vectors of A.
-* Next, assemble the left singular vector matrix U (M x N).
- IF ( NR .LT. M ) THEN
- CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )
- IF ( NR .LT. N1 ) THEN
- CALL DLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)
- CALL DLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU)
- END IF
- END IF
-*
-* The Q matrix from the first QRF is built into the left singular
-* matrix U. This applies to all cases.
-*
- CALL DORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
-
-* The columns of U are normalized. The cost is O(M*N) flops.
- TEMP1 = DSQRT(DBLE(M)) * EPSLN
- DO 1973 p = 1, NR
- XSC = ONE / DNRM2( M, U(1,p), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL DSCAL( M, XSC, U(1,p), 1 )
- 1973 CONTINUE
-*
-* If the initial QRF is computed with row pivoting, the left
-* singular vectors must be adjusted.
-*
- IF ( ROWPIV )
- & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
- ELSE
-*
-* .. the initial matrix A has almost orthogonal columns and
-* the second QRF is not needed
-*
- CALL DLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL)
- DO 5970 p = 2, N
- TEMP1 = XSC * WORK( N + (p-1)*N + p )
- DO 5971 q = 1, p - 1
- WORK(N+(q-1)*N+p)=-DSIGN(TEMP1,WORK(N+(p-1)*N+q))
- 5971 CONTINUE
- 5970 CONTINUE
- ELSE
- CALL DLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )
- END IF
-*
- CALL DGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA,
- & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO )
-*
- SCALEM = WORK(N+N*N+1)
- NUMRANK = IDNINT(WORK(N+N*N+2))
- DO 6970 p = 1, N
- CALL DCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )
- CALL DSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )
- 6970 CONTINUE
-*
- CALL DTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,
- & ONE, A, LDA, WORK(N+1), N )
- DO 6972 p = 1, N
- CALL DCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )
- 6972 CONTINUE
- TEMP1 = DSQRT(DBLE(N))*EPSLN
- DO 6971 p = 1, N
- XSC = ONE / DNRM2( N, V(1,p), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL DSCAL( N, XSC, V(1,p), 1 )
- 6971 CONTINUE
-*
-* Assemble the left singular vector matrix U (M x N).
-*
- IF ( N .LT. M ) THEN
- CALL DLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU )
- IF ( N .LT. N1 ) THEN
- CALL DLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU )
- CALL DLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )
- END IF
- END IF
- CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
- TEMP1 = DSQRT(DBLE(M))*EPSLN
- DO 6973 p = 1, N1
- XSC = ONE / DNRM2( M, U(1,p), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL DSCAL( M, XSC, U(1,p), 1 )
- 6973 CONTINUE
-*
- IF ( ROWPIV )
- & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
- END IF
-*
-* end of the >> almost orthogonal case << in the full SVD
-*
- ELSE
-*
-* This branch deploys a preconditioned Jacobi SVD with explicitly
-* accumulated rotations. It is included as optional, mainly for
-* experimental purposes. It does perfom well, and can also be used.
-* In this implementation, this branch will be automatically activated
-* if the condition number sigma_max(A) / sigma_min(A) is predicted
-* to be greater than the overflow threshold. This is because the
-* a posteriori computation of the singular vectors assumes robust
-* implementation of BLAS and some LAPACK procedures, capable of working
-* in presence of extreme values. Since that is not always the case, ...
-*
- DO 7968 p = 1, NR
- CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )
- 7968 CONTINUE
-*
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL/EPSLN)
- DO 5969 q = 1, NR
- TEMP1 = XSC*DABS( V(q,q) )
- DO 5968 p = 1, N
- IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )
- & .OR. ( p .LT. q ) )
- & V(p,q) = DSIGN( TEMP1, V(p,q) )
- IF ( p. LT. q ) V(p,q) = - V(p,q)
- 5968 CONTINUE
- 5969 CONTINUE
- ELSE
- CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
- END IF
-
- CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
- CALL DLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )
-*
- DO 7969 p = 1, NR
- CALL DCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )
- 7969 CONTINUE
-
- IF ( L2PERT ) THEN
- XSC = DSQRT(SMALL/EPSLN)
- DO 9970 q = 2, NR
- DO 9971 p = 1, q - 1
- TEMP1 = XSC * DMIN1(DABS(U(p,p)),DABS(U(q,q)))
- U(p,q) = - DSIGN( TEMP1, U(q,p) )
- 9971 CONTINUE
- 9970 CONTINUE
- ELSE
- CALL DLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )
- END IF
-
- CALL DGESVJ( 'G', 'U', 'V', NR, NR, U, LDU, SVA,
- & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO )
- SCALEM = WORK(2*N+N*NR+1)
- NUMRANK = IDNINT(WORK(2*N+N*NR+2))
-
- IF ( NR .LT. N ) THEN
- CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )
- CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )
- CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )
- END IF
-
- CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )
-*
-* Permute the rows of V using the (column) permutation from the
-* first QRF. Also, scale the columns to make them unit in
-* Euclidean norm. This applies to all cases.
-*
- TEMP1 = DSQRT(DBLE(N)) * EPSLN
- DO 7972 q = 1, N
- DO 8972 p = 1, N
- WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)
- 8972 CONTINUE
- DO 8973 p = 1, N
- V(p,q) = WORK(2*N+N*NR+NR+p)
- 8973 CONTINUE
- XSC = ONE / DNRM2( N, V(1,q), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL DSCAL( N, XSC, V(1,q), 1 )
- 7972 CONTINUE
-*
-* At this moment, V contains the right singular vectors of A.
-* Next, assemble the left singular vector matrix U (M x N).
-*
- IF ( NR .LT. M ) THEN
- CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )
- IF ( NR .LT. N1 ) THEN
- CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU )
- CALL DLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )
- END IF
- END IF
-*
- CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
-*
- IF ( ROWPIV )
- & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
-*
- END IF
- IF ( TRANSP ) THEN
-* .. swap U and V because the procedure worked on A^t
- DO 6974 p = 1, N
- CALL DSWAP( N, U(1,p), 1, V(1,p), 1 )
- 6974 CONTINUE
- END IF
-*
- END IF
-* end of the full SVD
-*
-* Undo scaling, if necessary (and possible)
-*
- IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN
- CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR )
- USCAL1 = ONE
- USCAL2 = ONE
- END IF
-*
- IF ( NR .LT. N ) THEN
- DO 3004 p = NR+1, N
- SVA(p) = ZERO
- 3004 CONTINUE
- END IF
-*
- WORK(1) = USCAL2 * SCALEM
- WORK(2) = USCAL1
- IF ( ERREST ) WORK(3) = SCONDA
- IF ( LSVEC .AND. RSVEC ) THEN
- WORK(4) = CONDR1
- WORK(5) = CONDR2
- END IF
- IF ( L2TRAN ) THEN
- WORK(6) = ENTRA
- WORK(7) = ENTRAT
- END IF
-*
- IWORK(1) = NR
- IWORK(2) = NUMRANK
- IWORK(3) = WARNING
-*
- RETURN
-* ..
-* .. END OF DGEJSV
-* ..
- END
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgelq2"></A>
- <H2>dgelq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.dgelq2( a)
- or
- NumRu::Lapack.dgelq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGELQ2 computes an LQ factorization of a real m by n matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m by min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgelqf"></A>
- <H2>dgelqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.dgelqf( m, a, lwork)
- or
- NumRu::Lapack.dgelqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGELQF computes an LQ factorization of a real M-by-N matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgels"></A>
- <H2>dgels</H2>
-
- <PRE>
-USAGE:
- work, info, a, b = NumRu::Lapack.dgels( trans, m, a, b, lwork)
- or
- NumRu::Lapack.dgels # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGELS solves overdetermined or underdetermined real linear systems
-* involving an M-by-N matrix A, or its transpose, using a QR or LQ
-* factorization of A. It is assumed that A has full rank.
-*
-* The following options are provided:
-*
-* 1. If TRANS = 'N' and m >= n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A*X ||.
-*
-* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
-* an underdetermined system A * X = B.
-*
-* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
-* an undetermined system A**T * X = B.
-*
-* 4. If TRANS = 'T' and m < n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A**T * X ||.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N': the linear system involves A;
-* = 'T': the linear system involves A**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of the matrices B and X. NRHS >=0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if M >= N, A is overwritten by details of its QR
-* factorization as returned by DGEQRF;
-* if M < N, A is overwritten by details of its LQ
-* factorization as returned by DGELQF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the matrix B of right hand side vectors, stored
-* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
-* if TRANS = 'T'.
-* On exit, if INFO = 0, B is overwritten by the solution
-* vectors, stored columnwise:
-* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
-* squares solution vectors; the residual sum of squares for the
-* solution in each column is given by the sum of squares of
-* elements N+1 to M in that column;
-* if TRANS = 'N' and m < n, rows 1 to N of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'T' and m < n, rows 1 to M of B contain the
-* least squares solution vectors; the residual sum of squares
-* for the solution in each column is given by the sum of
-* squares of elements M+1 to N in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= MAX(1,M,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= max( 1, MN + max( MN, NRHS ) ).
-* For optimal performance,
-* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
-* where MN = min(M,N) and NB is the optimum block size.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of the
-* triangular factor of A is zero, so that A does not have
-* full rank; the least squares solution could not be
-* computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgelsd"></A>
- <H2>dgelsd</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, b = NumRu::Lapack.dgelsd( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.dgelsd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGELSD computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize 2-norm(| b - A*x |)
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The problem is solved in three steps:
-* (1) Reduce the coefficient matrix A to bidiagonal form with
-* Householder transformations, reducing the original problem
-* into a "bidiagonal least squares problem" (BLS)
-* (2) Solve the BLS using a divide and conquer approach.
-* (3) Apply back all the Householder tranformations to solve
-* the original least squares problem.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution
-* matrix X. If m >= n and RANK = n, the residual
-* sum-of-squares for the solution in the i-th column is given
-* by the sum of squares of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,max(M,N)).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK must be at least 1.
-* The exact minimum amount of workspace needed depends on M,
-* N and NRHS. As long as LWORK is at least
-* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
-* if M is greater than or equal to N or
-* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
-* if M is less than N, the code will execute correctly.
-* SMLSIZ is returned by ILAENV and is equal to the maximum
-* size of the subproblems at the bottom of the computation
-* tree (usually about 25), and
-* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN),
-* where MINMN = MIN( M,N ).
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Ren-Cang Li, Computer Science Division, University of
-* California at Berkeley, USA
-* Osni Marques, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgelss"></A>
- <H2>dgelss</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, a, b = NumRu::Lapack.dgelss( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.dgelss # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGELSS computes the minimum norm solution to a real linear least
-* squares problem:
-*
-* Minimize 2-norm(| b - A*x |).
-*
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
-* X.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the first min(m,n) rows of A are overwritten with
-* its right singular vectors, stored rowwise.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution
-* matrix X. If m >= n and RANK = n, the residual
-* sum-of-squares for the solution in the i-th column is given
-* by the sum of squares of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,max(M,N)).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1, and also:
-* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgelsx"></A>
- <H2>dgelsx</H2>
-
- <PRE>
-USAGE:
- rank, info, a, b, jpvt = NumRu::Lapack.dgelsx( m, a, b, jpvt, rcond)
- or
- NumRu::Lapack.dgelsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine DGELSY.
-*
-* DGELSX computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by orthogonal transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of elements N+1:M in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
-* initial column, otherwise it is a free column. Before
-* the QR factorization of A, all initial columns are
-* permuted to the leading positions; only the remaining
-* free columns are moved as a result of column pivoting
-* during the factorization.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension
-* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgelsy"></A>
- <H2>dgelsy</H2>
-
- <PRE>
-USAGE:
- rank, work, info, a, b, jpvt = NumRu::Lapack.dgelsy( m, a, b, jpvt, rcond, lwork)
- or
- NumRu::Lapack.dgelsy # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGELSY computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by orthogonal transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-* This routine is basically identical to the original xGELSX except
-* three differences:
-* o The call to the subroutine xGEQPF has been substituted by the
-* the call to the subroutine xGEQP3. This subroutine is a Blas-3
-* version of the QR factorization with column pivoting.
-* o Matrix B (the right hand side) is updated with Blas-3.
-* o The permutation of matrix B (the right hand side) is faster and
-* more simple.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of AP, otherwise column i is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of AP
-* was the k-th column of A.
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* The unblocked strategy requires that:
-* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
-* where MN = min( M, N ).
-* The block algorithm requires that:
-* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
-* where NB is an upper bound on the blocksize returned
-* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,
-* and DORMRZ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeql2"></A>
- <H2>dgeql2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.dgeql2( m, a)
- or
- NumRu::Lapack.dgeql2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEQL2 computes a QL factorization of a real m by n matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the m by n lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* orthogonal matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeqlf"></A>
- <H2>dgeqlf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.dgeqlf( m, a, lwork)
- or
- NumRu::Lapack.dgeqlf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEQLF computes a QL factorization of a real M-by-N matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the M-by-N lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* orthogonal matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeqp3"></A>
- <H2>dgeqp3</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a, jpvt = NumRu::Lapack.dgeqp3( m, a, jpvt, lwork)
- or
- NumRu::Lapack.dgeqp3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEQP3 computes a QR factorization with column pivoting of a
-* matrix A: A*P = Q*R using Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper trapezoidal matrix R; the elements below
-* the diagonal, together with the array TAU, represent the
-* orthogonal matrix Q as a product of min(M,N) elementary
-* reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(J)=0,
-* the J-th column of A is a free column.
-* On exit, if JPVT(J)=K, then the J-th column of A*P was the
-* the K-th column of A.
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 3*N+1.
-* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real/complex scalar, and v is a real/complex vector
-* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
-* A(i+1:m,i), and tau in TAU(i).
-*
-* Based on contributions by
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* X. Sun, Computer Science Dept., Duke University, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeqpf"></A>
- <H2>dgeqpf</H2>
-
- <PRE>
-USAGE:
- tau, info, a, jpvt = NumRu::Lapack.dgeqpf( m, a, jpvt)
- or
- NumRu::Lapack.dgeqpf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine DGEQP3.
-*
-* DGEQPF computes a QR factorization with column pivoting of a
-* real M-by-N matrix A: A*P = Q*R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper triangular matrix R; the elements
-* below the diagonal, together with the array TAU,
-* represent the orthogonal matrix Q as a product of
-* min(m,n) elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(i) = 0,
-* the i-th column of A is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(n)
-*
-* Each H(i) has the form
-*
-* H = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
-*
-* The matrix P is represented in jpvt as follows: If
-* jpvt(j) = i
-* then the jth column of P is the ith canonical unit vector.
-*
-* Partial column norm updating strategy modified by
-* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
-* University of Zagreb, Croatia.
-* June 2010
-* For more details see LAPACK Working Note 176.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeqr2"></A>
- <H2>dgeqr2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.dgeqr2( m, a)
- or
- NumRu::Lapack.dgeqr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEQR2 computes a QR factorization of a real m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeqr2p"></A>
- <H2>dgeqr2p</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.dgeqr2p( m, a)
- or
- NumRu::Lapack.dgeqr2p # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEQR2 computes a QR factorization of a real m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeqrf"></A>
- <H2>dgeqrf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.dgeqrf( m, a, lwork)
- or
- NumRu::Lapack.dgeqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEQRF computes a QR factorization of a real M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgeqrfp"></A>
- <H2>dgeqrfp</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.dgeqrfp( m, a, lwork)
- or
- NumRu::Lapack.dgeqrfp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGEQRFP computes a QR factorization of a real M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL DGEQR2P, DLARFB, DLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgerfs"></A>
- <H2>dgerfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dgerfs( trans, a, af, ipiv, b, x)
- or
- NumRu::Lapack.dgerfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGERFS improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates for
-* the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by DGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from DGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgerfsx"></A>
- <H2>dgerfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.dgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.dgerfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGERFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by DGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from DGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed.
-* If R is accessed, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed.
-* If C is accessed, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgerq2"></A>
- <H2>dgerq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.dgerq2( a)
- or
- NumRu::Lapack.dgerq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGERQ2 computes an RQ factorization of a real m by n matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the m by n upper trapezoidal matrix R; the remaining
-* elements, with the array TAU, represent the orthogonal matrix
-* Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgerqf"></A>
- <H2>dgerqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.dgerqf( m, a, lwork)
- or
- NumRu::Lapack.dgerqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGERQF computes an RQ factorization of a real M-by-N matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R;
-* the remaining elements, with the array TAU, represent the
-* orthogonal matrix Q as a product of min(m,n) elementary
-* reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgesc2"></A>
- <H2>dgesc2</H2>
-
- <PRE>
-USAGE:
- scale, rhs = NumRu::Lapack.dgesc2( a, rhs, ipiv, jpiv)
- or
- NumRu::Lapack.dgesc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
-
-* Purpose
-* =======
-*
-* DGESC2 solves a system of linear equations
-*
-* A * X = scale* RHS
-*
-* with a general N-by-N matrix A using the LU factorization with
-* complete pivoting computed by DGETC2.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the LU part of the factorization of the n-by-n
-* matrix A computed by DGETC2: A = P * L * U * Q
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, N).
-*
-* RHS (input/output) DOUBLE PRECISION array, dimension (N).
-* On entry, the right hand side vector b.
-* On exit, the solution vector X.
-*
-* IPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* SCALE (output) DOUBLE PRECISION
-* On exit, SCALE contains the scale factor. SCALE is chosen
-* 0 <= SCALE <= 1 to prevent owerflow in the solution.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgesdd"></A>
- <H2>dgesdd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.dgesdd( jobz, m, a, lwork)
- or
- NumRu::Lapack.dgesdd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGESDD computes the singular value decomposition (SVD) of a real
-* M-by-N matrix A, optionally computing the left and right singular
-* vectors. If singular vectors are desired, it uses a
-* divide-and-conquer algorithm.
-*
-* The SVD is written
-*
-* A = U * SIGMA * transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
-* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns VT = V**T, not V.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U and all N rows of V**T are
-* returned in the arrays U and VT;
-* = 'S': the first min(M,N) columns of U and the first
-* min(M,N) rows of V**T are returned in the arrays U
-* and VT;
-* = 'O': If M >= N, the first N columns of U are overwritten
-* on the array A and all rows of V**T are returned in
-* the array VT;
-* otherwise, all columns of U are returned in the
-* array U and the first M rows of V**T are overwritten
-* in the array A;
-* = 'N': no columns of U or rows of V**T are computed.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBZ = 'O', A is overwritten with the first N columns
-* of U (the left singular vectors, stored
-* columnwise) if M >= N;
-* A is overwritten with the first M rows
-* of V**T (the right singular vectors, stored
-* rowwise) otherwise.
-* if JOBZ .ne. 'O', the contents of A are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
-* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
-* UCOL = min(M,N) if JOBZ = 'S'.
-* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
-* orthogonal matrix U;
-* if JOBZ = 'S', U contains the first min(M,N) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
-*
-* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
-* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
-* N-by-N orthogonal matrix V**T;
-* if JOBZ = 'S', VT contains the first min(M,N) rows of
-* V**T (the right singular vectors, stored rowwise);
-* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
-* if JOBZ = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* If JOBZ = 'N',
-* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).
-* If JOBZ = 'O',
-* LWORK >= 3*min(M,N) +
-* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
-* If JOBZ = 'S' or 'A'
-* LWORK >= 3*min(M,N) +
-* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
-* For good performance, LWORK should generally be larger.
-* If LWORK = -1 but other input arguments are legal, WORK(1)
-* returns the optimal LWORK.
-*
-* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: DBDSDC did not converge, updating process failed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgesv"></A>
- <H2>dgesv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a, b = NumRu::Lapack.dgesv( a, b)
- or
- NumRu::Lapack.dgesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DGESV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as
-* A = P * L * U,
-* where P is a permutation matrix, L is unit lower triangular, and U is
-* upper triangular. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the N-by-N coefficient matrix A.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS matrix of right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL DGETRF, DGETRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgesvd"></A>
- <H2>dgesvd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.dgesvd( jobu, jobvt, m, a, lwork)
- or
- NumRu::Lapack.dgesvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGESVD computes the singular value decomposition (SVD) of a real
-* M-by-N matrix A, optionally computing the left and/or right singular
-* vectors. The SVD is written
-*
-* A = U * SIGMA * transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
-* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns V**T, not V.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U are returned in array U:
-* = 'S': the first min(m,n) columns of U (the left singular
-* vectors) are returned in the array U;
-* = 'O': the first min(m,n) columns of U (the left singular
-* vectors) are overwritten on the array A;
-* = 'N': no columns of U (no left singular vectors) are
-* computed.
-*
-* JOBVT (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix
-* V**T:
-* = 'A': all N rows of V**T are returned in the array VT;
-* = 'S': the first min(m,n) rows of V**T (the right singular
-* vectors) are returned in the array VT;
-* = 'O': the first min(m,n) rows of V**T (the right singular
-* vectors) are overwritten on the array A;
-* = 'N': no rows of V**T (no right singular vectors) are
-* computed.
-*
-* JOBVT and JOBU cannot both be 'O'.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBU = 'O', A is overwritten with the first min(m,n)
-* columns of U (the left singular vectors,
-* stored columnwise);
-* if JOBVT = 'O', A is overwritten with the first min(m,n)
-* rows of V**T (the right singular vectors,
-* stored rowwise);
-* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
-* are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
-* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
-* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
-* if JOBU = 'S', U contains the first min(m,n) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBU = 'N' or 'O', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBU = 'S' or 'A', LDU >= M.
-*
-* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
-* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
-* V**T;
-* if JOBVT = 'S', VT contains the first min(m,n) rows of
-* V**T (the right singular vectors, stored rowwise);
-* if JOBVT = 'N' or 'O', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
-* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
-* superdiagonal elements of an upper bidiagonal matrix B
-* whose diagonal is in S (not necessarily sorted). B
-* satisfies A = U * B * VT, so it has the same singular values
-* as A, and singular vectors related by U and VT.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if DBDSQR did not converge, INFO specifies how many
-* superdiagonals of an intermediate bidiagonal form B
-* did not converge to zero. See the description of WORK
-* above for details.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgesvj"></A>
- <H2>dgesvj</H2>
-
- <PRE>
-USAGE:
- sva, info, a, v, work = NumRu::Lapack.dgesvj( joba, jobu, jobv, m, a, mv, v, work)
- or
- NumRu::Lapack.dgesvj # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGESVJ computes the singular value decomposition (SVD) of a real
-* M-by-N matrix A, where M >= N. The SVD of A is written as
-* [++] [xx] [x0] [xx]
-* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]
-* [++] [xx]
-* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal
-* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements
-* of SIGMA are the singular values of A. The columns of U and V are the
-* left and the right singular vectors of A, respectively.
-*
-* Further Details
-* ~~~~~~~~~~~~~~~
-* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane
-* rotations. The rotations are implemented as fast scaled rotations of
-* Anda and Park [1]. In the case of underflow of the Jacobi angle, a
-* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses
-* column interchanges of de Rijk [2]. The relative accuracy of the computed
-* singular values and the accuracy of the computed singular vectors (in
-* angle metric) is as guaranteed by the theory of Demmel and Veselic [3].
-* The condition number that determines the accuracy in the full rank case
-* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the
-* spectral condition number. The best performance of this Jacobi SVD
-* procedure is achieved if used in an accelerated version of Drmac and
-* Veselic [5,6], and it is the kernel routine in the SIGMA library [7].
-* Some tunning parameters (marked with [TP]) are available for the
-* implementer.
-* The computational range for the nonzero singular values is the machine
-* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even
-* denormalized singular values can be computed with the corresponding
-* gradual loss of accurate digits.
-*
-* Contributors
-* ~~~~~~~~~~~~
-* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
-*
-* References
-* ~~~~~~~~~~
-* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.
-* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.
-* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the
-* singular value decomposition on a vector computer.
-* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.
-* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.
-* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular
-* value computation in floating point arithmetic.
-* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.
-* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.
-* LAPACK Working note 169.
-* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.
-* LAPACK Working note 170.
-* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
-* QSVD, (H,K)-SVD computations.
-* Department of Mathematics, University of Zagreb, 2008.
-*
-* Bugs, Examples and Comments
-* ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Please report all bugs and send interesting test examples and comments to
-* drmac at math.hr. Thank you.
-*
-
-* Arguments
-* =========
-*
-* JOBA (input) CHARACTER* 1
-* Specifies the structure of A.
-* = 'L': The input matrix A is lower triangular;
-* = 'U': The input matrix A is upper triangular;
-* = 'G': The input matrix A is general M-by-N matrix, M >= N.
-*
-* JOBU (input) CHARACTER*1
-* Specifies whether to compute the left singular vectors
-* (columns of U):
-* = 'U': The left singular vectors corresponding to the nonzero
-* singular values are computed and returned in the leading
-* columns of A. See more details in the description of A.
-* The default numerical orthogonality threshold is set to
-* approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E').
-* = 'C': Analogous to JOBU='U', except that user can control the
-* level of numerical orthogonality of the computed left
-* singular vectors. TOL can be set to TOL = CTOL*EPS, where
-* CTOL is given on input in the array WORK.
-* No CTOL smaller than ONE is allowed. CTOL greater
-* than 1 / EPS is meaningless. The option 'C'
-* can be used if M*EPS is satisfactory orthogonality
-* of the computed left singular vectors, so CTOL=M could
-* save few sweeps of Jacobi rotations.
-* See the descriptions of A and WORK(1).
-* = 'N': The matrix U is not computed. However, see the
-* description of A.
-*
-* JOBV (input) CHARACTER*1
-* Specifies whether to compute the right singular vectors, that
-* is, the matrix V:
-* = 'V' : the matrix V is computed and returned in the array V
-* = 'A' : the Jacobi rotations are applied to the MV-by-N
-* array V. In other words, the right singular vector
-* matrix V is not computed explicitly, instead it is
-* applied to an MV-by-N matrix initially stored in the
-* first MV rows of V.
-* = 'N' : the matrix V is not computed and the array V is not
-* referenced
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A.
-* M >= N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit :
-* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' :
-* If INFO .EQ. 0 :
-* RANKA orthonormal columns of U are returned in the
-* leading RANKA columns of the array A. Here RANKA <= N
-* is the number of computed singular values of A that are
-* above the underflow threshold DLAMCH('S'). The singular
-* vectors corresponding to underflowed or zero singular
-* values are not computed. The value of RANKA is returned
-* in the array WORK as RANKA=NINT(WORK(2)). Also see the
-* descriptions of SVA and WORK. The computed columns of U
-* are mutually numerically orthogonal up to approximately
-* TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),
-* see the description of JOBU.
-* If INFO .GT. 0 :
-* the procedure DGESVJ did not converge in the given number
-* of iterations (sweeps). In that case, the computed
-* columns of U may not be orthogonal up to TOL. The output
-* U (stored in A), SIGMA (given by the computed singular
-* values in SVA(1:N)) and V is still a decomposition of the
-* input matrix A in the sense that the residual
-* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.
-*
-* If JOBU .EQ. 'N' :
-* If INFO .EQ. 0 :
-* Note that the left singular vectors are 'for free' in the
-* one-sided Jacobi SVD algorithm. However, if only the
-* singular values are needed, the level of numerical
-* orthogonality of U is not an issue and iterations are
-* stopped when the columns of the iterated matrix are
-* numerically orthogonal up to approximately M*EPS. Thus,
-* on exit, A contains the columns of U scaled with the
-* corresponding singular values.
-* If INFO .GT. 0 :
-* the procedure DGESVJ did not converge in the given number
-* of iterations (sweeps).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* SVA (workspace/output) DOUBLE PRECISION array, dimension (N)
-* On exit :
-* If INFO .EQ. 0 :
-* depending on the value SCALE = WORK(1), we have:
-* If SCALE .EQ. ONE :
-* SVA(1:N) contains the computed singular values of A.
-* During the computation SVA contains the Euclidean column
-* norms of the iterated matrices in the array A.
-* If SCALE .NE. ONE :
-* The singular values of A are SCALE*SVA(1:N), and this
-* factored representation is due to the fact that some of the
-* singular values of A might underflow or overflow.
-* If INFO .GT. 0 :
-* the procedure DGESVJ did not converge in the given number of
-* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
-*
-* MV (input) INTEGER
-* If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ
-* is applied to the first MV rows of V. See the description of JOBV.
-*
-* V (input/output) DOUBLE PRECISION array, dimension (LDV,N)
-* If JOBV = 'V', then V contains on exit the N-by-N matrix of
-* the right singular vectors;
-* If JOBV = 'A', then V contains the product of the computed right
-* singular vector matrix and the initial matrix in
-* the array V.
-* If JOBV = 'N', then V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V, LDV .GE. 1.
-* If JOBV .EQ. 'V', then LDV .GE. max(1,N).
-* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .
-*
-* WORK (input/workspace/output) DOUBLE PRECISION array, dimension max(4,M+N).
-* On entry :
-* If JOBU .EQ. 'C' :
-* WORK(1) = CTOL, where CTOL defines the threshold for convergence.
-* The process stops if all columns of A are mutually
-* orthogonal up to CTOL*EPS, EPS=DLAMCH('E').
-* It is required that CTOL >= ONE, i.e. it is not
-* allowed to force the routine to obtain orthogonality
-* below EPS.
-* On exit :
-* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
-* are the computed singular values of A.
-* (See description of SVA().)
-* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero
-* singular values.
-* WORK(3) = NINT(WORK(3)) is the number of the computed singular
-* values that are larger than the underflow threshold.
-* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi
-* rotations needed for numerical convergence.
-* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.
-* This is useful information in cases when DGESVJ did
-* not converge, as it can be used to estimate whether
-* the output is stil useful and for post festum analysis.
-* WORK(6) = the largest absolute value over all sines of the
-* Jacobi rotation angles in the last sweep. It can be
-* useful for a post festum analysis.
-*
-* LWORK (input) INTEGER
-* length of WORK, WORK >= MAX(6,M+N)
-*
-* INFO (output) INTEGER
-* = 0 : successful exit.
-* < 0 : if INFO = -i, then the i-th argument had an illegal value
-* > 0 : DGESVJ did not converge in the maximal allowed number (30)
-* of sweeps. The output may still be useful. See the
-* description of WORK.
-*
-
-* =====================================================================
-*
-* .. Local Parameters ..
- DOUBLE PRECISION ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
- + TWO = 2.0D0 )
- INTEGER NSWEEP
- PARAMETER ( NSWEEP = 30 )
-* ..
-* .. Local Scalars ..
- DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
- + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,
- + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
- + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,
- + THSIGN, TOL
- INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
- + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,
- + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,
- + SWBAND
- LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
- + RSVEC, UCTOL, UPPER
-* ..
-* .. Local Arrays ..
- DOUBLE PRECISION FASTR( 5 )
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT
-* ..
-* .. External Functions ..
-* ..
-* from BLAS
- DOUBLE PRECISION DDOT, DNRM2
- EXTERNAL DDOT, DNRM2
- INTEGER IDAMAX
- EXTERNAL IDAMAX
-* from LAPACK
- DOUBLE PRECISION DLAMCH
- EXTERNAL DLAMCH
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
-* ..
-* from BLAS
- EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP
-* from LAPACK
- EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA
-*
- EXTERNAL DGSVJ0, DGSVJ1
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgesvx"></A>
- <H2>dgesvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.dgesvx( fact, trans, a, af, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.dgesvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGESVX uses the LU factorization to compute the solution to a real
-* system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = P * L * U,
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by DGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N)
-* On exit, WORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If WORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* WORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization has
-* been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgesvxx"></A>
- <H2>dgesvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.dgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.dgesvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGESVXX uses the LU factorization to compute the solution to a
-* double precision system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. DGESVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* DGESVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* DGESVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what DGESVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose = Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by DGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In DGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgetc2"></A>
- <H2>dgetc2</H2>
-
- <PRE>
-USAGE:
- ipiv, jpiv, info, a = NumRu::Lapack.dgetc2( a)
- or
- NumRu::Lapack.dgetc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
-
-* Purpose
-* =======
-*
-* DGETC2 computes an LU factorization with complete pivoting of the
-* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
-* where P and Q are permutation matrices, L is lower triangular with
-* unit diagonal elements and U is upper triangular.
-*
-* This is the Level 2 BLAS algorithm.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the n-by-n matrix A to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U*Q; the unit diagonal elements of L are not stored.
-* If U(k, k) appears to be less than SMIN, U(k, k) is given the
-* value of SMIN, i.e., giving a nonsingular perturbed system.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension(N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (output) INTEGER array, dimension(N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* > 0: if INFO = k, U(k, k) is likely to produce owerflow if
-* we try to solve for x in Ax = b. So U is perturbed to
-* avoid the overflow.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgetf2"></A>
- <H2>dgetf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.dgetf2( m, a)
- or
- NumRu::Lapack.dgetf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DGETF2 computes an LU factorization of a general m-by-n matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the m by n matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgetrf"></A>
- <H2>dgetrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.dgetrf( m, a)
- or
- NumRu::Lapack.dgetrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DGETRF computes an LU factorization of a general M-by-N matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgetri"></A>
- <H2>dgetri</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dgetri( a, ipiv, lwork)
- or
- NumRu::Lapack.dgetri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGETRI computes the inverse of a matrix using the LU factorization
-* computed by DGETRF.
-*
-* This method inverts U and then computes inv(A) by solving the system
-* inv(A)*L = inv(U) for inv(A).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the factors L and U from the factorization
-* A = P*L*U as computed by DGETRF.
-* On exit, if INFO = 0, the inverse of the original matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from DGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimal performance LWORK >= N*NB, where NB is
-* the optimal blocksize returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
-* singular and its inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgetrs"></A>
- <H2>dgetrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dgetrs( trans, a, ipiv, b)
- or
- NumRu::Lapack.dgetrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DGETRS solves a system of linear equations
-* A * X = B or A' * X = B
-* with a general N-by-N matrix A using the LU factorization computed
-* by DGETRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A'* X = B (Transpose)
-* = 'C': A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by DGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from DGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dgg.html b/doc/dgg.html
deleted file mode 100644
index dc29ce5..0000000
--- a/doc/dgg.html
+++ /dev/null
@@ -1,2140 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</H1>
- <UL>
- <LI><A HREF="#dggbak">dggbak</A> : </LI>
- <LI><A HREF="#dggbal">dggbal</A> : </LI>
- <LI><A HREF="#dgges">dgges</A> : </LI>
- <LI><A HREF="#dggesx">dggesx</A> : </LI>
- <LI><A HREF="#dggev">dggev</A> : </LI>
- <LI><A HREF="#dggevx">dggevx</A> : </LI>
- <LI><A HREF="#dggglm">dggglm</A> : </LI>
- <LI><A HREF="#dgghrd">dgghrd</A> : </LI>
- <LI><A HREF="#dgglse">dgglse</A> : </LI>
- <LI><A HREF="#dggqrf">dggqrf</A> : </LI>
- <LI><A HREF="#dggrqf">dggrqf</A> : </LI>
- <LI><A HREF="#dggsvd">dggsvd</A> : </LI>
- <LI><A HREF="#dggsvp">dggsvp</A> : </LI>
- </UL>
-
- <A NAME="dggbak"></A>
- <H2>dggbak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.dggbak( job, side, ilo, ihi, lscale, rscale, v)
- or
- NumRu::Lapack.dggbak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* DGGBAK forms the right or left eigenvectors of a real generalized
-* eigenvalue problem A*x = lambda*B*x, by backward transformation on
-* the computed eigenvectors of the balanced pair of matrices output by
-* DGGBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N': do nothing, return immediately;
-* = 'P': do backward transformation for permutation only;
-* = 'S': do backward transformation for scaling only;
-* = 'B': do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to DGGBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by DGGBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* LSCALE (input) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the left side of A and B, as returned by DGGBAL.
-*
-* RSCALE (input) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the right side of A and B, as returned by DGGBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by DTGEVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the matrix V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. Ward, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFTV, RIGHTV
- INTEGER I, K
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DSCAL, DSWAP, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggbal"></A>
- <H2>dggbal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.dggbal( job, a, b)
- or
- NumRu::Lapack.dggbal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGBAL balances a pair of general real matrices (A,B). This
-* involves, first, permuting A and B by similarity transformations to
-* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
-* elements on the diagonal; and second, applying a diagonal similarity
-* transformation to rows and columns ILO to IHI to make the rows
-* and columns as close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrices, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors in the
-* generalized eigenvalue problem A*x = lambda*B*x.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A and B:
-* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
-* and RSCALE(I) = 1.0 for i = 1,...,N.
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
-* On entry, the input matrix B.
-* On exit, B is overwritten by the balanced matrix.
-* If JOB = 'N', B is not referenced.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If P(j) is the index of the
-* row interchanged with row j, and D(j)
-* is the scaling factor applied to row j, then
-* LSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If P(j) is the index of the
-* column interchanged with column j, and D(j)
-* is the scaling factor applied to column j, then
-* LSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (lwork)
-* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
-* at least 1 when JOB = 'N' or 'P'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. WARD, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgges"></A>
- <H2>dgges</H2>
-
- <PRE>
-USAGE:
- sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b,c| ... }
- or
- NumRu::Lapack.dgges # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
-* the generalized eigenvalues, the generalized real Schur form (S,T),
-* optionally, the left and/or right matrices of Schur vectors (VSL and
-* VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* quasi-triangular matrix S and the upper triangular matrix T.The
-* leading columns of VSL and VSR then form an orthonormal basis for the
-* corresponding left and right eigenspaces (deflating subspaces).
-*
-* (If only the generalized eigenvalues are needed, use the driver
-* DGGEV instead, which is faster.)
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0 or both being zero.
-*
-* A pair of matrices (S,T) is in generalized real Schur form if T is
-* upper triangular with non-negative diagonal and S is block upper
-* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
-* to real generalized eigenvalues, while 2-by-2 blocks of S will be
-* "standardized" by making the corresponding elements of T have the
-* form:
-* [ a 0 ]
-* [ 0 b ]
-*
-* and the pair of corresponding 2-by-2 blocks in S and T will have a
-* complex conjugate pair of generalized eigenvalues.
-*
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG);
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
-* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
-* one of a complex conjugate pair of eigenvalues is selected,
-* then both complex eigenvalues are selected.
-*
-* Note that in the ill-conditioned case, a selected complex
-* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
-* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
-* in this case.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true. (Complex conjugate pairs for which
-* SELCTG is true for either eigenvalue count as 2.)
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
-* and BETA(j),j=1,...,N are the diagonals of the complex Schur
-* form (S,T) that would result if the 2-by-2 diagonal blocks of
-* the real Schur form of (A,B) were further reduced to
-* triangular form using 2-by-2 complex unitary transformations.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio.
-* However, ALPHAR and ALPHAI will be always less than and
-* usually comparable with norm(A) in magnitude, and BETA always
-* less than and usually comparable with norm(B).
-*
-* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N = 0, LWORK >= 1, else LWORK >= 8*N+16.
-* For good performance , LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
-* be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in DHGEQZ.
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering failed in DTGSEN.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggesx"></A>
- <H2>dggesx</H2>
-
- <PRE>
-USAGE:
- sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b,c| ... }
- or
- NumRu::Lapack.dggesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGESX computes for a pair of N-by-N real nonsymmetric matrices
-* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
-* optionally, the left and/or right matrices of Schur vectors (VSL and
-* VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* quasi-triangular matrix S and the upper triangular matrix T; computes
-* a reciprocal condition number for the average of the selected
-* eigenvalues (RCONDE); and computes a reciprocal condition number for
-* the right and left deflating subspaces corresponding to the selected
-* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
-* an orthonormal basis for the corresponding left and right eigenspaces
-* (deflating subspaces).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0 or for both being zero.
-*
-* A pair of matrices (S,T) is in generalized real Schur form if T is
-* upper triangular with non-negative diagonal and S is block upper
-* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
-* to real generalized eigenvalues, while 2-by-2 blocks of S will be
-* "standardized" by making the corresponding elements of T have the
-* form:
-* [ a 0 ]
-* [ 0 b ]
-*
-* and the pair of corresponding 2-by-2 blocks in S and T will have a
-* complex conjugate pair of generalized eigenvalues.
-*
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG).
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
-* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
-* one of a complex conjugate pair of eigenvalues is selected,
-* then both complex eigenvalues are selected.
-* Note that a selected complex eigenvalue may no longer satisfy
-* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
-* since ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned), in this
-* case INFO is set to N+3.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N' : None are computed;
-* = 'E' : Computed for average of selected eigenvalues only;
-* = 'V' : Computed for selected deflating subspaces only;
-* = 'B' : Computed for both.
-* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true. (Complex conjugate pairs for which
-* SELCTG is true for either eigenvalue count as 2.)
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
-* and BETA(j),j=1,...,N are the diagonals of the complex Schur
-* form (S,T) that would result if the 2-by-2 diagonal blocks of
-* the real Schur form of (A,B) were further reduced to
-* triangular form using 2-by-2 complex unitary transformations.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio.
-* However, ALPHAR and ALPHAI will be always less than and
-* usually comparable with norm(A) in magnitude, and BETA always
-* less than and usually comparable with norm(B).
-*
-* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )
-* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
-* reciprocal condition numbers for the average of the selected
-* eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )
-* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
-* reciprocal condition numbers for the selected deflating
-* subspaces.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
-* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
-* LWORK >= max( 8*N, 6*N+16 ).
-* Note that 2*SDIM*(N-SDIM) <= N*N/2.
-* Note also that an error is only returned if
-* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
-* this may not be large enough.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the bound on the optimal size of the WORK
-* array and the minimum size of the IWORK array, returns these
-* values as the first entries of the WORK and IWORK arrays, and
-* no error message related to LWORK or LIWORK is issued by
-* XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
-* LIWORK >= N+6.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the bound on the optimal size of the
-* WORK array and the minimum size of the IWORK array, returns
-* these values as the first entries of the WORK and IWORK
-* arrays, and no error message related to LWORK or LIWORK is
-* issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
-* be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in DHGEQZ
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering failed in DTGSEN.
-*
-
-* Further Details
-* ===============
-*
-* An approximate (asymptotic) bound on the average absolute error of
-* the selected eigenvalues is
-*
-* EPS * norm((A, B)) / RCONDE( 1 ).
-*
-* An approximate (asymptotic) bound on the maximum angular error in
-* the computed deflating subspaces is
-*
-* EPS * norm((A, B)) / RCONDV( 2 ).
-*
-* See LAPACK User's Guide, section 4.11 for more information.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggev"></A>
- <H2>dggev</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dggev( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.dggev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
-* the generalized eigenvalues, and optionally, the left and/or right
-* generalized eigenvectors.
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* A * v(j) = lambda(j) * B * v(j).
-*
-* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* u(j)**H * A = lambda(j) * u(j)**H * B .
-*
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. If ALPHAI(j) is zero, then
-* the j-th eigenvalue is real; if positive, then the j-th and
-* (j+1)-st eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio
-* alpha/beta. However, ALPHAR and ALPHAI will be always less
-* than and usually comparable with norm(A) in magnitude, and
-* BETA always less than and usually comparable with norm(B).
-*
-* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* u(j) = VL(:,j), the j-th column of VL. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
-* Each eigenvector is scaled so the largest component has
-* abs(real part)+abs(imag. part)=1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* v(j) = VR(:,j), the j-th column of VR. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
-* Each eigenvector is scaled so the largest component has
-* abs(real part)+abs(imag. part)=1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,8*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
-* should be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in DHGEQZ.
-* =N+2: error return from DTGEVC.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggevx"></A>
- <H2>dggevx</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggevx( balanc, jobvl, jobvr, sense, a, b, lwork)
- or
- NumRu::Lapack.dggevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
-* the generalized eigenvalues, and optionally, the left and/or right
-* generalized eigenvectors.
-*
-* Optionally also, it computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
-* the eigenvalues (RCONDE), and reciprocal condition numbers for the
-* right eigenvectors (RCONDV).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* A * v(j) = lambda(j) * B * v(j) .
-*
-* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* u(j)**H * A = lambda(j) * u(j)**H * B.
-*
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Specifies the balance option to be performed.
-* = 'N': do not diagonally scale or permute;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-* Computed reciprocal condition numbers will be for the
-* matrices after permuting and/or balancing. Permuting does
-* not change condition numbers (in exact arithmetic), but
-* balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': none are computed;
-* = 'E': computed for eigenvalues only;
-* = 'V': computed for eigenvectors only;
-* = 'B': computed for eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then A contains the first part of the real Schur
-* form of the "balanced" versions of the input A and B.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then B contains the second part of the real Schur
-* form of the "balanced" versions of the input A and B.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. If ALPHAI(j) is zero, then
-* the j-th eigenvalue is real; if positive, then the j-th and
-* (j+1)-st eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio
-* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
-* than and usually comparable with norm(A) in magnitude, and
-* BETA always less than and usually comparable with norm(B).
-*
-* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* u(j) = VL(:,j), the j-th column of VL. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
-* Each eigenvector will be scaled so the largest component have
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* v(j) = VR(:,j), the j-th column of VR. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
-* Each eigenvector will be scaled so the largest component have
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If PL(j) is the index of the
-* row interchanged with row j, and DL(j) is the scaling
-* factor applied to row j, then
-* LSCALE(j) = PL(j) for j = 1,...,ILO-1
-* = DL(j) for j = ILO,...,IHI
-* = PL(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If PR(j) is the index of the
-* column interchanged with column j, and DR(j) is the scaling
-* factor applied to column j, then
-* RSCALE(j) = PR(j) for j = 1,...,ILO-1
-* = DR(j) for j = ILO,...,IHI
-* = PR(j) for j = IHI+1,...,N
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) DOUBLE PRECISION
-* The one-norm of the balanced matrix A.
-*
-* BBNRM (output) DOUBLE PRECISION
-* The one-norm of the balanced matrix B.
-*
-* RCONDE (output) DOUBLE PRECISION array, dimension (N)
-* If SENSE = 'E' or 'B', the reciprocal condition numbers of
-* the eigenvalues, stored in consecutive elements of the array.
-* For a complex conjugate pair of eigenvalues two consecutive
-* elements of RCONDE are set to the same value. Thus RCONDE(j),
-* RCONDV(j), and the j-th columns of VL and VR all correspond
-* to the j-th eigenpair.
-* If SENSE = 'N or 'V', RCONDE is not referenced.
-*
-* RCONDV (output) DOUBLE PRECISION array, dimension (N)
-* If SENSE = 'V' or 'B', the estimated reciprocal condition
-* numbers of the eigenvectors, stored in consecutive elements
-* of the array. For a complex eigenvector two consecutive
-* elements of RCONDV are set to the same value. If the
-* eigenvalues cannot be reordered to compute RCONDV(j),
-* RCONDV(j) is set to 0; this can only occur when the true
-* value would be very small anyway.
-* If SENSE = 'N' or 'E', RCONDV is not referenced.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
-* LWORK >= max(1,6*N).
-* If SENSE = 'E' or 'B', LWORK >= max(1,10*N).
-* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (N+6)
-* If SENSE = 'E', IWORK is not referenced.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* If SENSE = 'N', BWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
-* should be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in DHGEQZ.
-* =N+2: error return from DTGEVC.
-*
-
-* Further Details
-* ===============
-*
-* Balancing a matrix pair (A,B) includes, first, permuting rows and
-* columns to isolate eigenvalues, second, applying diagonal similarity
-* transformation to the rows and columns to make the rows and columns
-* as close in norm as possible. The computed reciprocal condition
-* numbers correspond to the balanced matrix. Permuting rows and columns
-* will not change the condition numbers (in exact arithmetic) but
-* diagonal scaling will. For further explanation of balancing, see
-* section 4.11.1.2 of LAPACK Users' Guide.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
-*
-* An approximate error bound for the angle between the i-th computed
-* eigenvector VL(i) or VR(i) is given by
-*
-* EPS * norm(ABNRM, BBNRM) / DIF(i).
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see section 4.11 of LAPACK User's Guide.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggglm"></A>
- <H2>dggglm</H2>
-
- <PRE>
-USAGE:
- x, y, work, info, a, b, d = NumRu::Lapack.dggglm( a, b, d, lwork)
- or
- NumRu::Lapack.dggglm # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGGLM solves a general Gauss-Markov linear model (GLM) problem:
-*
-* minimize || y ||_2 subject to d = A*x + B*y
-* x
-*
-* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
-* given N-vector. It is assumed that M <= N <= M+P, and
-*
-* rank(A) = M and rank( A B ) = N.
-*
-* Under these assumptions, the constrained equation is always
-* consistent, and there is a unique solution x and a minimal 2-norm
-* solution y, which is obtained using a generalized QR factorization
-* of the matrices (A, B) given by
-*
-* A = Q*(R), B = Q*T*Z.
-* (0)
-*
-* In particular, if matrix B is square nonsingular, then the problem
-* GLM is equivalent to the following weighted linear least squares
-* problem
-*
-* minimize || inv(B)*(d-A*x) ||_2
-* x
-*
-* where inv(B) denotes the inverse of B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. 0 <= M <= N.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= N-M.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the upper triangular part of the array A contains
-* the M-by-M upper triangular matrix R.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, D is the left hand side of the GLM equation.
-* On exit, D is destroyed.
-*
-* X (output) DOUBLE PRECISION array, dimension (M)
-* Y (output) DOUBLE PRECISION array, dimension (P)
-* On exit, X and Y are the solutions of the GLM problem.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N+M+P).
-* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* DGEQRF, SGERQF, DORMQR and SORMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with A in the
-* generalized QR factorization of the pair (A, B) is
-* singular, so that rank(A) < M; the least squares
-* solution could not be computed.
-* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
-* factor T associated with B in the generalized QR
-* factorization of the pair (A, B) is singular, so that
-* rank( A B ) < N; the least squares solution could not
-* be computed.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgghrd"></A>
- <H2>dgghrd</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.dgghrd( compq, compz, ilo, ihi, a, b, q, z)
- or
- NumRu::Lapack.dgghrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )
-
-* Purpose
-* =======
-*
-* DGGHRD reduces a pair of real matrices (A,B) to generalized upper
-* Hessenberg form using orthogonal transformations, where A is a
-* general matrix and B is upper triangular. The form of the
-* generalized eigenvalue problem is
-* A*x = lambda*B*x,
-* and B is typically made upper triangular by computing its QR
-* factorization and moving the orthogonal matrix Q to the left side
-* of the equation.
-*
-* This subroutine simultaneously reduces A to a Hessenberg matrix H:
-* Q**T*A*Z = H
-* and transforms B to another upper triangular matrix T:
-* Q**T*B*Z = T
-* in order to reduce the problem to its standard form
-* H*y = lambda*T*y
-* where y = Z**T*x.
-*
-* The orthogonal matrices Q and Z are determined as products of Givens
-* rotations. They may either be formed explicitly, or they may be
-* postmultiplied into input matrices Q1 and Z1, so that
-*
-* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
-*
-* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
-*
-* If Q1 is the orthogonal matrix from the QR factorization of B in the
-* original equation A*x = lambda*B*x, then DGGHRD reduces the original
-* problem to generalized Hessenberg form.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': do not compute Q;
-* = 'I': Q is initialized to the unit matrix, and the
-* orthogonal matrix Q is returned;
-* = 'V': Q must contain an orthogonal matrix Q1 on entry,
-* and the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': do not compute Z;
-* = 'I': Z is initialized to the unit matrix, and the
-* orthogonal matrix Z is returned;
-* = 'V': Z must contain an orthogonal matrix Z1 on entry,
-* and the product Z1*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of A which are to be
-* reduced. It is assumed that A is already upper triangular
-* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
-* normally set by a previous call to SGGBAL; otherwise they
-* should be set to 1 and N respectively.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* rest is set to zero.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the N-by-N upper triangular matrix B.
-* On exit, the upper triangular matrix T = Q**T B Z. The
-* elements below the diagonal are set to zero.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
-* On entry, if COMPQ = 'V', the orthogonal matrix Q1,
-* typically from the QR factorization of B.
-* On exit, if COMPQ='I', the orthogonal matrix Q, and if
-* COMPQ = 'V', the product Q1*Q.
-* Not referenced if COMPQ='N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix Z1.
-* On exit, if COMPZ='I', the orthogonal matrix Z, and if
-* COMPZ = 'V', the product Z1*Z.
-* Not referenced if COMPZ='N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z.
-* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* This routine reduces A to Hessenberg and B to triangular form by
-* an unblocked reduction, as described in _Matrix_Computations_,
-* by Golub and Van Loan (Johns Hopkins Press.)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgglse"></A>
- <H2>dgglse</H2>
-
- <PRE>
-USAGE:
- x, work, info, a, b, c, d = NumRu::Lapack.dgglse( a, b, c, d, lwork)
- or
- NumRu::Lapack.dgglse # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGLSE solves the linear equality-constrained least squares (LSE)
-* problem:
-*
-* minimize || c - A*x ||_2 subject to B*x = d
-*
-* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
-* M-vector, and d is a given P-vector. It is assumed that
-* P <= N <= M+P, and
-*
-* rank(B) = P and rank( (A) ) = N.
-* ( (B) )
-*
-* These conditions ensure that the LSE problem has a unique solution,
-* which is obtained using a generalized RQ factorization of the
-* matrices (B, A) given by
-*
-* B = (0 R)*Q, A = Z*T*Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. 0 <= P <= N <= M+P.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
-* contains the P-by-P upper triangular matrix R.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* C (input/output) DOUBLE PRECISION array, dimension (M)
-* On entry, C contains the right hand side vector for the
-* least squares part of the LSE problem.
-* On exit, the residual sum of squares for the solution
-* is given by the sum of squares of elements N-P+1 to M of
-* vector C.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (P)
-* On entry, D contains the right hand side vector for the
-* constrained equation.
-* On exit, D is destroyed.
-*
-* X (output) DOUBLE PRECISION array, dimension (N)
-* On exit, X is the solution of the LSE problem.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M+N+P).
-* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* DGEQRF, SGERQF, DORMQR and SORMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with B in the
-* generalized RQ factorization of the pair (B, A) is
-* singular, so that rank(B) < P; the least squares
-* solution could not be computed.
-* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
-* T associated with A in the generalized RQ factorization
-* of the pair (B, A) is singular, so that
-* rank( (A) ) < N; the least squares solution could not
-* ( (B) )
-* be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggqrf"></A>
- <H2>dggqrf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.dggqrf( n, a, b, lwork)
- or
- NumRu::Lapack.dggqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGQRF computes a generalized QR factorization of an N-by-M matrix A
-* and an N-by-P matrix B:
-*
-* A = Q*R, B = Q*T*Z,
-*
-* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
-* matrix, and R and T assume one of the forms:
-*
-* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
-* ( 0 ) N-M N M-N
-* M
-*
-* where R11 is upper triangular, and
-*
-* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
-* P-N N ( T21 ) P
-* P
-*
-* where T12 or T21 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GQR factorization
-* of A and B implicitly gives the QR factorization of inv(B)*A:
-*
-* inv(B)*A = Z'*(inv(T)*R)
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* transpose of the matrix Z.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
-* upper triangular if N >= M); the elements below the diagonal,
-* with the array TAUA, represent the orthogonal matrix Q as a
-* product of min(N,M) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q (see Further Details).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)-th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T; the remaining
-* elements, with the array TAUB, represent the orthogonal
-* matrix Z as a product of elementary reflectors (see Further
-* Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Z (see Further Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the QR factorization
-* of an N-by-M matrix, NB2 is the optimal blocksize for the
-* RQ factorization of an N-by-P matrix, and NB3 is the optimal
-* blocksize for a call of DORMQR.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(n,m).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
-* and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine DORGQR.
-* To use Q to update another matrix, use LAPACK subroutine DORMQR.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(n,p).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a real scalar, and v is a real vector with
-* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
-* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine DORGRQ.
-* To use Z to update another matrix, use LAPACK subroutine DORMRQ.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggrqf"></A>
- <H2>dggrqf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.dggrqf( m, p, a, b, lwork)
- or
- NumRu::Lapack.dggrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A
-* and a P-by-N matrix B:
-*
-* A = R*Q, B = Z*T*Q,
-*
-* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
-* matrix, and R and T assume one of the forms:
-*
-* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
-* N-M M ( R21 ) N
-* N
-*
-* where R12 or R21 is upper triangular, and
-*
-* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
-* ( 0 ) P-N P N-P
-* N
-*
-* where T11 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GRQ factorization
-* of A and B implicitly gives the RQ factorization of A*inv(B):
-*
-* A*inv(B) = (R*inv(T))*Z'
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* transpose of the matrix Z.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, if M <= N, the upper triangle of the subarray
-* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
-* if M > N, the elements on and above the (M-N)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R; the remaining
-* elements, with the array TAUA, represent the orthogonal
-* matrix Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q (see Further Details).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
-* upper triangular if P >= N); the elements below the diagonal,
-* with the array TAUB, represent the orthogonal matrix Z as a
-* product of elementary reflectors (see Further Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Z (see Further Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the RQ factorization
-* of an M-by-N matrix, NB2 is the optimal blocksize for the
-* QR factorization of a P-by-N matrix, and NB3 is the optimal
-* blocksize for a call of DORMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INF0= -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a real scalar, and v is a real vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine DORGRQ.
-* To use Q to update another matrix, use LAPACK subroutine DORMRQ.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(p,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
-* and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine DORGQR.
-* To use Z to update another matrix, use LAPACK subroutine DORMQR.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggsvd"></A>
- <H2>dggsvd</H2>
-
- <PRE>
-USAGE:
- k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.dggsvd( jobu, jobv, jobq, a, b)
- or
- NumRu::Lapack.dggsvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGSVD computes the generalized singular value decomposition (GSVD)
-* of an M-by-N real matrix A and P-by-N real matrix B:
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
-*
-* where U, V and Q are orthogonal matrices, and Z' is the transpose
-* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',
-* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
-* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
-* following structures, respectively:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 )
-* L ( 0 0 R22 )
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The routine computes C, S, R, and optionally the orthogonal
-* transformation matrices U, V and Q.
-*
-* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
-* A and B implicitly gives the SVD of A*inv(B):
-* A*inv(B) = U*(D1*inv(D2))*V'.
-* If ( A',B')' has orthonormal columns, then the GSVD of A and B is
-* also equal to the CS decomposition of A and B. Furthermore, the GSVD
-* can be used to derive the solution of the eigenvalue problem:
-* A'*A x = lambda* B'*B x.
-* In some literature, the GSVD of A and B is presented in the form
-* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
-* where U and V are orthogonal and X is nonsingular, D1 and D2 are
-* ``diagonal''. The former GSVD form can be converted to the latter
-* form by taking the nonsingular matrix X as
-*
-* X = Q*( I 0 )
-* ( 0 inv(R) ).
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Orthogonal matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Orthogonal matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Orthogonal matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in the Purpose section.
-* K + L = effective numerical rank of (A',B')'.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular matrix R, or part of R.
-* See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains the triangular matrix R if M-K-L < 0.
-* See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* ALPHA (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = C,
-* BETA(K+1:K+L) = S,
-* or if M-K-L < 0,
-* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
-* BETA(K+1:M) =S, BETA(M+1:K+L) =1
-* and
-* ALPHA(K+L+1:N) = 0
-* BETA(K+L+1:N) = 0
-*
-* U (output) DOUBLE PRECISION array, dimension (LDU,M)
-* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) DOUBLE PRECISION array, dimension (LDV,P)
-* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) DOUBLE PRECISION array,
-* dimension (max(3*N,M,P)+N)
-*
-* IWORK (workspace/output) INTEGER array, dimension (N)
-* On exit, IWORK stores the sorting information. More
-* precisely, the following loop will sort ALPHA
-* for I = K+1, min(M,K+L)
-* swap ALPHA(I) and ALPHA(IWORK(I))
-* endfor
-* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = 1, the Jacobi-type procedure failed to
-* converge. For further details, see subroutine DTGSJA.
-*
-* Internal Parameters
-* ===================
-*
-* TOLA DOUBLE PRECISION
-* TOLB DOUBLE PRECISION
-* TOLA and TOLB are the thresholds to determine the effective
-* rank of (A',B')'. Generally, they are set to
-* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
-* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-
-* Further Details
-* ===============
-*
-* 2-96 Based on modifications by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL WANTQ, WANTU, WANTV
- INTEGER I, IBND, ISUB, J, NCYCLE
- DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- DOUBLE PRECISION DLAMCH, DLANGE
- EXTERNAL LSAME, DLAMCH, DLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL DCOPY, DGGSVP, DTGSJA, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dggsvp"></A>
- <H2>dggsvp</H2>
-
- <PRE>
-USAGE:
- k, l, u, v, q, info, a, b = NumRu::Lapack.dggsvp( jobu, jobv, jobq, a, b, tola, tolb)
- or
- NumRu::Lapack.dggsvp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DGGSVP computes orthogonal matrices U, V and Q such that
-*
-* N-K-L K L
-* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* V'*B*Q = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
-* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
-* transpose of Z.
-*
-* This decomposition is the preprocessing step for computing the
-* Generalized Singular Value Decomposition (GSVD), see subroutine
-* DGGSVD.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Orthogonal matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Orthogonal matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Orthogonal matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular (or trapezoidal) matrix
-* described in the Purpose section.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains the triangular matrix described in
-* the Purpose section.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) DOUBLE PRECISION
-* TOLB (input) DOUBLE PRECISION
-* TOLA and TOLB are the thresholds to determine the effective
-* numerical rank of matrix B and a subblock of A. Generally,
-* they are set to
-* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
-* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in Purpose.
-* K + L = effective numerical rank of (A',B')'.
-*
-* U (output) DOUBLE PRECISION array, dimension (LDU,M)
-* If JOBU = 'U', U contains the orthogonal matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) DOUBLE PRECISION array, dimension (LDV,P)
-* If JOBV = 'V', V contains the orthogonal matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the orthogonal matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* TAU (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-*
-
-* Further Details
-* ===============
-*
-* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization
-* with column pivoting to detect the effective numerical rank of the
-* a matrix. It may be replaced by a better rank determination strategy.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dgt.html b/doc/dgt.html
deleted file mode 100644
index aad7a01..0000000
--- a/doc/dgt.html
+++ /dev/null
@@ -1,733 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for general tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for general tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#dgtcon">dgtcon</A> : </LI>
- <LI><A HREF="#dgtrfs">dgtrfs</A> : </LI>
- <LI><A HREF="#dgtsv">dgtsv</A> : </LI>
- <LI><A HREF="#dgtsvx">dgtsvx</A> : </LI>
- <LI><A HREF="#dgttrf">dgttrf</A> : </LI>
- <LI><A HREF="#dgttrs">dgttrs</A> : </LI>
- <LI><A HREF="#dgtts2">dgtts2</A> : </LI>
- </UL>
-
- <A NAME="dgtcon"></A>
- <H2>dgtcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dgtcon( norm, dl, d, du, du2, ipiv, anorm)
- or
- NumRu::Lapack.dgtcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGTCON estimates the reciprocal of the condition number of a real
-* tridiagonal matrix A using the LU factorization as computed by
-* DGTTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* DL (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by DGTTRF.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* ANORM (input) DOUBLE PRECISION
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgtrfs"></A>
- <H2>dgtrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)
- or
- NumRu::Lapack.dgtrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is tridiagonal, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of A.
-*
-* DU (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by DGTTRF.
-*
-* DF (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DUF (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgtsv"></A>
- <H2>dgtsv</H2>
-
- <PRE>
-USAGE:
- info, dl, d, du, b = NumRu::Lapack.dgtsv( dl, d, du, b)
- or
- NumRu::Lapack.dgtsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DGTSV solves the equation
-*
-* A*X = B,
-*
-* where A is an n by n tridiagonal matrix, by Gaussian elimination with
-* partial pivoting.
-*
-* Note that the equation A'*X = B may be solved by interchanging the
-* order of the arguments DU and DL.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, DL must contain the (n-1) sub-diagonal elements of
-* A.
-*
-* On exit, DL is overwritten by the (n-2) elements of the
-* second super-diagonal of the upper triangular matrix U from
-* the LU factorization of A, in DL(1), ..., DL(n-2).
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-*
-* On exit, D is overwritten by the n diagonal elements of U.
-*
-* DU (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, DU must contain the (n-1) super-diagonal elements
-* of A.
-*
-* On exit, DU is overwritten by the (n-1) elements of the first
-* super-diagonal of U.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N by NRHS matrix of right hand side matrix B.
-* On exit, if INFO = 0, the N by NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
-* has not been computed. The factorization has not been
-* completed unless i = N.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgtsvx"></A>
- <H2>dgtsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.dgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)
- or
- NumRu::Lapack.dgtsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DGTSVX uses the LU factorization to compute the solution to a real
-* system of linear equations A * X = B or A**T * X = B,
-* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
-* as A = L * U, where L is a product of permutation and unit lower
-* bidiagonal matrices and U is upper triangular with nonzeros in
-* only the main diagonal and first two superdiagonals.
-*
-* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
-* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
-* will not be modified.
-* = 'N': The matrix will be copied to DLF, DF, and DUF
-* and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of A.
-*
-* DU (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input or output) DOUBLE PRECISION array, dimension (N-1)
-* If FACT = 'F', then DLF is an input argument and on entry
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A as computed by DGTTRF.
-*
-* If FACT = 'N', then DLF is an output argument and on exit
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A.
-*
-* DF (input or output) DOUBLE PRECISION array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* DUF (input or output) DOUBLE PRECISION array, dimension (N-1)
-* If FACT = 'F', then DUF is an input argument and on entry
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* If FACT = 'N', then DUF is an output argument and on exit
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2)
-* If FACT = 'F', then DU2 is an input argument and on entry
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* If FACT = 'N', then DU2 is an output argument and on exit
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the LU factorization of A as
-* computed by DGTTRF.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the LU factorization of A;
-* row i of the matrix was interchanged with row IPIV(i).
-* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
-* a row interchange was not required.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has not been completed unless i = N, but the
-* factor U is exactly singular, so the solution
-* and error bounds could not be computed.
-* RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgttrf"></A>
- <H2>dgttrf</H2>
-
- <PRE>
-USAGE:
- du2, ipiv, info, dl, d, du = NumRu::Lapack.dgttrf( dl, d, du)
- or
- NumRu::Lapack.dgttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DGTTRF computes an LU factorization of a real tridiagonal matrix A
-* using elimination with partial pivoting and row interchanges.
-*
-* The factorization has the form
-* A = L * U
-* where L is a product of permutation and unit lower bidiagonal
-* matrices and U is upper triangular with nonzeros in only the main
-* diagonal and first two superdiagonals.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* DL (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, DL must contain the (n-1) sub-diagonal elements of
-* A.
-*
-* On exit, DL is overwritten by the (n-1) multipliers that
-* define the matrix L from the LU factorization of A.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-*
-* On exit, D is overwritten by the n diagonal elements of the
-* upper triangular matrix U from the LU factorization of A.
-*
-* DU (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, DU must contain the (n-1) super-diagonal elements
-* of A.
-*
-* On exit, DU is overwritten by the (n-1) elements of the first
-* super-diagonal of U.
-*
-* DU2 (output) DOUBLE PRECISION array, dimension (N-2)
-* On exit, DU2 is overwritten by the (n-2) elements of the
-* second super-diagonal of U.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgttrs"></A>
- <H2>dgttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dgttrs( trans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.dgttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DGTTRS solves one of the systems of equations
-* A*X = B or A'*X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by DGTTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A'* X = B (Transpose)
-* = 'C': A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL NOTRAN
- INTEGER ITRANS, J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DGTTS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dgtts2"></A>
- <H2>dgtts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.dgtts2( itrans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.dgtts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
-
-* Purpose
-* =======
-*
-* DGTTS2 solves one of the systems of equations
-* A*X = B or A'*X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by DGTTRF.
-*
-
-* Arguments
-* =========
-*
-* ITRANS (input) INTEGER
-* Specifies the form of the system of equations.
-* = 0: A * X = B (No transpose)
-* = 1: A'* X = B (Transpose)
-* = 2: A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, IP, J
- DOUBLE PRECISION TEMP
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dhg.html b/doc/dhg.html
deleted file mode 100644
index 58e35fc..0000000
--- a/doc/dhg.html
+++ /dev/null
@@ -1,227 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</H1>
- <UL>
- <LI><A HREF="#dhgeqz">dhgeqz</A> : </LI>
- </UL>
-
- <A NAME="dhgeqz"></A>
- <H2>dhgeqz</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.dhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)
- or
- NumRu::Lapack.dhgeqz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DHGEQZ computes the eigenvalues of a real matrix pair (H,T),
-* where H is an upper Hessenberg matrix and T is upper triangular,
-* using the double-shift QZ method.
-* Matrix pairs of this type are produced by the reduction to
-* generalized upper Hessenberg form of a real matrix pair (A,B):
-*
-* A = Q1*H*Z1**T, B = Q1*T*Z1**T,
-*
-* as computed by DGGHRD.
-*
-* If JOB='S', then the Hessenberg-triangular pair (H,T) is
-* also reduced to generalized Schur form,
-*
-* H = Q*S*Z**T, T = Q*P*Z**T,
-*
-* where Q and Z are orthogonal matrices, P is an upper triangular
-* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
-* diagonal blocks.
-*
-* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
-* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
-* eigenvalues.
-*
-* Additionally, the 2-by-2 upper triangular diagonal blocks of P
-* corresponding to 2-by-2 blocks of S are reduced to positive diagonal
-* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
-* P(j,j) > 0, and P(j+1,j+1) > 0.
-*
-* Optionally, the orthogonal matrix Q from the generalized Schur
-* factorization may be postmultiplied into an input matrix Q1, and the
-* orthogonal matrix Z may be postmultiplied into an input matrix Z1.
-* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced
-* the matrix pair (A,B) to generalized upper Hessenberg form, then the
-* output matrices Q1*Q and Z1*Z are the orthogonal factors from the
-* generalized Schur factorization of (A,B):
-*
-* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.
-*
-* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
-* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
-* complex and beta real.
-* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
-* generalized nonsymmetric eigenvalue problem (GNEP)
-* A*x = lambda*B*x
-* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
-* alternate form of the GNEP
-* mu*A*y = B*y.
-* Real eigenvalues can be read directly from the generalized Schur
-* form:
-* alpha = S(i,i), beta = P(i,i).
-*
-* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
-* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
-* pp. 241--256.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': Compute eigenvalues only;
-* = 'S': Compute eigenvalues and the Schur form.
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': Left Schur vectors (Q) are not computed;
-* = 'I': Q is initialized to the unit matrix and the matrix Q
-* of left Schur vectors of (H,T) is returned;
-* = 'V': Q must contain an orthogonal matrix Q1 on entry and
-* the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Right Schur vectors (Z) are not computed;
-* = 'I': Z is initialized to the unit matrix and the matrix Z
-* of right Schur vectors of (H,T) is returned;
-* = 'V': Z must contain an orthogonal matrix Z1 on entry and
-* the product Z1*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrices H, T, Q, and Z. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of H which are in
-* Hessenberg form. It is assumed that A is already upper
-* triangular in rows and columns 1:ILO-1 and IHI+1:N.
-* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
-*
-* H (input/output) DOUBLE PRECISION array, dimension (LDH, N)
-* On entry, the N-by-N upper Hessenberg matrix H.
-* On exit, if JOB = 'S', H contains the upper quasi-triangular
-* matrix S from the generalized Schur factorization;
-* 2-by-2 diagonal blocks (corresponding to complex conjugate
-* pairs of eigenvalues) are returned in standard form, with
-* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.
-* If JOB = 'E', the diagonal blocks of H match those of S, but
-* the rest of H is unspecified.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max( 1, N ).
-*
-* T (input/output) DOUBLE PRECISION array, dimension (LDT, N)
-* On entry, the N-by-N upper triangular matrix T.
-* On exit, if JOB = 'S', T contains the upper triangular
-* matrix P from the generalized Schur factorization;
-* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
-* are reduced to positive diagonal form, i.e., if H(j+1,j) is
-* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
-* T(j+1,j+1) > 0.
-* If JOB = 'E', the diagonal blocks of T match those of P, but
-* the rest of T is unspecified.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max( 1, N ).
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* The real parts of each scalar alpha defining an eigenvalue
-* of GNEP.
-*
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* The imaginary parts of each scalar alpha defining an
-* eigenvalue of GNEP.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
-*
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* The scalars beta that define the eigenvalues of GNEP.
-* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
-* beta = BETA(j) represent the j-th eigenvalue of the matrix
-* pair (A,B), in one of the forms lambda = alpha/beta or
-* mu = beta/alpha. Since either lambda or mu may overflow,
-* they should not, in general, be computed.
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in
-* the reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur
-* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix
-* of left Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If COMPQ='V' or 'I', then LDQ >= N.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
-* the reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the orthogonal matrix of
-* right Schur vectors of (H,T), and if COMPZ = 'V', the
-* orthogonal matrix of right Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If COMPZ='V' or 'I', then LDZ >= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1,...,N: the QZ iteration did not converge. (H,T) is not
-* in Schur form, but ALPHAR(i), ALPHAI(i), and
-* BETA(i), i=INFO+1,...,N should be correct.
-* = N+1,...,2*N: the shift calculation failed. (H,T) is not
-* in Schur form, but ALPHAR(i), ALPHAI(i), and
-* BETA(i), i=INFO-N+1,...,N should be correct.
-*
-
-* Further Details
-* ===============
-*
-* Iteration counters:
-*
-* JITER -- counts iterations.
-* IITER -- counts iterations run since ILAST was last
-* changed. This is therefore reset only when a 1-by-1 or
-* 2-by-2 block deflates off the bottom.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dhs.html b/doc/dhs.html
deleted file mode 100644
index 1442bc4..0000000
--- a/doc/dhs.html
+++ /dev/null
@@ -1,419 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for upper Hessenberg matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for upper Hessenberg matrix</H1>
- <UL>
- <LI><A HREF="#dhsein">dhsein</A> : </LI>
- <LI><A HREF="#dhseqr">dhseqr</A> : </LI>
- </UL>
-
- <A NAME="dhsein"></A>
- <H2>dhsein</H2>
-
- <PRE>
-USAGE:
- m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.dhsein( side, eigsrc, initv, select, h, wr, wi, vl, vr)
- or
- NumRu::Lapack.dhsein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )
-
-* Purpose
-* =======
-*
-* DHSEIN uses inverse iteration to find specified right and/or left
-* eigenvectors of a real upper Hessenberg matrix H.
-*
-* The right eigenvector x and the left eigenvector y of the matrix H
-* corresponding to an eigenvalue w are defined by:
-*
-* H * x = w * x, y**h * H = w * y**h
-*
-* where y**h denotes the conjugate transpose of the vector y.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* EIGSRC (input) CHARACTER*1
-* Specifies the source of eigenvalues supplied in (WR,WI):
-* = 'Q': the eigenvalues were found using DHSEQR; thus, if
-* H has zero subdiagonal elements, and so is
-* block-triangular, then the j-th eigenvalue can be
-* assumed to be an eigenvalue of the block containing
-* the j-th row/column. This property allows DHSEIN to
-* perform inverse iteration on just one diagonal block.
-* = 'N': no assumptions are made on the correspondence
-* between eigenvalues and diagonal blocks. In this
-* case, DHSEIN must always perform inverse iteration
-* using the whole matrix H.
-*
-* INITV (input) CHARACTER*1
-* = 'N': no initial vectors are supplied;
-* = 'U': user-supplied initial vectors are stored in the arrays
-* VL and/or VR.
-*
-* SELECT (input/output) LOGICAL array, dimension (N)
-* Specifies the eigenvectors to be computed. To select the
-* real eigenvector corresponding to a real eigenvalue WR(j),
-* SELECT(j) must be set to .TRUE.. To select the complex
-* eigenvector corresponding to a complex eigenvalue
-* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
-* either SELECT(j) or SELECT(j+1) or both must be set to
-* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
-* .FALSE..
-*
-* N (input) INTEGER
-* The order of the matrix H. N >= 0.
-*
-* H (input) DOUBLE PRECISION array, dimension (LDH,N)
-* The upper Hessenberg matrix H.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max(1,N).
-*
-* WR (input/output) DOUBLE PRECISION array, dimension (N)
-* WI (input) DOUBLE PRECISION array, dimension (N)
-* On entry, the real and imaginary parts of the eigenvalues of
-* H; a complex conjugate pair of eigenvalues must be stored in
-* consecutive elements of WR and WI.
-* On exit, WR may have been altered since close eigenvalues
-* are perturbed slightly in searching for independent
-* eigenvectors.
-*
-* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
-* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
-* contain starting vectors for the inverse iteration for the
-* left eigenvectors; the starting vector for each eigenvector
-* must be in the same column(s) in which the eigenvector will
-* be stored.
-* On exit, if SIDE = 'L' or 'B', the left eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VL, in the same order as their eigenvalues. A
-* complex eigenvector corresponding to a complex eigenvalue is
-* stored in two consecutive columns, the first holding the real
-* part and the second the imaginary part.
-* If SIDE = 'R', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
-*
-* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
-* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
-* contain starting vectors for the inverse iteration for the
-* right eigenvectors; the starting vector for each eigenvector
-* must be in the same column(s) in which the eigenvector will
-* be stored.
-* On exit, if SIDE = 'R' or 'B', the right eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VR, in the same order as their eigenvalues. A
-* complex eigenvector corresponding to a complex eigenvalue is
-* stored in two consecutive columns, the first holding the real
-* part and the second the imaginary part.
-* If SIDE = 'L', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR required to
-* store the eigenvectors; each selected real eigenvector
-* occupies one column and each selected complex eigenvector
-* occupies two columns.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)
-*
-* IFAILL (output) INTEGER array, dimension (MM)
-* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
-* eigenvector in the i-th column of VL (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
-* eigenvector converged satisfactorily. If the i-th and (i+1)th
-* columns of VL hold a complex eigenvector, then IFAILL(i) and
-* IFAILL(i+1) are set to the same value.
-* If SIDE = 'R', IFAILL is not referenced.
-*
-* IFAILR (output) INTEGER array, dimension (MM)
-* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
-* eigenvector in the i-th column of VR (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
-* eigenvector converged satisfactorily. If the i-th and (i+1)th
-* columns of VR hold a complex eigenvector, then IFAILR(i) and
-* IFAILR(i+1) are set to the same value.
-* If SIDE = 'L', IFAILR is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, i is the number of eigenvectors which
-* failed to converge; see IFAILL and IFAILR for further
-* details.
-*
-
-* Further Details
-* ===============
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x|+|y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dhseqr"></A>
- <H2>dhseqr</H2>
-
- <PRE>
-USAGE:
- wr, wi, work, info, h, z = NumRu::Lapack.dhseqr( job, compz, ilo, ihi, h, z, ldz, lwork)
- or
- NumRu::Lapack.dhseqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DHSEQR computes the eigenvalues of a Hessenberg matrix H
-* and, optionally, the matrices T and Z from the Schur decomposition
-* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
-* Schur form), and Z is the orthogonal matrix of Schur vectors.
-*
-* Optionally Z may be postmultiplied into an input orthogonal
-* matrix Q so that this routine can give the Schur factorization
-* of a matrix A which has been reduced to the Hessenberg form H
-* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': compute eigenvalues only;
-* = 'S': compute eigenvalues and the Schur form T.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': no Schur vectors are computed;
-* = 'I': Z is initialized to the unit matrix and the matrix Z
-* of Schur vectors of H is returned;
-* = 'V': Z must contain an orthogonal matrix Q on entry, and
-* the product Q*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrix H. N .GE. 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that H is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to DGEBAL, and then passed to DGEHRD
-* when the matrix output by DGEBAL is reduced to Hessenberg
-* form. Otherwise ILO and IHI should be set to 1 and N
-* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
-* If N = 0, then ILO = 1 and IHI = 0.
-*
-* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
-* On entry, the upper Hessenberg matrix H.
-* On exit, if INFO = 0 and JOB = 'S', then H contains the
-* upper quasi-triangular matrix T from the Schur decomposition
-* (the Schur form); 2-by-2 diagonal blocks (corresponding to
-* complex conjugate pairs of eigenvalues) are returned in
-* standard form, with H(i,i) = H(i+1,i+1) and
-* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
-* contents of H are unspecified on exit. (The output value of
-* H when INFO.GT.0 is given under the description of INFO
-* below.)
-*
-* Unlike earlier versions of DHSEQR, this subroutine may
-* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
-* or j = IHI+1, IHI+2, ... N.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH .GE. max(1,N).
-*
-* WR (output) DOUBLE PRECISION array, dimension (N)
-* WI (output) DOUBLE PRECISION array, dimension (N)
-* The real and imaginary parts, respectively, of the computed
-* eigenvalues. If two eigenvalues are computed as a complex
-* conjugate pair, they are stored in consecutive elements of
-* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
-* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
-* the same order as on the diagonal of the Schur form returned
-* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
-* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
-* WI(i+1) = -WI(i).
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
-* If COMPZ = 'N', Z is not referenced.
-* If COMPZ = 'I', on entry Z need not be set and on exit,
-* if INFO = 0, Z contains the orthogonal matrix Z of the Schur
-* vectors of H. If COMPZ = 'V', on entry Z must contain an
-* N-by-N matrix Q, which is assumed to be equal to the unit
-* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
-* if INFO = 0, Z contains Q*Z.
-* Normally Q is the orthogonal matrix generated by DORGHR
-* after the call to DGEHRD which formed the Hessenberg matrix
-* H. (The output value of Z when INFO.GT.0 is given under
-* the description of INFO below.)
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. if COMPZ = 'I' or
-* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns an estimate of
-* the optimal value for LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK .GE. max(1,N)
-* is sufficient and delivers very good and sometimes
-* optimal performance. However, LWORK as large as 11*N
-* may be required for optimal performance. A workspace
-* query is recommended to determine the optimal workspace
-* size.
-*
-* If LWORK = -1, then DHSEQR does a workspace query.
-* In this case, DHSEQR checks the input parameters and
-* estimates the optimal workspace size for the given
-* values of N, ILO and IHI. The estimate is returned
-* in WORK(1). No error message related to LWORK is
-* issued by XERBLA. Neither H nor Z are accessed.
-*
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* .LT. 0: if INFO = -i, the i-th argument had an illegal
-* value
-* .GT. 0: if INFO = i, DHSEQR failed to compute all of
-* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
-* and WI contain those eigenvalues which have been
-* successfully computed. (Failures are rare.)
-*
-* If INFO .GT. 0 and JOB = 'E', then on exit, the
-* remaining unconverged eigenvalues are the eigen-
-* values of the upper Hessenberg matrix rows and
-* columns ILO through INFO of the final, output
-* value of H.
-*
-* If INFO .GT. 0 and JOB = 'S', then on exit
-*
-* (*) (initial value of H)*U = U*(final value of H)
-*
-* where U is an orthogonal matrix. The final
-* value of H is upper Hessenberg and quasi-triangular
-* in rows and columns INFO+1 through IHI.
-*
-* If INFO .GT. 0 and COMPZ = 'V', then on exit
-*
-* (final value of Z) = (initial value of Z)*U
-*
-* where U is the orthogonal matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'I', then on exit
-* (final value of Z) = U
-* where U is the orthogonal matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'N', then Z is not
-* accessed.
-*
-
-* ================================================================
-* Default values supplied by
-* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
-* It is suggested that these defaults be adjusted in order
-* to attain best performance in each particular
-* computational environment.
-*
-* ISPEC=12: The DLAHQR vs DLAQR0 crossover point.
-* Default: 75. (Must be at least 11.)
-*
-* ISPEC=13: Recommended deflation window size.
-* This depends on ILO, IHI and NS. NS is the
-* number of simultaneous shifts returned
-* by ILAENV(ISPEC=15). (See ISPEC=15 below.)
-* The default for (IHI-ILO+1).LE.500 is NS.
-* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
-*
-* ISPEC=14: Nibble crossover point. (See IPARMQ for
-* details.) Default: 14% of deflation window
-* size.
-*
-* ISPEC=15: Number of simultaneous shifts in a multishift
-* QR iteration.
-*
-* If IHI-ILO+1 is ...
-*
-* greater than ...but less ... the
-* or equal to ... than default is
-*
-* 1 30 NS = 2(+)
-* 30 60 NS = 4(+)
-* 60 150 NS = 10(+)
-* 150 590 NS = **
-* 590 3000 NS = 64
-* 3000 6000 NS = 128
-* 6000 infinity NS = 256
-*
-* (+) By default some or all matrices of this order
-* are passed to the implicit double shift routine
-* DLAHQR and this parameter is ignored. See
-* ISPEC=12 above and comments in IPARMQ for
-* details.
-*
-* (**) The asterisks (**) indicate an ad-hoc
-* function of N increasing from 10 to 64.
-*
-* ISPEC=16: Select structured matrix multiply.
-* If the number of simultaneous shifts (specified
-* by ISPEC=15) is less than 14, then the default
-* for ISPEC=16 is 0. Otherwise the default for
-* ISPEC=16 is 2.
-*
-* ================================================================
-* Based on contributions by
-* Karen Braman and Ralph Byers, Department of Mathematics,
-* University of Kansas, USA
-*
-* ================================================================
-* References:
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
-* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
-* 929--947, 2002.
-*
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
-* of Matrix Analysis, volume 23, pages 948--973, 2002.
-*
-* ================================================================
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dop.html b/doc/dop.html
deleted file mode 100644
index a0a69bf..0000000
--- a/doc/dop.html
+++ /dev/null
@@ -1,171 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for (real) orthogonal, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for (real) orthogonal, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#dopgtr">dopgtr</A> : </LI>
- <LI><A HREF="#dopmtr">dopmtr</A> : </LI>
- </UL>
-
- <A NAME="dopgtr"></A>
- <H2>dopgtr</H2>
-
- <PRE>
-USAGE:
- q, info = NumRu::Lapack.dopgtr( uplo, ap, tau)
- or
- NumRu::Lapack.dopgtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DOPGTR generates a real orthogonal matrix Q which is defined as the
-* product of n-1 elementary reflectors H(i) of order n, as returned by
-* DSPTRD using packed storage:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to DSPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to DSPTRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The vectors which define the elementary reflectors, as
-* returned by DSPTRD.
-*
-* TAU (input) DOUBLE PRECISION array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DSPTRD.
-*
-* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
-* The N-by-N orthogonal matrix Q.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N-1)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dopmtr"></A>
- <H2>dopmtr</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, c)
- or
- NumRu::Lapack.dopmtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DOPMTR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by DSPTRD using packed
-* storage:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to DSPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to DSPTRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension
-* (M*(M+1)/2) if SIDE = 'L'
-* (N*(N+1)/2) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by DSPTRD. AP is modified by the routine but
-* restored on exit.
-*
-* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'
-* or (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DSPTRD.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension
-* (N) if SIDE = 'L'
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dor.html b/doc/dor.html
deleted file mode 100644
index 9cfa9ee..0000000
--- a/doc/dor.html
+++ /dev/null
@@ -1,2617 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for (real) orthogonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for (real) orthogonal matrix</H1>
- <UL>
- <LI><A HREF="#dorbdb">dorbdb</A> : </LI>
- <LI><A HREF="#dorcsd">dorcsd</A> : </LI>
- <LI><A HREF="#dorg2l">dorg2l</A> : </LI>
- <LI><A HREF="#dorg2r">dorg2r</A> : </LI>
- <LI><A HREF="#dorgbr">dorgbr</A> : </LI>
- <LI><A HREF="#dorghr">dorghr</A> : </LI>
- <LI><A HREF="#dorgl2">dorgl2</A> : </LI>
- <LI><A HREF="#dorglq">dorglq</A> : </LI>
- <LI><A HREF="#dorgql">dorgql</A> : </LI>
- <LI><A HREF="#dorgqr">dorgqr</A> : </LI>
- <LI><A HREF="#dorgr2">dorgr2</A> : </LI>
- <LI><A HREF="#dorgrq">dorgrq</A> : </LI>
- <LI><A HREF="#dorgtr">dorgtr</A> : </LI>
- <LI><A HREF="#dorm2l">dorm2l</A> : </LI>
- <LI><A HREF="#dorm2r">dorm2r</A> : </LI>
- <LI><A HREF="#dormbr">dormbr</A> : </LI>
- <LI><A HREF="#dormhr">dormhr</A> : </LI>
- <LI><A HREF="#dorml2">dorml2</A> : </LI>
- <LI><A HREF="#dormlq">dormlq</A> : </LI>
- <LI><A HREF="#dormql">dormql</A> : </LI>
- <LI><A HREF="#dormqr">dormqr</A> : </LI>
- <LI><A HREF="#dormr2">dormr2</A> : </LI>
- <LI><A HREF="#dormr3">dormr3</A> : </LI>
- <LI><A HREF="#dormrq">dormrq</A> : </LI>
- <LI><A HREF="#dormrz">dormrz</A> : </LI>
- <LI><A HREF="#dormtr">dormtr</A> : </LI>
- </UL>
-
- <A NAME="dorbdb"></A>
- <H2>dorbdb</H2>
-
- <PRE>
-USAGE:
- theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.dorbdb( trans, signs, m, x11, x12, x21, x22, lwork)
- or
- NumRu::Lapack.dorbdb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORBDB simultaneously bidiagonalizes the blocks of an M-by-M
-* partitioned orthogonal matrix X:
-*
-* [ B11 | B12 0 0 ]
-* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T
-* X = [-----------] = [---------] [----------------] [---------] .
-* [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]
-* [ 0 | 0 0 I ]
-*
-* X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is
-* not the case, then X must be transposed and/or permuted. This can be
-* done in constant time using the TRANS and SIGNS options. See DORCSD
-* for details.)
-*
-* The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-
-* (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are
-* represented implicitly by Householder vectors.
-*
-* B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented
-* implicitly by angles THETA, PHI.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <=
-* MIN(P,M-P,M-Q).
-*
-* X11 (input/output) DOUBLE PRECISION array, dimension (LDX11,Q)
-* On entry, the top-left block of the orthogonal matrix to be
-* reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X11) specify reflectors for P1,
-* the rows of triu(X11,1) specify reflectors for Q1;
-* else TRANS = 'T', and
-* the rows of triu(X11) specify reflectors for P1,
-* the columns of tril(X11,-1) specify reflectors for Q1.
-*
-* LDX11 (input) INTEGER
-* The leading dimension of X11. If TRANS = 'N', then LDX11 >=
-* P; else LDX11 >= Q.
-*
-* X12 (input/output) DOUBLE PRECISION array, dimension (LDX12,M-Q)
-* On entry, the top-right block of the orthogonal matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X12) specify the first P reflectors for
-* Q2;
-* else TRANS = 'T', and
-* the columns of tril(X12) specify the first P reflectors
-* for Q2.
-*
-* LDX12 (input) INTEGER
-* The leading dimension of X12. If TRANS = 'N', then LDX12 >=
-* P; else LDX11 >= M-Q.
-*
-* X21 (input/output) DOUBLE PRECISION array, dimension (LDX21,Q)
-* On entry, the bottom-left block of the orthogonal matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X21) specify reflectors for P2;
-* else TRANS = 'T', and
-* the rows of triu(X21) specify reflectors for P2.
-*
-* LDX21 (input) INTEGER
-* The leading dimension of X21. If TRANS = 'N', then LDX21 >=
-* M-P; else LDX21 >= Q.
-*
-* X22 (input/output) DOUBLE PRECISION array, dimension (LDX22,M-Q)
-* On entry, the bottom-right block of the orthogonal matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last
-* M-P-Q reflectors for Q2,
-* else TRANS = 'T', and
-* the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last
-* M-P-Q reflectors for P2.
-*
-* LDX22 (input) INTEGER
-* The leading dimension of X22. If TRANS = 'N', then LDX22 >=
-* M-P; else LDX22 >= M-Q.
-*
-* THETA (output) DOUBLE PRECISION array, dimension (Q)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* PHI (output) DOUBLE PRECISION array, dimension (Q-1)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* TAUP1 (output) DOUBLE PRECISION array, dimension (P)
-* The scalar factors of the elementary reflectors that define
-* P1.
-*
-* TAUP2 (output) DOUBLE PRECISION array, dimension (M-P)
-* The scalar factors of the elementary reflectors that define
-* P2.
-*
-* TAUQ1 (output) DOUBLE PRECISION array, dimension (Q)
-* The scalar factors of the elementary reflectors that define
-* Q1.
-*
-* TAUQ2 (output) DOUBLE PRECISION array, dimension (M-Q)
-* The scalar factors of the elementary reflectors that define
-* Q2.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= M-Q.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The bidiagonal blocks B11, B12, B21, and B22 are represented
-* implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,
-* PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are
-* lower bidiagonal. Every entry in each bidiagonal band is a product
-* of a sine or cosine of a THETA with a sine or cosine of a PHI. See
-* [1] or DORCSD for details.
-*
-* P1, P2, Q1, and Q2 are represented as products of elementary
-* reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2
-* using DORGQR and DORGLQ.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorcsd"></A>
- <H2>dorcsd</H2>
-
- <PRE>
-USAGE:
- theta, u1, u2, v1t, v2t, info = NumRu::Lapack.dorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, ldu1, ldu2, ldv1t, ldv2t, lwork)
- or
- NumRu::Lapack.dorcsd # print help
-
-
-FORTRAN MANUAL
- RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORCSD computes the CS decomposition of an M-by-M partitioned
-* orthogonal matrix X:
-*
-* [ I 0 0 | 0 0 0 ]
-* [ 0 C 0 | 0 -S 0 ]
-* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T
-* X = [-----------] = [---------] [---------------------] [---------] .
-* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]
-* [ 0 S 0 | 0 C 0 ]
-* [ 0 0 I | 0 0 0 ]
-*
-* X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,
-* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
-* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
-* which R = MIN(P,M-P,Q,M-Q).
-*
-
-* Arguments
-* =========
-*
-* JOBU1 (input) CHARACTER
-* = 'Y': U1 is computed;
-* otherwise: U1 is not computed.
-*
-* JOBU2 (input) CHARACTER
-* = 'Y': U2 is computed;
-* otherwise: U2 is not computed.
-*
-* JOBV1T (input) CHARACTER
-* = 'Y': V1T is computed;
-* otherwise: V1T is not computed.
-*
-* JOBV2T (input) CHARACTER
-* = 'Y': V2T is computed;
-* otherwise: V2T is not computed.
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <= M.
-*
-* X (input/workspace) DOUBLE PRECISION array, dimension (LDX,M)
-* On entry, the orthogonal matrix whose CSD is desired.
-*
-* LDX (input) INTEGER
-* The leading dimension of X. LDX >= MAX(1,M).
-*
-* THETA (output) DOUBLE PRECISION array, dimension (R), in which R =
-* MIN(P,M-P,Q,M-Q).
-* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
-* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
-*
-* U1 (output) DOUBLE PRECISION array, dimension (P)
-* If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
-*
-* LDU1 (input) INTEGER
-* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
-* MAX(1,P).
-*
-* U2 (output) DOUBLE PRECISION array, dimension (M-P)
-* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
-* matrix U2.
-*
-* LDU2 (input) INTEGER
-* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
-* MAX(1,M-P).
-*
-* V1T (output) DOUBLE PRECISION array, dimension (Q)
-* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
-* matrix V1**T.
-*
-* LDV1T (input) INTEGER
-* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
-* MAX(1,Q).
-*
-* V2T (output) DOUBLE PRECISION array, dimension (M-Q)
-* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal
-* matrix V2**T.
-*
-* LDV2T (input) INTEGER
-* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=
-* MAX(1,M-Q).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-* If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
-* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
-* define the matrix in intermediate bidiagonal-block form
-* remaining after nonconvergence. INFO specifies the number
-* of nonzero PHI's.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the work array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M-Q)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: DBBCSD did not converge. See the description of WORK
-* above for details.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorg2l"></A>
- <H2>dorg2l</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dorg2l( m, a, tau)
- or
- NumRu::Lapack.dorg2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORG2L generates an m by n real matrix Q with orthonormal columns,
-* which is defined as the last n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by DGEQLF in the last k columns of its array
-* argument A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQLF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorg2r"></A>
- <H2>dorg2r</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dorg2r( m, a, tau)
- or
- NumRu::Lapack.dorg2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORG2R generates an m by n real matrix Q with orthonormal columns,
-* which is defined as the first n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by DGEQRF in the first k columns of its array
-* argument A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQRF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorgbr"></A>
- <H2>dorgbr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dorgbr( vect, m, k, a, tau, lwork)
- or
- NumRu::Lapack.dorgbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGBR generates one of the real orthogonal matrices Q or P**T
-* determined by DGEBRD when reducing a real matrix A to bidiagonal
-* form: A = Q * B * P**T. Q and P**T are defined as products of
-* elementary reflectors H(i) or G(i) respectively.
-*
-* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
-* is of order M:
-* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n
-* columns of Q, where m >= n >= k;
-* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
-* M-by-M matrix.
-*
-* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
-* is of order N:
-* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
-* rows of P**T, where n >= m >= k;
-* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as
-* an N-by-N matrix.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether the matrix Q or the matrix P**T is
-* required, as defined in the transformation applied by DGEBRD:
-* = 'Q': generate Q;
-* = 'P': generate P**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q or P**T to be returned.
-* M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q or P**T to be returned.
-* N >= 0.
-* If VECT = 'Q', M >= N >= min(M,K);
-* if VECT = 'P', N >= M >= min(N,K).
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original M-by-K
-* matrix reduced by DGEBRD.
-* If VECT = 'P', the number of rows in the original K-by-N
-* matrix reduced by DGEBRD.
-* K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by DGEBRD.
-* On exit, the M-by-N matrix Q or P**T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension
-* (min(M,K)) if VECT = 'Q'
-* (min(N,K)) if VECT = 'P'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i), which determines Q or P**T, as
-* returned by DGEBRD in its array argument TAUQ or TAUP.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,min(M,N)).
-* For optimum performance LWORK >= min(M,N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorghr"></A>
- <H2>dorghr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dorghr( ilo, ihi, a, tau, lwork)
- or
- NumRu::Lapack.dorghr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGHR generates a real orthogonal matrix Q which is defined as the
-* product of IHI-ILO elementary reflectors of order N, as returned by
-* DGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of DGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by DGEHRD.
-* On exit, the N-by-N orthogonal matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEHRD.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= IHI-ILO.
-* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorgl2"></A>
- <H2>dorgl2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dorgl2( a, tau)
- or
- NumRu::Lapack.dorgl2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGL2 generates an m by n real matrix Q with orthonormal rows,
-* which is defined as the first m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by DGELQF in the first k rows of its array argument A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGELQF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorglq"></A>
- <H2>dorglq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dorglq( m, a, tau, lwork)
- or
- NumRu::Lapack.dorglq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGLQ generates an M-by-N real matrix Q with orthonormal rows,
-* which is defined as the first M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by DGELQF in the first k rows of its array argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGELQF.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorgql"></A>
- <H2>dorgql</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dorgql( m, a, tau, lwork)
- or
- NumRu::Lapack.dorgql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGQL generates an M-by-N real matrix Q with orthonormal columns,
-* which is defined as the last N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by DGEQLF in the last k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQLF.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorgqr"></A>
- <H2>dorgqr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dorgqr( m, a, tau, lwork)
- or
- NumRu::Lapack.dorgqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGQR generates an M-by-N real matrix Q with orthonormal columns,
-* which is defined as the first N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by DGEQRF in the first k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQRF.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorgr2"></A>
- <H2>dorgr2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dorgr2( a, tau)
- or
- NumRu::Lapack.dorgr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGR2 generates an m by n real matrix Q with orthonormal rows,
-* which is defined as the last m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by DGERQF in the last k rows of its array argument
-* A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGERQF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorgrq"></A>
- <H2>dorgrq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dorgrq( m, a, tau, lwork)
- or
- NumRu::Lapack.dorgrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGRQ generates an M-by-N real matrix Q with orthonormal rows,
-* which is defined as the last M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by DGERQF in the last k rows of its array argument
-* A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGERQF.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorgtr"></A>
- <H2>dorgtr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.dorgtr( uplo, a, tau, lwork)
- or
- NumRu::Lapack.dorgtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORGTR generates a real orthogonal matrix Q which is defined as the
-* product of n-1 elementary reflectors of order N, as returned by
-* DSYTRD:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from DSYTRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from DSYTRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by DSYTRD.
-* On exit, the N-by-N orthogonal matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DSYTRD.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N-1).
-* For optimum performance LWORK >= (N-1)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorm2l"></A>
- <H2>dorm2l</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.dorm2l( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.dorm2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORM2L overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQLF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorm2r"></A>
- <H2>dorm2r</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.dorm2r( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.dorm2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORM2R overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQRF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormbr"></A>
- <H2>dormbr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormbr( vect, side, trans, m, k, a, tau, c, lwork)
- or
- NumRu::Lapack.dormbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': P * C C * P
-* TRANS = 'T': P**T * C C * P**T
-*
-* Here Q and P**T are the orthogonal matrices determined by DGEBRD when
-* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
-* P**T are defined as products of elementary reflectors H(i) and G(i)
-* respectively.
-*
-* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
-* order of the orthogonal matrix Q or P**T that is applied.
-*
-* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
-* if nq >= k, Q = H(1) H(2) . . . H(k);
-* if nq < k, Q = H(1) H(2) . . . H(nq-1).
-*
-* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
-* if k < nq, P = G(1) G(2) . . . G(k);
-* if k >= nq, P = G(1) G(2) . . . G(nq-1).
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'Q': apply Q or Q**T;
-* = 'P': apply P or P**T.
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q, Q**T, P or P**T from the Left;
-* = 'R': apply Q, Q**T, P or P**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q or P;
-* = 'T': Transpose, apply Q**T or P**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original
-* matrix reduced by DGEBRD.
-* If VECT = 'P', the number of rows in the original
-* matrix reduced by DGEBRD.
-* K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,min(nq,K)) if VECT = 'Q'
-* (LDA,nq) if VECT = 'P'
-* The vectors which define the elementary reflectors H(i) and
-* G(i), whose products determine the matrices Q and P, as
-* returned by DGEBRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If VECT = 'Q', LDA >= max(1,nq);
-* if VECT = 'P', LDA >= max(1,min(nq,K)).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K))
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i) which determines Q or P, as returned
-* by DGEBRD in the array argument TAUQ or TAUP.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
-* or P*C or P**T*C or C*P or C*P**T.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
- CHARACTER TRANST
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DORMLQ, DORMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormhr"></A>
- <H2>dormhr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormhr( side, trans, ilo, ihi, a, tau, c, lwork)
- or
- NumRu::Lapack.dormhr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMHR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* IHI-ILO elementary reflectors, as returned by DGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of DGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
-* ILO = 1 and IHI = 0, if M = 0;
-* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
-* ILO = 1 and IHI = 0, if N = 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by DGEHRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) DOUBLE PRECISION array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEHRD.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DORMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dorml2"></A>
- <H2>dorml2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.dorml2( side, trans, a, tau, c)
- or
- NumRu::Lapack.dorml2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORML2 overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGELQF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormlq"></A>
- <H2>dormlq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormlq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.dormlq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMLQ overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGELQF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormql"></A>
- <H2>dormql</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormql( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.dormql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMQL overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQLF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormqr"></A>
- <H2>dormqr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormqr( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.dormqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMQR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGEQRF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormr2"></A>
- <H2>dormr2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.dormr2( side, trans, a, tau, c)
- or
- NumRu::Lapack.dormr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMR2 overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGERQF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormr3"></A>
- <H2>dormr3</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.dormr3( side, trans, l, a, tau, c)
- or
- NumRu::Lapack.dormr3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMR3 overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DTZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DTZRZF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, NOTRAN
- INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DLARZ, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormrq"></A>
- <H2>dormrq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormrq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.dormrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMRQ overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DGERQF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormrz"></A>
- <H2>dormrz</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormrz( side, trans, l, a, tau, c, lwork)
- or
- NumRu::Lapack.dormrz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMRZ overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* DTZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) DOUBLE PRECISION array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DTZRZF.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dormtr"></A>
- <H2>dormtr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.dormtr( side, uplo, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.dormtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DORMTR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by DSYTRD:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from DSYTRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from DSYTRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by DSYTRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) DOUBLE PRECISION array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by DSYTRD.
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, UPPER
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DORMQL, DORMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dpb.html b/doc/dpb.html
deleted file mode 100644
index 182ea74..0000000
--- a/doc/dpb.html
+++ /dev/null
@@ -1,1018 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for symmetric or Hermitian positive definite band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for symmetric or Hermitian positive definite band matrix</H1>
- <UL>
- <LI><A HREF="#dpbcon">dpbcon</A> : </LI>
- <LI><A HREF="#dpbequ">dpbequ</A> : </LI>
- <LI><A HREF="#dpbrfs">dpbrfs</A> : </LI>
- <LI><A HREF="#dpbstf">dpbstf</A> : </LI>
- <LI><A HREF="#dpbsv">dpbsv</A> : </LI>
- <LI><A HREF="#dpbsvx">dpbsvx</A> : </LI>
- <LI><A HREF="#dpbtf2">dpbtf2</A> : </LI>
- <LI><A HREF="#dpbtrf">dpbtrf</A> : </LI>
- <LI><A HREF="#dpbtrs">dpbtrs</A> : </LI>
- </UL>
-
- <A NAME="dpbcon"></A>
- <H2>dpbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dpbcon( uplo, kd, ab, anorm)
- or
- NumRu::Lapack.dpbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPBCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite band matrix using the
-* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm (or infinity-norm) of the symmetric band matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbequ"></A>
- <H2>dpbequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.dpbequ( uplo, kd, ab)
- or
- NumRu::Lapack.dpbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DPBEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite band matrix A and reduce its condition
-* number (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular of A is stored;
-* = 'L': Lower triangular of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The upper or lower triangle of the symmetric band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbrfs"></A>
- <H2>dpbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dpbrfs( uplo, kd, ab, afb, b, x)
- or
- NumRu::Lapack.dpbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite
-* and banded, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The upper or lower triangle of the symmetric band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T of the band matrix A as computed by
-* DPBTRF, in the same storage format as A (see AB).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DPBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbstf"></A>
- <H2>dpbstf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.dpbstf( uplo, kd, ab)
- or
- NumRu::Lapack.dpbstf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* DPBSTF computes a split Cholesky factorization of a real
-* symmetric positive definite band matrix A.
-*
-* This routine is designed to be used in conjunction with DSBGST.
-*
-* The factorization has the form A = S**T*S where S is a band matrix
-* of the same bandwidth as A and the following structure:
-*
-* S = ( U )
-* ( M L )
-*
-* where U is upper triangular of order m = (n+kd)/2, and L is lower
-* triangular of order n-m.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first kd+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the factor S from the split Cholesky
-* factorization A = S**T*S. See Further Details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the factorization could not be completed,
-* because the updated element a(i,i) was negative; the
-* matrix A is not positive definite.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 7, KD = 2:
-*
-* S = ( s11 s12 s13 )
-* ( s22 s23 s24 )
-* ( s33 s34 )
-* ( s44 )
-* ( s53 s54 s55 )
-* ( s64 s65 s66 )
-* ( s75 s76 s77 )
-*
-* If UPLO = 'U', the array AB holds:
-*
-* on entry: on exit:
-*
-* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75
-* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-*
-* If UPLO = 'L', the array AB holds:
-*
-* on entry: on exit:
-*
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *
-* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbsv"></A>
- <H2>dpbsv</H2>
-
- <PRE>
-USAGE:
- info, ab, b = NumRu::Lapack.dpbsv( uplo, kd, ab, b)
- or
- NumRu::Lapack.dpbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPBSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix, with the same number of superdiagonals or
-* subdiagonals as A. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**T*U or A = L*L**T of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DPBTRF, DPBTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbsvx"></A>
- <H2>dpbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.dpbsvx( fact, uplo, kd, ab, afb, equed, s, b)
- or
- NumRu::Lapack.dpbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
-* compute the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AB and AFB will not
-* be modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right-hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array, except
-* if FACT = 'F' and EQUED = 'Y', then A must contain the
-* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
-* is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the band matrix
-* A, in the same storage format as A (see AB). If EQUED = 'Y',
-* then AFB is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13
-* a22 a23 a24
-* a33 a34 a35
-* a44 a45 a46
-* a55 a56
-* (aij=conjg(aji)) a66
-*
-* Band storage of the upper triangle of A:
-*
-* * * a13 a24 a35 a46
-* * a12 a23 a34 a45 a56
-* a11 a22 a33 a44 a55 a66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* a11 a22 a33 a44 a55 a66
-* a21 a32 a43 a54 a65 *
-* a31 a42 a53 a64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbtf2"></A>
- <H2>dpbtf2</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.dpbtf2( uplo, kd, ab)
- or
- NumRu::Lapack.dpbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* DPBTF2 computes the Cholesky factorization of a real symmetric
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix, U' is the transpose of U, and
-* L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of super-diagonals of the matrix A if UPLO = 'U',
-* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U'*U or A = L*L' of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbtrf"></A>
- <H2>dpbtrf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.dpbtrf( uplo, kd, ab)
- or
- NumRu::Lapack.dpbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* DPBTRF computes the Cholesky factorization of a real symmetric
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**T*U or A = L*L**T of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* Contributed by
-* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpbtrs"></A>
- <H2>dpbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dpbtrs( uplo, kd, ab, b)
- or
- NumRu::Lapack.dpbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPBTRS solves a system of linear equations A*X = B with a symmetric
-* positive definite band matrix A using the Cholesky factorization
-* A = U**T*U or A = L*L**T computed by DPBTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DTBSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dpo.html b/doc/dpo.html
deleted file mode 100644
index ecd3c5f..0000000
--- a/doc/dpo.html
+++ /dev/null
@@ -1,1552 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for symmetric or Hermitian positive definite matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for symmetric or Hermitian positive definite matrix</H1>
- <UL>
- <LI><A HREF="#dpocon">dpocon</A> : </LI>
- <LI><A HREF="#dpoequ">dpoequ</A> : </LI>
- <LI><A HREF="#dpoequb">dpoequb</A> : </LI>
- <LI><A HREF="#dporfs">dporfs</A> : </LI>
- <LI><A HREF="#dporfsx">dporfsx</A> : </LI>
- <LI><A HREF="#dposv">dposv</A> : </LI>
- <LI><A HREF="#dposvx">dposvx</A> : </LI>
- <LI><A HREF="#dposvxx">dposvxx</A> : </LI>
- <LI><A HREF="#dpotf2">dpotf2</A> : </LI>
- <LI><A HREF="#dpotrf">dpotrf</A> : </LI>
- <LI><A HREF="#dpotri">dpotri</A> : </LI>
- <LI><A HREF="#dpotrs">dpotrs</A> : </LI>
- </UL>
-
- <A NAME="dpocon"></A>
- <H2>dpocon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dpocon( uplo, a, anorm)
- or
- NumRu::Lapack.dpocon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPOCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite matrix using the
-* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by DPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm (or infinity-norm) of the symmetric matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpoequ"></A>
- <H2>dpoequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.dpoequ( a)
- or
- NumRu::Lapack.dpoequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DPOEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The N-by-N symmetric positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpoequb"></A>
- <H2>dpoequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.dpoequb( a)
- or
- NumRu::Lapack.dpoequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DPOEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The N-by-N symmetric positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dporfs"></A>
- <H2>dporfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dporfs( uplo, a, af, b, x)
- or
- NumRu::Lapack.dporfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPORFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite,
-* and provides error bounds and backward error estimates for the
-* solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by DPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DPOTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dporfsx"></A>
- <H2>dporfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dporfsx( uplo, equed, a, af, s, b, x, params)
- or
- NumRu::Lapack.dporfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPORFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive
-* definite, and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by DPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dposv"></A>
- <H2>dposv</H2>
-
- <PRE>
-USAGE:
- info, a, b = NumRu::Lapack.dposv( uplo, a, b)
- or
- NumRu::Lapack.dposv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPOSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DPOTRF, DPOTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dposvx"></A>
- <H2>dposvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.dposvx( fact, uplo, a, af, equed, s, b)
- or
- NumRu::Lapack.dposvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
-* compute the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. A and AF will not
-* be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A, except if FACT = 'F' and
-* EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored form
-* of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dposvxx"></A>
- <H2>dposvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.dposvxx( fact, uplo, a, af, equed, s, b, params)
- or
- NumRu::Lapack.dposvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T
-* to compute the solution to a double precision system of linear equations
-* A * X = B, where A is an N-by-N symmetric positive definite matrix
-* and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. DPOSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* DPOSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* DPOSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what DPOSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A (see argument RCOND). If the reciprocal of the condition number
-* is less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A and AF are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =
-* 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper
-* triangular part of A contains the upper triangular part of the
-* matrix A, and the strictly lower triangular part of A is not
-* referenced. If UPLO = 'L', the leading N-by-N lower triangular
-* part of A contains the lower triangular part of the matrix A, and
-* the strictly upper triangular part of A is not referenced. A is
-* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =
-* 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored
-* form of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpotf2"></A>
- <H2>dpotf2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dpotf2( uplo, a)
- or
- NumRu::Lapack.dpotf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* DPOTF2 computes the Cholesky factorization of a real symmetric
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L'.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpotrf"></A>
- <H2>dpotrf</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dpotrf( uplo, a)
- or
- NumRu::Lapack.dpotrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* DPOTRF computes the Cholesky factorization of a real symmetric
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the block version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpotri"></A>
- <H2>dpotri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dpotri( uplo, a)
- or
- NumRu::Lapack.dpotri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* DPOTRI computes the inverse of a real symmetric positive definite
-* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
-* computed by DPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, as computed by
-* DPOTRF.
-* On exit, the upper or lower triangle of the (symmetric)
-* inverse of A, overwriting the input factor U or L.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DLAUUM, DTRTRI, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpotrs"></A>
- <H2>dpotrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dpotrs( uplo, a, b)
- or
- NumRu::Lapack.dpotrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPOTRS solves a system of linear equations A*X = B with a symmetric
-* positive definite matrix A using the Cholesky factorization
-* A = U**T*U or A = L*L**T computed by DPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by DPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dpp.html b/doc/dpp.html
deleted file mode 100644
index 86e9024..0000000
--- a/doc/dpp.html
+++ /dev/null
@@ -1,793 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for symmetric or Hermitian positive definite, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for symmetric or Hermitian positive definite, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#dppcon">dppcon</A> : </LI>
- <LI><A HREF="#dppequ">dppequ</A> : </LI>
- <LI><A HREF="#dpprfs">dpprfs</A> : </LI>
- <LI><A HREF="#dppsv">dppsv</A> : </LI>
- <LI><A HREF="#dppsvx">dppsvx</A> : </LI>
- <LI><A HREF="#dpptrf">dpptrf</A> : </LI>
- <LI><A HREF="#dpptri">dpptri</A> : </LI>
- <LI><A HREF="#dpptrs">dpptrs</A> : </LI>
- </UL>
-
- <A NAME="dppcon"></A>
- <H2>dppcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dppcon( uplo, ap, anorm)
- or
- NumRu::Lapack.dppcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite packed matrix using
-* the Cholesky factorization A = U**T*U or A = L*L**T computed by
-* DPPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm (or infinity-norm) of the symmetric matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dppequ"></A>
- <H2>dppequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.dppequ( uplo, ap)
- or
- NumRu::Lapack.dppequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* DPPEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A in packed storage and reduce
-* its condition number (with respect to the two-norm). S contains the
-* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
-* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
-* This choice of S puts the condition number of B within a factor N of
-* the smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpprfs"></A>
- <H2>dpprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dpprfs( uplo, ap, afp, b, x)
- or
- NumRu::Lapack.dpprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,
-* packed columnwise in a linear array in the same format as A
-* (see AP).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DPPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dppsv"></A>
- <H2>dppsv</H2>
-
- <PRE>
-USAGE:
- info, ap, b = NumRu::Lapack.dppsv( uplo, n, ap, b)
- or
- NumRu::Lapack.dppsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPPSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DPPTRF, DPPTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dppsvx"></A>
- <H2>dppsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.dppsvx( fact, uplo, ap, afp, equed, s, b)
- or
- NumRu::Lapack.dppsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
-* compute the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFP contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AP and AFP will not
-* be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array, except if FACT = 'F'
-* and EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). The j-th column of A is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* AFP (input or output) DOUBLE PRECISION array, dimension
-* (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L', in the same storage
-* format as A. If EQUED .ne. 'N', then AFP is the factored
-* form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L' of the original matrix A.
-*
-* If FACT = 'E', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L' of the equilibrated
-* matrix A (see the description of AP for the form of the
-* equilibrated matrix).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpptrf"></A>
- <H2>dpptrf</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.dpptrf( uplo, n, ap)
- or
- NumRu::Lapack.dpptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPTRF( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* DPPTRF computes the Cholesky factorization of a real symmetric
-* positive definite matrix A stored in packed format.
-*
-* The factorization has the form
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**T*U or A = L*L**T, in the same
-* storage format as A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ======= =======
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpptri"></A>
- <H2>dpptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.dpptri( uplo, n, ap)
- or
- NumRu::Lapack.dpptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPTRI( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* DPPTRI computes the inverse of a real symmetric positive definite
-* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
-* computed by DPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor is stored in AP;
-* = 'L': Lower triangular factor is stored in AP.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, packed columnwise as
-* a linear array. The j-th column of U or L is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* On exit, the upper or lower triangle of the (symmetric)
-* inverse of A, overwriting the input factor U or L.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpptrs"></A>
- <H2>dpptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dpptrs( uplo, n, ap, b)
- or
- NumRu::Lapack.dpptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPPTRS solves a system of linear equations A*X = B with a symmetric
-* positive definite matrix A in packed storage using the Cholesky
-* factorization A = U**T*U or A = L*L**T computed by DPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DTPSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dpt.html b/doc/dpt.html
deleted file mode 100644
index a5bc965..0000000
--- a/doc/dpt.html
+++ /dev/null
@@ -1,698 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for symmetric or Hermitian positive definite tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for symmetric or Hermitian positive definite tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#dptcon">dptcon</A> : </LI>
- <LI><A HREF="#dpteqr">dpteqr</A> : </LI>
- <LI><A HREF="#dptrfs">dptrfs</A> : </LI>
- <LI><A HREF="#dptsv">dptsv</A> : </LI>
- <LI><A HREF="#dptsvx">dptsvx</A> : </LI>
- <LI><A HREF="#dpttrf">dpttrf</A> : </LI>
- <LI><A HREF="#dpttrs">dpttrs</A> : </LI>
- <LI><A HREF="#dptts2">dptts2</A> : </LI>
- </UL>
-
- <A NAME="dptcon"></A>
- <H2>dptcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dptcon( d, e, anorm)
- or
- NumRu::Lapack.dptcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DPTCON computes the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite tridiagonal matrix
-* using the factorization A = L*D*L**T or A = U**T*D*U computed by
-* DPTTRF.
-*
-* Norm(inv(A)) is computed by a direct method, and the reciprocal of
-* the condition number is computed as
-* RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization of A, as computed by DPTTRF.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) off-diagonal elements of the unit bidiagonal factor
-* U or L from the factorization of A, as computed by DPTTRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
-* 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The method used is described in Nicholas J. Higham, "Efficient
-* Algorithms for Computing the Condition Number of a Tridiagonal
-* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpteqr"></A>
- <H2>dpteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.dpteqr( compz, d, e, z)
- or
- NumRu::Lapack.dpteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric positive definite tridiagonal matrix by first factoring the
-* matrix using DPTTRF, and then calling DBDSQR to compute the singular
-* values of the bidiagonal factor.
-*
-* This routine computes the eigenvalues of the positive definite
-* tridiagonal matrix to high relative accuracy. This means that if the
-* eigenvalues range over many orders of magnitude in size, then the
-* small eigenvalues and corresponding eigenvectors will be computed
-* more accurately than, for example, with the standard QR method.
-*
-* The eigenvectors of a full or band symmetric positive definite matrix
-* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
-* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
-* form, however, may preclude the possibility of obtaining high
-* relative accuracy in the small eigenvalues of the original matrix, if
-* these eigenvalues range over many orders of magnitude.)
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvectors of original symmetric
-* matrix also. Array Z contains the orthogonal
-* matrix used to reduce the original matrix to
-* tridiagonal form.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal
-* matrix.
-* On normal exit, D contains the eigenvalues, in descending
-* order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix used in the
-* reduction to tridiagonal form.
-* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
-* original symmetric matrix;
-* if COMPZ = 'I', the orthonormal eigenvectors of the
-* tridiagonal matrix.
-* If INFO > 0 on exit, Z contains the eigenvectors associated
-* with only the stored eigenvalues.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* COMPZ = 'V' or 'I', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is:
-* <= N the Cholesky factorization of the matrix could
-* not be performed because the i-th principal minor
-* was not positive definite.
-* > N the SVD algorithm failed to converge;
-* if INFO = N+i, i off-diagonal elements of the
-* bidiagonal factor did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dptrfs"></A>
- <H2>dptrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dptrfs( d, e, df, ef, b, x)
- or
- NumRu::Lapack.dptrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DPTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite
-* and tridiagonal, and provides error bounds and backward error
-* estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix A.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix A.
-*
-* DF (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization computed by DPTTRF.
-*
-* EF (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of the unit bidiagonal factor
-* L from the factorization computed by DPTTRF.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DPTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dptsv"></A>
- <H2>dptsv</H2>
-
- <PRE>
-USAGE:
- info, d, e, b = NumRu::Lapack.dptsv( d, e, b)
- or
- NumRu::Lapack.dptsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPTSV computes the solution to a real system of linear equations
-* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
-* matrix, and X and B are N-by-NRHS matrices.
-*
-* A is factored as A = L*D*L**T, and the factored form of A is then
-* used to solve the system of equations.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the factorization A = L*D*L**T.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L**T factorization of
-* A. (E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U**T*D*U factorization of A.)
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the solution has not been
-* computed. The factorization has not been completed
-* unless i = N.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL DPTTRF, DPTTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dptsvx"></A>
- <H2>dptsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.dptsvx( fact, d, e, df, ef, b)
- or
- NumRu::Lapack.dptsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DPTSVX uses the factorization A = L*D*L**T to compute the solution
-* to a real system of linear equations A*X = B, where A is an N-by-N
-* symmetric positive definite tridiagonal matrix and X and B are
-* N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
-* is a unit lower bidiagonal matrix and D is diagonal. The
-* factorization can also be regarded as having the form
-* A = U**T*D*U.
-*
-* 2. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, DF and EF contain the factored form of A.
-* D, E, DF, and EF will not be modified.
-* = 'N': The matrix A will be copied to DF and EF and
-* factored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix A.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix A.
-*
-* DF (input or output) DOUBLE PRECISION array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**T factorization of A.
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**T factorization of A.
-*
-* EF (input or output) DOUBLE PRECISION array, dimension (N-1)
-* If FACT = 'F', then EF is an input argument and on entry
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**T factorization of A.
-* If FACT = 'N', then EF is an output argument and on exit
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**T factorization of A.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal condition number of the matrix A. If RCOND
-* is less than the machine precision (in particular, if
-* RCOND = 0), the matrix is singular to working precision.
-* This condition is indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in any
-* element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpttrf"></A>
- <H2>dpttrf</H2>
-
- <PRE>
-USAGE:
- info, d, e = NumRu::Lapack.dpttrf( d, e)
- or
- NumRu::Lapack.dpttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTTRF( N, D, E, INFO )
-
-* Purpose
-* =======
-*
-* DPTTRF computes the L*D*L' factorization of a real symmetric
-* positive definite tridiagonal matrix A. The factorization may also
-* be regarded as having the form A = U'*D*U.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the L*D*L' factorization of A.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L' factorization of A.
-* E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U'*D*U factorization of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite; if k < N, the factorization could not
-* be completed, while if k = N, the factorization was
-* completed, but D(N) <= 0.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dpttrs"></A>
- <H2>dpttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dpttrs( d, e, b)
- or
- NumRu::Lapack.dpttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DPTTRS solves a tridiagonal system of the form
-* A * X = B
-* using the L*D*L' factorization of A computed by DPTTRF. D is a
-* diagonal matrix specified in the vector D, L is a unit bidiagonal
-* matrix whose subdiagonal is specified in the vector E, and X and B
-* are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* L*D*L' factorization of A.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of the unit bidiagonal factor
-* L from the L*D*L' factorization of A. E can also be regarded
-* as the superdiagonal of the unit bidiagonal factor U from the
-* factorization A = U'*D*U.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DPTTS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dptts2"></A>
- <H2>dptts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.dptts2( d, e, b)
- or
- NumRu::Lapack.dptts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )
-
-* Purpose
-* =======
-*
-* DPTTS2 solves a tridiagonal system of the form
-* A * X = B
-* using the L*D*L' factorization of A computed by DPTTRF. D is a
-* diagonal matrix specified in the vector D, L is a unit bidiagonal
-* matrix whose subdiagonal is specified in the vector E, and X and B
-* are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* L*D*L' factorization of A.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of the unit bidiagonal factor
-* L from the L*D*L' factorization of A. E can also be regarded
-* as the superdiagonal of the unit bidiagonal factor U from the
-* factorization A = U'*D*U.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, J
-* ..
-* .. External Subroutines ..
- EXTERNAL DSCAL
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ds.html b/doc/ds.html
deleted file mode 100644
index d7c7b7d..0000000
--- a/doc/ds.html
+++ /dev/null
@@ -1,15 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>Data type in double but solving problem using single precision routines</TITLE>
- </HEAD>
- <BODY>
- <H1>Data type in double but solving problem using single precision routines</H1>
- <UL>
- <LI><A HREF="dsge.html">GE: general (i.e., unsymmetric, in some cases rectangular)</A></LI>
- <LI><A HREF="dspo.html">PO: symmetric or Hermitian positive definite</A></LI>
- <LI><A HREF="dspt.html">PT: symmetric or Hermitian positive definite tridiagonal</A></LI>
- </UL>
- <HR />
- <A HREF="index.html">back to data types</A>
- </BODY>
-</HTML>
diff --git a/doc/dsb.html b/doc/dsb.html
deleted file mode 100644
index d60a51b..0000000
--- a/doc/dsb.html
+++ /dev/null
@@ -1,1018 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for (real) symmetric band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for (real) symmetric band matrix</H1>
- <UL>
- <LI><A HREF="#dsbev">dsbev</A> : </LI>
- <LI><A HREF="#dsbevd">dsbevd</A> : </LI>
- <LI><A HREF="#dsbevx">dsbevx</A> : </LI>
- <LI><A HREF="#dsbgst">dsbgst</A> : </LI>
- <LI><A HREF="#dsbgv">dsbgv</A> : </LI>
- <LI><A HREF="#dsbgvd">dsbgvd</A> : </LI>
- <LI><A HREF="#dsbgvx">dsbgvx</A> : </LI>
- <LI><A HREF="#dsbtrd">dsbtrd</A> : </LI>
- </UL>
-
- <A NAME="dsbev"></A>
- <H2>dsbev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab = NumRu::Lapack.dsbev( jobz, uplo, kd, ab)
- or
- NumRu::Lapack.dsbev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSBEV computes all the eigenvalues and, optionally, eigenvectors of
-* a real symmetric band matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsbevd"></A>
- <H2>dsbevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ab = NumRu::Lapack.dsbevd( jobz, uplo, kd, ab, lwork, liwork)
- or
- NumRu::Lapack.dsbevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of
-* a real symmetric band matrix A. If eigenvectors are desired, it uses
-* a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* IF N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.
-* If JOBZ = 'V' and N > 2, LWORK must be at least
-* ( 1 + 5*N + 2*N**2 ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array LIWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsbevx"></A>
- <H2>dsbevx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, ifail, info, ab = NumRu::Lapack.dsbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.dsbevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSBEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric band matrix A. Eigenvalues and eigenvectors can
-* be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)
-* If JOBZ = 'V', the N-by-N orthogonal matrix used in the
-* reduction to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'V', then
-* LDQ >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AB to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsbgst"></A>
- <H2>dsbgst</H2>
-
- <PRE>
-USAGE:
- x, info, ab = NumRu::Lapack.dsbgst( vect, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.dsbgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSBGST reduces a real symmetric-definite banded generalized
-* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
-* such that C has the same bandwidth as A.
-*
-* B must have been previously factorized as S**T*S by DPBSTF, using a
-* split Cholesky factorization. A is overwritten by C = X**T*A*X, where
-* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
-* bandwidth of A.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form the transformation matrix X;
-* = 'V': form X.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the transformed matrix X**T*A*X, stored in the same
-* format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input) DOUBLE PRECISION array, dimension (LDBB,N)
-* The banded factor S from the split Cholesky factorization of
-* B, as returned by DPBSTF, stored in the first KB+1 rows of
-* the array.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,N)
-* If VECT = 'V', the n-by-n matrix X.
-* If VECT = 'N', the array X is not referenced.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X.
-* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsbgv"></A>
- <H2>dsbgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab, bb = NumRu::Lapack.dsbgv( jobz, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.dsbgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSBGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
-* and banded, and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**T*S, as returned by DPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**T*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER VECT
- INTEGER IINFO, INDE, INDWRK
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsbgvd"></A>
- <H2>dsbgvd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ab, bb = NumRu::Lapack.dsbgvd( jobz, uplo, ka, kb, ab, bb, lwork, liwork)
- or
- NumRu::Lapack.dsbgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite banded eigenproblem, of the
-* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
-* banded, and B is also positive definite. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**T*S, as returned by DPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so Z**T*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= 3*N.
-* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsbgvx"></A>
- <H2>dsbgvx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.dsbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.dsbgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSBGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a real generalized symmetric-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
-* and banded, and B is also positive definite. Eigenvalues and
-* eigenvectors can be selected by specifying either all eigenvalues,
-* a range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**T*S, as returned by DPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)
-* If JOBZ = 'V', the n-by-n matrix used in the reduction of
-* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
-* and consequently C to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'N',
-* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so Z**T*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace/output) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (M)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvalues that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0 : successful exit
-* < 0 : if INFO = -i, the i-th argument had an illegal value
-* <= N: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in IFAIL.
-* > N : DPBSTF returned an error code; i.e.,
-* if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsbtrd"></A>
- <H2>dsbtrd</H2>
-
- <PRE>
-USAGE:
- d, e, info, ab, q = NumRu::Lapack.dsbtrd( vect, uplo, kd, ab, q)
- or
- NumRu::Lapack.dsbtrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSBTRD reduces a real symmetric band matrix A to symmetric
-* tridiagonal form T by an orthogonal similarity transformation:
-* Q**T * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form Q;
-* = 'V': form Q;
-* = 'U': update a matrix X, by forming X*Q.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* On exit, the diagonal elements of AB are overwritten by the
-* diagonal elements of the tridiagonal matrix T; if KD > 0, the
-* elements on the first superdiagonal (if UPLO = 'U') or the
-* first subdiagonal (if UPLO = 'L') are overwritten by the
-* off-diagonal elements of T; the rest of AB is overwritten by
-* values generated during the reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T.
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
-* On entry, if VECT = 'U', then Q must contain an N-by-N
-* matrix X; if VECT = 'N' or 'V', then Q need not be set.
-*
-* On exit:
-* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
-* if VECT = 'U', Q contains the product X*Q;
-* if VECT = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Modified by Linda Kaufman, Bell Labs.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dsge.html b/doc/dsge.html
deleted file mode 100644
index 51ec53f..0000000
--- a/doc/dsge.html
+++ /dev/null
@@ -1,141 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>Data type in double but solving problem using single precision routines for general (i.e., unsymmetric, in some cases rectangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>Data type in double but solving problem using single precision routines for general (i.e., unsymmetric, in some cases rectangular) matrix</H1>
- <UL>
- <LI><A HREF="#dsgesv">dsgesv</A> : </LI>
- </UL>
-
- <A NAME="dsgesv"></A>
- <H2>dsgesv</H2>
-
- <PRE>
-USAGE:
- ipiv, x, iter, info, a = NumRu::Lapack.dsgesv( a, b)
- or
- NumRu::Lapack.dsgesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )
-
-* Purpose
-* =======
-*
-* DSGESV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* DSGESV first attempts to factorize the matrix in SINGLE PRECISION
-* and use this factorization within an iterative refinement procedure
-* to produce a solution with DOUBLE PRECISION normwise backward error
-* quality (see below). If the approach fails the method switches to a
-* DOUBLE PRECISION factorization and solve.
-*
-* The iterative refinement is not going to be a winning strategy if
-* the ratio SINGLE PRECISION performance over DOUBLE PRECISION
-* performance is too small. A reasonable strategy should take the
-* number of right-hand sides and the size of the matrix into account.
-* This might be done with a call to ILAENV in the future. Up to now, we
-* always try iterative refinement.
-*
-* The iterative refinement process is stopped if
-* ITER > ITERMAX
-* or for all the RHS we have:
-* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
-* where
-* o ITER is the number of the current iteration in the iterative
-* refinement process
-* o RNRM is the infinity-norm of the residual
-* o XNRM is the infinity-norm of the solution
-* o ANRM is the infinity-operator-norm of the matrix A
-* o EPS is the machine epsilon returned by DLAMCH('Epsilon')
-* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00
-* respectively.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array,
-* dimension (LDA,N)
-* On entry, the N-by-N coefficient matrix A.
-* On exit, if iterative refinement has been successfully used
-* (INFO.EQ.0 and ITER.GE.0, see description below), then A is
-* unchanged, if double precision factorization has been used
-* (INFO.EQ.0 and ITER.LT.0, see description below), then the
-* array A contains the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-* Corresponds either to the single precision factorization
-* (if INFO.EQ.0 and ITER.GE.0) or the double precision
-* factorization (if INFO.EQ.0 and ITER.LT.0).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)
-* This array is used to hold the residual vectors.
-*
-* SWORK (workspace) REAL array, dimension (N*(N+NRHS))
-* This array is used to use the single precision matrix and the
-* right-hand sides or solutions in single precision.
-*
-* ITER (output) INTEGER
-* < 0: iterative refinement has failed, double precision
-* factorization has been performed
-* -1 : the routine fell back to full precision for
-* implementation- or machine-specific reasons
-* -2 : narrowing the precision induced an overflow,
-* the routine fell back to full precision
-* -3 : failure of SGETRF
-* -31: stop the iterative refinement after the 30th
-* iterations
-* > 0: iterative refinement has been sucessfully used.
-* Returns the number of iterations
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is
-* exactly zero. The factorization has been completed,
-* but the factor U is exactly singular, so the solution
-* could not be computed.
-*
-* =========
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="ds.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dsp.html b/doc/dsp.html
deleted file mode 100644
index 191a5c3..0000000
--- a/doc/dsp.html
+++ /dev/null
@@ -1,1824 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for symmetric, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for symmetric, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#dspcon">dspcon</A> : </LI>
- <LI><A HREF="#dspev">dspev</A> : </LI>
- <LI><A HREF="#dspevd">dspevd</A> : </LI>
- <LI><A HREF="#dspevx">dspevx</A> : </LI>
- <LI><A HREF="#dspgst">dspgst</A> : </LI>
- <LI><A HREF="#dspgv">dspgv</A> : </LI>
- <LI><A HREF="#dspgvd">dspgvd</A> : </LI>
- <LI><A HREF="#dspgvx">dspgvx</A> : </LI>
- <LI><A HREF="#dsposv">dsposv</A> : </LI>
- <LI><A HREF="#dsprfs">dsprfs</A> : </LI>
- <LI><A HREF="#dspsv">dspsv</A> : </LI>
- <LI><A HREF="#dspsvx">dspsvx</A> : </LI>
- <LI><A HREF="#dsptrd">dsptrd</A> : </LI>
- <LI><A HREF="#dsptrf">dsptrf</A> : </LI>
- <LI><A HREF="#dsptri">dsptri</A> : </LI>
- <LI><A HREF="#dsptrs">dsptrs</A> : </LI>
- </UL>
-
- <A NAME="dspcon"></A>
- <H2>dspcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dspcon( uplo, ap, ipiv, anorm)
- or
- NumRu::Lapack.dspcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric packed matrix A using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by DSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSPTRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspev"></A>
- <H2>dspev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap = NumRu::Lapack.dspev( jobz, uplo, ap)
- or
- NumRu::Lapack.dspev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
-* real symmetric matrix A in packed storage.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspevd"></A>
- <H2>dspevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ap = NumRu::Lapack.dspevd( jobz, uplo, ap, lwork, liwork)
- or
- NumRu::Lapack.dspevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPEVD computes all the eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A in packed storage. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
-* If JOBZ = 'V' and N > 1, LWORK must be at least
-* 1 + 6*N + N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspevx"></A>
- <H2>dspevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap = NumRu::Lapack.dspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.dspevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSPEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A in packed storage. Eigenvalues/vectors
-* can be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the selected eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspgst"></A>
- <H2>dspgst</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.dspgst( itype, uplo, n, ap, bp)
- or
- NumRu::Lapack.dspgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
-
-* Purpose
-* =======
-*
-* DSPGST reduces a real symmetric-definite generalized eigenproblem
-* to standard form, using packed storage.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
-*
-* B must have been previously factorized as U**T*U or L*L**T by DPPTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
-* = 2 or 3: compute U*A*U**T or L**T*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**T*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**T.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The triangular factor from the Cholesky factorization of B,
-* stored in the same format as A, as returned by DPPTRF.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspgv"></A>
- <H2>dspgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap, bp = NumRu::Lapack.dspgv( itype, jobz, uplo, ap, bp)
- or
- NumRu::Lapack.dspgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPGV computes all the eigenvalues and, optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be symmetric, stored in packed format,
-* and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension
-* (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T, in the same storage
-* format as B.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: DPPTRF or DSPEV returned an error code:
-* <= N: if INFO = i, DSPEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero.
-* > N: if INFO = n + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER TRANS
- INTEGER J, NEIG
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspgvd"></A>
- <H2>dspgvd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ap, bp = NumRu::Lapack.dspgvd( itype, jobz, uplo, ap, bp, lwork, liwork)
- or
- NumRu::Lapack.dspgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be symmetric, stored in packed format, and B is also
-* positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T, in the same storage
-* format as B.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= 2*N.
-* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: DPPTRF or DSPEVD returned an error code:
-* <= N: if INFO = i, DSPEVD failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspgvx"></A>
- <H2>dspgvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap, bp = NumRu::Lapack.dspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)
- or
- NumRu::Lapack.dspgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSPGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
-* and B are assumed to be symmetric, stored in packed storage, and B
-* is also positive definite. Eigenvalues and eigenvectors can be
-* selected by specifying either a range of values or a range of indices
-* for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A and B are stored;
-* = 'L': Lower triangle of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrix pencil (A,B). N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T, in the same storage
-* format as B.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: DPPTRF or DSPEVX returned an error code:
-* <= N: if INFO = i, DSPEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
- CHARACTER TRANS
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsposv"></A>
- <H2>dsposv</H2>
-
- <PRE>
-USAGE:
- x, iter, info, a = NumRu::Lapack.dsposv( uplo, a, b)
- or
- NumRu::Lapack.dsposv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )
-
-* Purpose
-* =======
-*
-* DSPOSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* DSPOSV first attempts to factorize the matrix in SINGLE PRECISION
-* and use this factorization within an iterative refinement procedure
-* to produce a solution with DOUBLE PRECISION normwise backward error
-* quality (see below). If the approach fails the method switches to a
-* DOUBLE PRECISION factorization and solve.
-*
-* The iterative refinement is not going to be a winning strategy if
-* the ratio SINGLE PRECISION performance over DOUBLE PRECISION
-* performance is too small. A reasonable strategy should take the
-* number of right-hand sides and the size of the matrix into account.
-* This might be done with a call to ILAENV in the future. Up to now, we
-* always try iterative refinement.
-*
-* The iterative refinement process is stopped if
-* ITER > ITERMAX
-* or for all the RHS we have:
-* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
-* where
-* o ITER is the number of the current iteration in the iterative
-* refinement process
-* o RNRM is the infinity-norm of the residual
-* o XNRM is the infinity-norm of the solution
-* o ANRM is the infinity-operator-norm of the matrix A
-* o EPS is the machine epsilon returned by DLAMCH('Epsilon')
-* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00
-* respectively.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array,
-* dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if iterative refinement has been successfully used
-* (INFO.EQ.0 and ITER.GE.0, see description below), then A is
-* unchanged, if double precision factorization has been used
-* (INFO.EQ.0 and ITER.LT.0, see description below), then the
-* array A contains the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)
-* This array is used to hold the residual vectors.
-*
-* SWORK (workspace) REAL array, dimension (N*(N+NRHS))
-* This array is used to use the single precision matrix and the
-* right-hand sides or solutions in single precision.
-*
-* ITER (output) INTEGER
-* < 0: iterative refinement has failed, double precision
-* factorization has been performed
-* -1 : the routine fell back to full precision for
-* implementation- or machine-specific reasons
-* -2 : narrowing the precision induced an overflow,
-* the routine fell back to full precision
-* -3 : failure of SPOTRF
-* -31: stop the iterative refinement after the 30th
-* iterations
-* > 0: iterative refinement has been sucessfully used.
-* Returns the number of iterations
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of (DOUBLE
-* PRECISION) A is not positive definite, so the
-* factorization could not be completed, and the solution
-* has not been computed.
-*
-* =========
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsprfs"></A>
- <H2>dsprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dsprfs( uplo, ap, afp, ipiv, b, x)
- or
- NumRu::Lapack.dsprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The factored form of the matrix A. AFP contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by DSPTRF, stored as a packed
-* triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSPTRF.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DSPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspsv"></A>
- <H2>dspsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap, b = NumRu::Lapack.dspsv( uplo, ap, b)
- or
- NumRu::Lapack.dspsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DSPSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix stored in packed format and X
-* and B are N-by-NRHS matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, D is symmetric and block diagonal with 1-by-1
-* and 2-by-2 diagonal blocks. The factored form of A is then used to
-* solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by DSPTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be
-* computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DSPTRF, DSPTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dspsvx"></A>
- <H2>dspsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.dspsvx( fact, uplo, ap, afp, ipiv, b)
- or
- NumRu::Lapack.dspsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
-* A = L*D*L**T to compute the solution to a real system of linear
-* equations A * X = B, where A is an N-by-N symmetric matrix stored
-* in packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AFP and IPIV contain the factored form of
-* A. AP, AFP and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* AFP (input or output) DOUBLE PRECISION array, dimension
-* (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by DSPTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by DSPTRF.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsptrd"></A>
- <H2>dsptrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, ap = NumRu::Lapack.dsptrd( uplo, ap)
- or
- NumRu::Lapack.dsptrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRD reduces a real symmetric matrix A stored in packed form to
-* symmetric tridiagonal form T by an orthogonal similarity
-* transformation: Q**T * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the orthogonal
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the orthogonal matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) DOUBLE PRECISION array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
-* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
-* overwriting A(i+2:n,i), and tau is stored in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsptrf"></A>
- <H2>dsptrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap = NumRu::Lapack.dsptrf( uplo, ap)
- or
- NumRu::Lapack.dsptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRF computes the factorization of a real symmetric matrix A stored
-* in packed format using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L, stored as a packed triangular
-* matrix overwriting A (see below for further details).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsptri"></A>
- <H2>dsptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.dsptri( uplo, ap, ipiv)
- or
- NumRu::Lapack.dsptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRI computes the inverse of a real symmetric indefinite matrix
-* A in packed storage using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by DSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by DSPTRF,
-* stored as a packed triangular matrix.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix, stored as a packed triangular matrix. The j-th column
-* of inv(A) is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
-* if UPLO = 'L',
-* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSPTRF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsptrs"></A>
- <H2>dsptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dsptrs( uplo, ap, ipiv, b)
- or
- NumRu::Lapack.dsptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRS solves a system of linear equations A*X = B with a real
-* symmetric matrix A stored in packed format using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by DSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSPTRF.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dspo.html b/doc/dspo.html
deleted file mode 100644
index 9d03532..0000000
--- a/doc/dspo.html
+++ /dev/null
@@ -1,146 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>Data type in double but solving problem using single precision routines for symmetric or Hermitian positive definite matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>Data type in double but solving problem using single precision routines for symmetric or Hermitian positive definite matrix</H1>
- <UL>
- <LI><A HREF="#dsposv">dsposv</A> : </LI>
- </UL>
-
- <A NAME="dsposv"></A>
- <H2>dsposv</H2>
-
- <PRE>
-USAGE:
- x, iter, info, a = NumRu::Lapack.dsposv( uplo, a, b)
- or
- NumRu::Lapack.dsposv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )
-
-* Purpose
-* =======
-*
-* DSPOSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* DSPOSV first attempts to factorize the matrix in SINGLE PRECISION
-* and use this factorization within an iterative refinement procedure
-* to produce a solution with DOUBLE PRECISION normwise backward error
-* quality (see below). If the approach fails the method switches to a
-* DOUBLE PRECISION factorization and solve.
-*
-* The iterative refinement is not going to be a winning strategy if
-* the ratio SINGLE PRECISION performance over DOUBLE PRECISION
-* performance is too small. A reasonable strategy should take the
-* number of right-hand sides and the size of the matrix into account.
-* This might be done with a call to ILAENV in the future. Up to now, we
-* always try iterative refinement.
-*
-* The iterative refinement process is stopped if
-* ITER > ITERMAX
-* or for all the RHS we have:
-* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
-* where
-* o ITER is the number of the current iteration in the iterative
-* refinement process
-* o RNRM is the infinity-norm of the residual
-* o XNRM is the infinity-norm of the solution
-* o ANRM is the infinity-operator-norm of the matrix A
-* o EPS is the machine epsilon returned by DLAMCH('Epsilon')
-* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00
-* respectively.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array,
-* dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if iterative refinement has been successfully used
-* (INFO.EQ.0 and ITER.GE.0, see description below), then A is
-* unchanged, if double precision factorization has been used
-* (INFO.EQ.0 and ITER.LT.0, see description below), then the
-* array A contains the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)
-* This array is used to hold the residual vectors.
-*
-* SWORK (workspace) REAL array, dimension (N*(N+NRHS))
-* This array is used to use the single precision matrix and the
-* right-hand sides or solutions in single precision.
-*
-* ITER (output) INTEGER
-* < 0: iterative refinement has failed, double precision
-* factorization has been performed
-* -1 : the routine fell back to full precision for
-* implementation- or machine-specific reasons
-* -2 : narrowing the precision induced an overflow,
-* the routine fell back to full precision
-* -3 : failure of SPOTRF
-* -31: stop the iterative refinement after the 30th
-* iterations
-* > 0: iterative refinement has been sucessfully used.
-* Returns the number of iterations
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of (DOUBLE
-* PRECISION) A is not positive definite, so the
-* factorization could not be completed, and the solution
-* has not been computed.
-*
-* =========
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="ds.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dspt.html b/doc/dspt.html
deleted file mode 100644
index be93c05..0000000
--- a/doc/dspt.html
+++ /dev/null
@@ -1,362 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>Data type in double but solving problem using single precision routines for symmetric or Hermitian positive definite tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>Data type in double but solving problem using single precision routines for symmetric or Hermitian positive definite tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#dsptrd">dsptrd</A> : </LI>
- <LI><A HREF="#dsptrf">dsptrf</A> : </LI>
- <LI><A HREF="#dsptri">dsptri</A> : </LI>
- <LI><A HREF="#dsptrs">dsptrs</A> : </LI>
- </UL>
-
- <A NAME="dsptrd"></A>
- <H2>dsptrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, ap = NumRu::Lapack.dsptrd( uplo, ap)
- or
- NumRu::Lapack.dsptrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRD reduces a real symmetric matrix A stored in packed form to
-* symmetric tridiagonal form T by an orthogonal similarity
-* transformation: Q**T * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the orthogonal
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the orthogonal matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) DOUBLE PRECISION array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
-* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
-* overwriting A(i+2:n,i), and tau is stored in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsptrf"></A>
- <H2>dsptrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap = NumRu::Lapack.dsptrf( uplo, ap)
- or
- NumRu::Lapack.dsptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRF computes the factorization of a real symmetric matrix A stored
-* in packed format using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L, stored as a packed triangular
-* matrix overwriting A (see below for further details).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsptri"></A>
- <H2>dsptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.dsptri( uplo, ap, ipiv)
- or
- NumRu::Lapack.dsptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRI computes the inverse of a real symmetric indefinite matrix
-* A in packed storage using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by DSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by DSPTRF,
-* stored as a packed triangular matrix.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix, stored as a packed triangular matrix. The j-th column
-* of inv(A) is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
-* if UPLO = 'L',
-* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSPTRF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsptrs"></A>
- <H2>dsptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dsptrs( uplo, ap, ipiv, b)
- or
- NumRu::Lapack.dsptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DSPTRS solves a system of linear equations A*X = B with a real
-* symmetric matrix A stored in packed format using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by DSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSPTRF.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="ds.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dst.html b/doc/dst.html
deleted file mode 100644
index 260819a..0000000
--- a/doc/dst.html
+++ /dev/null
@@ -1,1454 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for (real) symmetric tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for (real) symmetric tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#dstebz">dstebz</A> : </LI>
- <LI><A HREF="#dstedc">dstedc</A> : </LI>
- <LI><A HREF="#dstegr">dstegr</A> : </LI>
- <LI><A HREF="#dstein">dstein</A> : </LI>
- <LI><A HREF="#dstemr">dstemr</A> : </LI>
- <LI><A HREF="#dsteqr">dsteqr</A> : </LI>
- <LI><A HREF="#dsterf">dsterf</A> : </LI>
- <LI><A HREF="#dstev">dstev</A> : </LI>
- <LI><A HREF="#dstevd">dstevd</A> : </LI>
- <LI><A HREF="#dstevr">dstevr</A> : </LI>
- <LI><A HREF="#dstevx">dstevx</A> : </LI>
- </UL>
-
- <A NAME="dstebz"></A>
- <H2>dstebz</H2>
-
- <PRE>
-USAGE:
- m, nsplit, w, iblock, isplit, info = NumRu::Lapack.dstebz( range, order, vl, vu, il, iu, abstol, d, e)
- or
- NumRu::Lapack.dstebz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEBZ computes the eigenvalues of a symmetric tridiagonal
-* matrix T. The user may ask for all eigenvalues, all eigenvalues
-* in the half-open interval (VL, VU], or the IL-th through IU-th
-* eigenvalues.
-*
-* To avoid overflow, the matrix must be scaled so that its
-* largest element is no greater than overflow**(1/2) *
-* underflow**(1/4) in absolute value, and for greatest
-* accuracy, it should not be much smaller than that.
-*
-* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
-* Matrix", Report CS41, Computer Science Dept., Stanford
-* University, July 21, 1966.
-*
-
-* Arguments
-* =========
-*
-* RANGE (input) CHARACTER*1
-* = 'A': ("All") all eigenvalues will be found.
-* = 'V': ("Value") all eigenvalues in the half-open interval
-* (VL, VU] will be found.
-* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
-* entire matrix) will be found.
-*
-* ORDER (input) CHARACTER*1
-* = 'B': ("By Block") the eigenvalues will be grouped by
-* split-off block (see IBLOCK, ISPLIT) and
-* ordered from smallest to largest within
-* the block.
-* = 'E': ("Entire matrix")
-* the eigenvalues for the entire matrix
-* will be ordered from smallest to
-* largest.
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix T. N >= 0.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. Eigenvalues less than or equal
-* to VL, or greater than VU, will not be returned. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute tolerance for the eigenvalues. An eigenvalue
-* (or cluster) is considered to be located if it has been
-* determined to lie in an interval whose width is ABSTOL or
-* less. If ABSTOL is less than or equal to zero, then ULP*|T|
-* will be used, where |T| means the 1-norm of T.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix T.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) off-diagonal elements of the tridiagonal matrix T.
-*
-* M (output) INTEGER
-* The actual number of eigenvalues found. 0 <= M <= N.
-* (See also the description of INFO=2,3.)
-*
-* NSPLIT (output) INTEGER
-* The number of diagonal blocks in the matrix T.
-* 1 <= NSPLIT <= N.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* On exit, the first M elements of W will contain the
-* eigenvalues. (DSTEBZ may use the remaining N-M elements as
-* workspace.)
-*
-* IBLOCK (output) INTEGER array, dimension (N)
-* At each row/column j where E(j) is zero or small, the
-* matrix T is considered to split into a block diagonal
-* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
-* block (from 1 to the number of blocks) the eigenvalue W(i)
-* belongs. (DSTEBZ may use the remaining N-M elements as
-* workspace.)
-*
-* ISPLIT (output) INTEGER array, dimension (N)
-* The splitting points, at which T breaks up into submatrices.
-* The first submatrix consists of rows/columns 1 to ISPLIT(1),
-* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
-* etc., and the NSPLIT-th consists of rows/columns
-* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
-* (Only the first NSPLIT elements will actually be used, but
-* since the user cannot know a priori what value NSPLIT will
-* have, N words must be reserved for ISPLIT.)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: some or all of the eigenvalues failed to converge or
-* were not computed:
-* =1 or 3: Bisection failed to converge for some
-* eigenvalues; these eigenvalues are flagged by a
-* negative block number. The effect is that the
-* eigenvalues may not be as accurate as the
-* absolute and relative tolerances. This is
-* generally caused by unexpectedly inaccurate
-* arithmetic.
-* =2 or 3: RANGE='I' only: Not all of the eigenvalues
-* IL:IU were found.
-* Effect: M < IU+1-IL
-* Cause: non-monotonic arithmetic, causing the
-* Sturm sequence to be non-monotonic.
-* Cure: recalculate, using RANGE='A', and pick
-* out eigenvalues IL:IU. In some cases,
-* increasing the PARAMETER "FUDGE" may
-* make things work.
-* = 4: RANGE='I', and the Gershgorin interval
-* initially used was too small. No eigenvalues
-* were computed.
-* Probable cause: your machine has sloppy
-* floating-point arithmetic.
-* Cure: Increase the PARAMETER "FUDGE",
-* recompile, and try again.
-*
-* Internal Parameters
-* ===================
-*
-* RELFAC DOUBLE PRECISION, default = 2.0e0
-* The relative tolerance. An interval (a,b] lies within
-* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
-* where "ulp" is the machine precision (distance from 1 to
-* the next larger floating point number.)
-*
-* FUDGE DOUBLE PRECISION, default = 2
-* A "fudge factor" to widen the Gershgorin intervals. Ideally,
-* a value of 1 should work, but on machines with sloppy
-* arithmetic, this needs to be larger. The default for
-* publicly released versions should be large enough to handle
-* the worst machine around. Note that this has no effect
-* on accuracy of the solution.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstedc"></A>
- <H2>dstedc</H2>
-
- <PRE>
-USAGE:
- work, iwork, info, d, e, z = NumRu::Lapack.dstedc( compz, d, e, z, lwork, liwork)
- or
- NumRu::Lapack.dstedc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the divide and conquer method.
-* The eigenvectors of a full or band real symmetric matrix can also be
-* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
-* matrix to tridiagonal form.
-*
-* This code makes very mild assumptions about floating point
-* arithmetic. It will work on machines with a guard digit in
-* add/subtract, or on those binary machines without guard digits
-* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
-* It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none. See DLAED3 for details.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-* = 'V': Compute eigenvectors of original dense symmetric
-* matrix also. On entry, Z contains the orthogonal
-* matrix used to reduce the original matrix to
-* tridiagonal form.
-*
-* N (input) INTEGER
-* The dimension of the symmetric tridiagonal matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the subdiagonal elements of the tridiagonal matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
-* On entry, if COMPZ = 'V', then Z contains the orthogonal
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original symmetric matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
-* If COMPZ = 'V' and N > 1 then LWORK must be at least
-* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
-* where lg( N ) = smallest integer k such
-* that 2**k >= N.
-* If COMPZ = 'I' and N > 1 then LWORK must be at least
-* ( 1 + 4*N + N**2 ).
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LWORK need
-* only be max(1,2*(N-1)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
-* If COMPZ = 'V' and N > 1 then LIWORK must be at least
-* ( 6 + 6*N + 5*N*lg N ).
-* If COMPZ = 'I' and N > 1 then LIWORK must be at least
-* ( 3 + 5*N ).
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LIWORK
-* need only be 1.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The algorithm failed to compute an eigenvalue while
-* working on the submatrix lying in rows and columns
-* INFO/(N+1) through mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-* Modified by Francoise Tisseur, University of Tennessee.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstegr"></A>
- <H2>dstegr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.dstegr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEGR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* DSTEGR is a compatability wrapper around the improved DSTEMR routine.
-* See DSTEMR for further details.
-*
-* One important change is that the ABSTOL parameter no longer provides any
-* benefit and hence is no longer used.
-*
-* Note : DSTEGR and DSTEMR work only on machines which follow
-* IEEE-754 floating-point standard in their handling of infinities and
-* NaNs. Normal execution may create these exceptiona values and hence
-* may abort due to a floating point exception in environments which
-* do not conform to the IEEE-754 standard.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* Unused. Was the absolute error tolerance for the
-* eigenvalues/eigenvectors in previous versions.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-* Supplying N columns is always safe.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in DLARRE,
-* if INFO = 2X, internal error in DLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by DLARRE or
-* DLARRV, respectively.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL TRYRAC
-* ..
-* .. External Subroutines ..
- EXTERNAL DSTEMR
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstein"></A>
- <H2>dstein</H2>
-
- <PRE>
-USAGE:
- z, ifail, info = NumRu::Lapack.dstein( d, e, w, iblock, isplit)
- or
- NumRu::Lapack.dstein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSTEIN computes the eigenvectors of a real symmetric tridiagonal
-* matrix T corresponding to specified eigenvalues, using inverse
-* iteration.
-*
-* The maximum number of iterations allowed for each eigenvector is
-* specified by an internal parameter MAXITS (currently set to 5).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix T.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix
-* T, in elements 1 to N-1.
-*
-* M (input) INTEGER
-* The number of eigenvectors to be found. 0 <= M <= N.
-*
-* W (input) DOUBLE PRECISION array, dimension (N)
-* The first M elements of W contain the eigenvalues for
-* which eigenvectors are to be computed. The eigenvalues
-* should be grouped by split-off block and ordered from
-* smallest to largest within the block. ( The output array
-* W from DSTEBZ with ORDER = 'B' is expected here. )
-*
-* IBLOCK (input) INTEGER array, dimension (N)
-* The submatrix indices associated with the corresponding
-* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
-* the first submatrix from the top, =2 if W(i) belongs to
-* the second submatrix, etc. ( The output array IBLOCK
-* from DSTEBZ is expected here. )
-*
-* ISPLIT (input) INTEGER array, dimension (N)
-* The splitting points, at which T breaks up into submatrices.
-* The first submatrix consists of rows/columns 1 to
-* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
-* through ISPLIT( 2 ), etc.
-* ( The output array ISPLIT from DSTEBZ is expected here. )
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, M)
-* The computed eigenvectors. The eigenvector associated
-* with the eigenvalue W(i) is stored in the i-th column of
-* Z. Any vector which fails to converge is set to its current
-* iterate after MAXITS iterations.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* IFAIL (output) INTEGER array, dimension (M)
-* On normal exit, all elements of IFAIL are zero.
-* If one or more eigenvectors fail to converge after
-* MAXITS iterations, then their indices are stored in
-* array IFAIL.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge
-* in MAXITS iterations. Their indices are stored in
-* array IFAIL.
-*
-* Internal Parameters
-* ===================
-*
-* MAXITS INTEGER, default = 5
-* The maximum number of iterations performed.
-*
-* EXTRA INTEGER, default = 2
-* The number of iterations performed after norm growth
-* criterion is satisfied, should be at least 1.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstemr"></A>
- <H2>dstemr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.dstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)
- or
- NumRu::Lapack.dstemr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEMR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* Depending on the number of desired eigenvalues, these are computed either
-* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
-* computed by the use of various suitable L D L^T factorizations near clusters
-* of close eigenvalues (referred to as RRRs, Relatively Robust
-* Representations). An informal sketch of the algorithm follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* For more details, see:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-* Further Details
-* 1.DSTEMR works only on machines which follow IEEE-754
-* floating-point standard in their handling of infinities and NaNs.
-* This permits the use of efficient inner loops avoiding a check for
-* zero divisors.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and can be computed with a workspace
-* query by setting NZC = -1, see below.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* NZC (input) INTEGER
-* The number of eigenvectors to be held in the array Z.
-* If RANGE = 'A', then NZC >= max(1,N).
-* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
-* If RANGE = 'I', then NZC >= IU-IL+1.
-* If NZC = -1, then a workspace query is assumed; the
-* routine calculates the number of columns of the array Z that
-* are needed to hold the eigenvectors.
-* This value is returned as the first entry of the Z array, and
-* no error message related to NZC is issued by XERBLA.
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* TRYRAC (input/output) LOGICAL
-* If TRYRAC.EQ..TRUE., indicates that the code should check whether
-* the tridiagonal matrix defines its eigenvalues to high relative
-* accuracy. If so, the code uses relative-accuracy preserving
-* algorithms that might be (a bit) slower depending on the matrix.
-* If the matrix does not define its eigenvalues to high relative
-* accuracy, the code can uses possibly faster algorithms.
-* If TRYRAC.EQ..FALSE., the code is not required to guarantee
-* relatively accurate eigenvalues and can use the fastest possible
-* techniques.
-* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
-* does not define its eigenvalues to high relative accuracy.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in DLARRE,
-* if INFO = 2X, internal error in DLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by DLARRE or
-* DLARRV, respectively.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Beresford Parlett, University of California, Berkeley, USA
-* Jim Demmel, University of California, Berkeley, USA
-* Inderjit Dhillon, University of Texas, Austin, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, University of California, Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsteqr"></A>
- <H2>dsteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.dsteqr( compz, d, e, z)
- or
- NumRu::Lapack.dsteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the implicit QL or QR method.
-* The eigenvectors of a full or band symmetric matrix can also be found
-* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
-* tridiagonal form.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvalues and eigenvectors of the original
-* symmetric matrix. On entry, Z must contain the
-* orthogonal matrix used to reduce the original matrix
-* to tridiagonal form.
-* = 'I': Compute eigenvalues and eigenvectors of the
-* tridiagonal matrix. Z is initialized to the identity
-* matrix.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', then Z contains the orthogonal
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original symmetric matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
-* If COMPZ = 'N', then WORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm has failed to find all the eigenvalues in
-* a total of 30*N iterations; if INFO = i, then i
-* elements of E have not converged to zero; on exit, D
-* and E contain the elements of a symmetric tridiagonal
-* matrix which is orthogonally similar to the original
-* matrix.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsterf"></A>
- <H2>dsterf</H2>
-
- <PRE>
-USAGE:
- info, d, e = NumRu::Lapack.dsterf( d, e)
- or
- NumRu::Lapack.dsterf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTERF( N, D, E, INFO )
-
-* Purpose
-* =======
-*
-* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
-* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm failed to find all of the eigenvalues in
-* a total of 30*N iterations; if INFO = i, then i
-* elements of E have not converged to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstev"></A>
- <H2>dstev</H2>
-
- <PRE>
-USAGE:
- z, info, d, e = NumRu::Lapack.dstev( jobz, d, e)
- or
- NumRu::Lapack.dstev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEV computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric tridiagonal matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A, stored in elements 1 to N-1 of E.
-* On exit, the contents of E are destroyed.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with D(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
-* If JOBZ = 'N', WORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of E did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstevd"></A>
- <H2>dstevd</H2>
-
- <PRE>
-USAGE:
- z, work, iwork, info, d, e = NumRu::Lapack.dstevd( jobz, d, e, lwork, liwork)
- or
- NumRu::Lapack.dstevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric tridiagonal matrix. If eigenvectors are desired, it
-* uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A, stored in elements 1 to N-1 of E.
-* On exit, the contents of E are destroyed.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with D(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.
-* If JOBZ = 'V' and N > 1 then LWORK must be at least
-* ( 1 + 4*N + N**2 ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of E did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstevr"></A>
- <H2>dstevr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstevr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.dstevr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSTEVR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Eigenvalues and
-* eigenvectors can be selected by specifying either a range of values
-* or a range of indices for the desired eigenvalues.
-*
-* Whenever possible, DSTEVR calls DSTEMR to compute the
-* eigenspectrum using Relatively Robust Representations. DSTEMR
-* computes eigenvalues by the dqds algorithm, while orthogonal
-* eigenvectors are computed from various "good" L D L^T representations
-* (also known as Relatively Robust Representations). Gram-Schmidt
-* orthogonalization is avoided as far as possible. More specifically,
-* the various steps of the algorithm are as follows. For the i-th
-* unreduced block of T,
-* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
-* is a relatively robust representation,
-* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
-* relative accuracy by the dqds algorithm,
-* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
-* close to the cluster, and go to step (a),
-* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
-* compute the corresponding eigenvector by forming a
-* rank-revealing twisted factorization.
-* The desired accuracy of the output can be specified by the input
-* parameter ABSTOL.
-*
-* For more details, see "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
-* Computer Science Division Technical Report No. UCB//CSD-97-971,
-* UC Berkeley, May 1997.
-*
-*
-* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested
-* on machines which conform to the ieee-754 floating point standard.
-* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and
-* when partial spectrum requests are made.
-*
-* Normal execution of DSTEMR may create NaNs and infinities and
-* hence may abort due to a floating point exception in environments
-* which do not handle NaNs and infinities in the ieee standard default
-* manner.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
-********** DSTEIN are called
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, D may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A in elements 1 to N-1 of E.
-* On exit, E may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* If high relative accuracy is important, set ABSTOL to
-* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
-* eigenvalues are computed to high relative accuracy when
-* possible in future releases. The current code does not
-* make any guarantees about high relative accuracy, but
-* future releases will. See J. Barlow and J. Demmel,
-* "Computing Accurate Eigensystems of Scaled Diagonally
-* Dominant Matrices", LAPACK Working Note #7, for a discussion
-* of which matrices define their eigenvalues to high relative
-* accuracy.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ).
-********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal (and
-* minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,20*N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal (and
-* minimal) LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: Internal error
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Ken Stanley, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dstevx"></A>
- <H2>dstevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, d, e = NumRu::Lapack.dstevx( jobz, range, d, e, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.dstevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSTEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix A. Eigenvalues and
-* eigenvectors can be selected by specifying either a range of values
-* or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, D may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A in elements 1 to N-1 of E.
-* On exit, E may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less
-* than or equal to zero, then EPS*|T| will be used in
-* its place, where |T| is the 1-norm of the tridiagonal
-* matrix.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge (INFO > 0), then that
-* column of Z contains the latest approximation to the
-* eigenvector, and the index of the eigenvector is returned
-* in IFAIL. If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dsy.html b/doc/dsy.html
deleted file mode 100644
index 20eccfd..0000000
--- a/doc/dsy.html
+++ /dev/null
@@ -1,3513 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for symmetric matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for symmetric matrix</H1>
- <UL>
- <LI><A HREF="#dsycon">dsycon</A> : </LI>
- <LI><A HREF="#dsyconv">dsyconv</A> : </LI>
- <LI><A HREF="#dsyequb">dsyequb</A> : </LI>
- <LI><A HREF="#dsyev">dsyev</A> : </LI>
- <LI><A HREF="#dsyevd">dsyevd</A> : </LI>
- <LI><A HREF="#dsyevr">dsyevr</A> : </LI>
- <LI><A HREF="#dsyevx">dsyevx</A> : </LI>
- <LI><A HREF="#dsygs2">dsygs2</A> : </LI>
- <LI><A HREF="#dsygst">dsygst</A> : </LI>
- <LI><A HREF="#dsygv">dsygv</A> : </LI>
- <LI><A HREF="#dsygvd">dsygvd</A> : </LI>
- <LI><A HREF="#dsygvx">dsygvx</A> : </LI>
- <LI><A HREF="#dsyrfs">dsyrfs</A> : </LI>
- <LI><A HREF="#dsyrfsx">dsyrfsx</A> : </LI>
- <LI><A HREF="#dsysv">dsysv</A> : </LI>
- <LI><A HREF="#dsysvx">dsysvx</A> : </LI>
- <LI><A HREF="#dsysvxx">dsysvxx</A> : </LI>
- <LI><A HREF="#dsyswapr">dsyswapr</A> : </LI>
- <LI><A HREF="#dsytd2">dsytd2</A> : </LI>
- <LI><A HREF="#dsytf2">dsytf2</A> : </LI>
- <LI><A HREF="#dsytrd">dsytrd</A> : </LI>
- <LI><A HREF="#dsytrf">dsytrf</A> : </LI>
- <LI><A HREF="#dsytri">dsytri</A> : </LI>
- <LI><A HREF="#dsytri2">dsytri2</A> : </LI>
- <LI><A HREF="#dsytri2x">dsytri2x</A> : </LI>
- <LI><A HREF="#dsytrs">dsytrs</A> : </LI>
- <LI><A HREF="#dsytrs2">dsytrs2</A> : </LI>
- </UL>
-
- <A NAME="dsycon"></A>
- <H2>dsycon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dsycon( uplo, a, ipiv, anorm)
- or
- NumRu::Lapack.dsycon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric matrix A using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by DSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyconv"></A>
- <H2>dsyconv</H2>
-
- <PRE>
-USAGE:
- info = NumRu::Lapack.dsyconv( uplo, way, a, ipiv)
- or
- NumRu::Lapack.dsyconv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYCONV convert A given by TRF into L and D and vice-versa.
-* Get Non-diag elements of D (returned in workspace) and
-* apply or reverse permutation done in TRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* WAY (input) CHARACTER*1
-* = 'C': Convert
-* = 'R': Revert
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by DSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1.
-* LWORK = N
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyequb"></A>
- <H2>dsyequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.dsyequb( uplo, a)
- or
- NumRu::Lapack.dsyequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYEQUB computes row and column scalings intended to equilibrate a
-* symmetric matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The N-by-N symmetric matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* Further Details
-* ======= =======
-*
-* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization",
-* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.
-* DOI 10.1023/B:NUMA.0000016606.32820.69
-* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyev"></A>
- <H2>dsyev</H2>
-
- <PRE>
-USAGE:
- w, work, info, a = NumRu::Lapack.dsyev( jobz, uplo, a, lwork)
- or
- NumRu::Lapack.dsyev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYEV computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,3*N-1).
-* For optimal efficiency, LWORK >= (NB+2)*N,
-* where NB is the blocksize for DSYTRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyevd"></A>
- <H2>dsyevd</H2>
-
- <PRE>
-USAGE:
- w, work, iwork, info, a = NumRu::Lapack.dsyevd( jobz, uplo, a, lwork, liwork)
- or
- NumRu::Lapack.dsyevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric matrix A. If eigenvectors are desired, it uses a
-* divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-* Because of large use of BLAS of level 3, DSYEVD needs N**2 more
-* workspace than DSYEVX.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
-* If JOBZ = 'V' and N > 1, LWORK must be at least
-* 1 + 6*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
-* to converge; i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* if INFO = i and JOBZ = 'V', then the algorithm failed
-* to compute an eigenvalue while working on the submatrix
-* lying in rows and columns INFO/(N+1) through
-* mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-* Modified by Francoise Tisseur, University of Tennessee.
-*
-* Modified description of INFO. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyevr"></A>
- <H2>dsyevr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.dsyevr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYEVR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
-* selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-* DSYEVR first reduces the matrix A to tridiagonal form T with a call
-* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute
-* the eigenspectrum using Relatively Robust Representations. DSTEMR
-* computes eigenvalues by the dqds algorithm, while orthogonal
-* eigenvectors are computed from various "good" L D L^T representations
-* (also known as Relatively Robust Representations). Gram-Schmidt
-* orthogonalization is avoided as far as possible. More specifically,
-* the various steps of the algorithm are as follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* The desired accuracy of the output can be specified by the input
-* parameter ABSTOL.
-*
-* For more details, see DSTEMR's documentation and:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-*
-* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
-* on machines which conform to the ieee-754 floating point standard.
-* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and
-* when partial spectrum requests are made.
-*
-* Normal execution of DSTEMR may create NaNs and infinities and
-* hence may abort due to a floating point exception in environments
-* which do not handle NaNs and infinities in the ieee standard default
-* manner.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
-********** DSTEIN are called
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* If high relative accuracy is important, set ABSTOL to
-* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
-* eigenvalues are computed to high relative accuracy when
-* possible in future releases. The current code does not
-* make any guarantees about high relative accuracy, but
-* future releases will. See J. Barlow and J. Demmel,
-* "Computing Accurate Eigensystems of Scaled Diagonally
-* Dominant Matrices", LAPACK Working Note #7, for a discussion
-* of which matrices define their eigenvalues to high relative
-* accuracy.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-* Supplying N columns is always safe.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ).
-********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,26*N).
-* For optimal efficiency, LWORK >= (NB+6)*N,
-* where NB is the max of the blocksize for DSYTRD and DORMTR
-* returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: Internal error
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Ken Stanley, Computer Science Division, University of
-* California at Berkeley, USA
-* Jason Riedy, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyevx"></A>
- <H2>dsyevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a = NumRu::Lapack.dsyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)
- or
- NumRu::Lapack.dsyevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSYEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
-* selected by specifying either a range of values or a range of indices
-* for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= 1, when N <= 1;
-* otherwise 8*N.
-* For optimal efficiency, LWORK >= (NB+3)*N,
-* where NB is the max of the blocksize for DSYTRD and DORMTR
-* returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsygs2"></A>
- <H2>dsygs2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dsygs2( itype, uplo, a, b)
- or
- NumRu::Lapack.dsygs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DSYGS2 reduces a real symmetric-definite generalized eigenproblem
-* to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
-*
-* B must have been previously factorized as U'*U or L*L' by DPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
-* = 2 or 3: compute U*A*U' or L'*A*L.
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored, and how B has been factorized.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by DPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsygst"></A>
- <H2>dsygst</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dsygst( itype, uplo, a, b)
- or
- NumRu::Lapack.dsygst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DSYGST reduces a real symmetric-definite generalized eigenproblem
-* to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
-*
-* B must have been previously factorized as U**T*U or L*L**T by DPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
-* = 2 or 3: compute U*A*U**T or L**T*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**T*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**T.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by DPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsygv"></A>
- <H2>dsygv</H2>
-
- <PRE>
-USAGE:
- w, work, info, a, b = NumRu::Lapack.dsygv( itype, jobz, uplo, a, b, lwork)
- or
- NumRu::Lapack.dsygv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be symmetric and B is also
-* positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the symmetric positive definite matrix B.
-* If UPLO = 'U', the leading N-by-N upper triangular part of B
-* contains the upper triangular part of the matrix B.
-* If UPLO = 'L', the leading N-by-N lower triangular part of B
-* contains the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,3*N-1).
-* For optimal efficiency, LWORK >= (NB+2)*N,
-* where NB is the blocksize for DSYTRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: DPOTRF or DSYEV returned an error code:
-* <= N: if INFO = i, DSYEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsygvd"></A>
- <H2>dsygvd</H2>
-
- <PRE>
-USAGE:
- w, work, iwork, info, a, b = NumRu::Lapack.dsygvd( itype, jobz, uplo, a, b, lwork, liwork)
- or
- NumRu::Lapack.dsygvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be symmetric and B is also positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the symmetric matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
-* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK >= 1.
-* If JOBZ = 'N' and N > 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: DPOTRF or DSYEVD returned an error code:
-* <= N: if INFO = i and JOBZ = 'N', then the algorithm
-* failed to converge; i off-diagonal elements of an
-* intermediate tridiagonal form did not converge to
-* zero;
-* if INFO = i and JOBZ = 'V', then the algorithm
-* failed to compute an eigenvalue while working on
-* the submatrix lying in rows and columns INFO/(N+1)
-* through mod(INFO,N+1);
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* Modified so that no backsubstitution is performed if DSYEVD fails to
-* converge (NEIG in old code could be greater than N causing out of
-* bounds reference to A - reported by Ralf Meyer). Also corrected the
-* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsygvx"></A>
- <H2>dsygvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a, b = NumRu::Lapack.dsygvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, ldz, lwork)
- or
- NumRu::Lapack.dsygvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* DSYGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
-* and B are assumed to be symmetric and B is also positive definite.
-* Eigenvalues and eigenvectors can be selected by specifying either a
-* range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A and B are stored;
-* = 'L': Lower triangle of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrix pencil (A,B). N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, the symmetric matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,8*N).
-* For optimal efficiency, LWORK >= (NB+3)*N,
-* where NB is the blocksize for DSYTRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: DPOTRF or DSYEVX returned an error code:
-* <= N: if INFO = i, DSYEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyrfs"></A>
- <H2>dsyrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.dsyrfs( uplo, a, af, ipiv, b, x)
- or
- NumRu::Lapack.dsyrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by DSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DSYTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyrfsx"></A>
- <H2>dsyrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)
- or
- NumRu::Lapack.dsyrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYRFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the
-* solution. In addition to normwise error bound, the code provides
-* maximum componentwise error bound if possible. See comments for
-* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or A =
-* L*D*L**T as computed by DSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsysv"></A>
- <H2>dsysv</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a, b = NumRu::Lapack.dsysv( uplo, a, b, lwork)
- or
- NumRu::Lapack.dsysv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
-* used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the block diagonal matrix D and the
-* multipliers used to obtain the factor U or L from the
-* factorization A = U*D*U**T or A = L*D*L**T as computed by
-* DSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by DSYTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= 1, and for best performance
-* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
-* DSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LWKOPT, NB
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DSYTRF, DSYTRS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsysvx"></A>
- <H2>dsysvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.dsysvx( fact, uplo, a, af, ipiv, b, lwork)
- or
- NumRu::Lapack.dsysvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYSVX uses the diagonal pivoting factorization to compute the
-* solution to a real system of linear equations A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
-* The form of the factorization is
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AF and IPIV contain the factored form of
-* A. AF and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by DSYTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by DSYTRF.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= max(1,3*N), and for best
-* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
-* NB is the optimal blocksize for DSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsysvxx"></A>
- <H2>dsysvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.dsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)
- or
- NumRu::Lapack.dsysvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYSVXX uses the diagonal pivoting factorization to compute the
-* solution to a double precision system of linear equations A * X = B, where A
-* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. DSYSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* DSYSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* DSYSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what DSYSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 3. If some D(i,i)=0, so that D is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is
-* less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(R) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T as computed by DSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block
-* structure of D, as determined by DSYTRF. If IPIV(k) > 0,
-* then rows and columns k and IPIV(k) were interchanged and
-* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and
-* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and
-* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2
-* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,
-* then rows and columns k+1 and -IPIV(k) were interchanged
-* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block
-* structure of D, as determined by DSYTRF.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsyswapr"></A>
- <H2>dsyswapr</H2>
-
- <PRE>
-USAGE:
- a = NumRu::Lapack.dsyswapr( uplo, a, i1, i2)
- or
- NumRu::Lapack.dsyswapr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYSWAPR( UPLO, N, A, I1, I2)
-
-* Purpose
-* =======
-*
-* DSYSWAPR applies an elementary permutation on the rows and the columns of
-* a symmetric matrix.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by DSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* I1 (input) INTEGER
-* Index of the first row to swap
-*
-* I2 (input) INTEGER
-* Index of the second row to swap
-*
-
-* =====================================================================
-*
-* ..
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
- DOUBLE PRECISION TMP
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DSWAP
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytd2"></A>
- <H2>dsytd2</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, a = NumRu::Lapack.dsytd2( uplo, a)
- or
- NumRu::Lapack.dsytd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
-* form T by an orthogonal similarity transformation: Q' * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the orthogonal
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the orthogonal matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) DOUBLE PRECISION array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytf2"></A>
- <H2>dsytf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.dsytf2( uplo, a)
- or
- NumRu::Lapack.dsytf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* DSYTF2 computes the factorization of a real symmetric matrix A using
-* the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U' or A = L*D*L'
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, U' is the transpose of U, and D is symmetric and
-* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 09-29-06 - patch from
-* Bobby Cheng, MathWorks
-*
-* Replace l.204 and l.372
-* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
-* by
-* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
-*
-* 01-01-96 - Based on modifications by
-* J. Lewis, Boeing Computer Services Company
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytrd"></A>
- <H2>dsytrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, work, info, a = NumRu::Lapack.dsytrd( uplo, a, lwork)
- or
- NumRu::Lapack.dsytrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYTRD reduces a real symmetric matrix A to real symmetric
-* tridiagonal form T by an orthogonal similarity transformation:
-* Q**T * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the orthogonal
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the orthogonal matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) DOUBLE PRECISION array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytrf"></A>
- <H2>dsytrf</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a = NumRu::Lapack.dsytrf( uplo, a, lwork)
- or
- NumRu::Lapack.dsytrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYTRF computes the factorization of a real symmetric matrix A using
-* the Bunch-Kaufman diagonal pivoting method. The form of the
-* factorization is
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1. For best performance
-* LWORK >= N*NB, where NB is the block size returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER
- INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DLASYF, DSYTF2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytri"></A>
- <H2>dsytri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dsytri( uplo, a, ipiv)
- or
- NumRu::Lapack.dsytri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYTRI computes the inverse of a real symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* DSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by DSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytri2"></A>
- <H2>dsytri2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dsytri2( uplo, a, ipiv, lwork)
- or
- NumRu::Lapack.dsytri2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYTRI2 computes the inverse of a real symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace
-* before calling DSYTRI2X that actually computes the inverse.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by DSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NB structure of D
-* as determined by DSYTRF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* WORK is size >= (N+NB+1)*(NB+3)
-* If LDWORK = -1, then a workspace query is assumed; the routine
-* calculates:
-* - the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array,
-* - and no error message related to LDWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, LQUERY
- INTEGER MINSIZE, NBMAX
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DSYTRI2X
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytri2x"></A>
- <H2>dsytri2x</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dsytri2x( uplo, a, ipiv, nb)
- or
- NumRu::Lapack.dsytri2x # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )
-
-* Purpose
-* =======
-*
-* DSYTRI2X computes the inverse of a real symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* DSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the NNB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by DSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NNB structure of D
-* as determined by DSYTRF.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N+NNB+1,NNB+3)
-*
-* NB (input) INTEGER
-* Block size
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytrs"></A>
- <H2>dsytrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dsytrs( uplo, a, ipiv, b)
- or
- NumRu::Lapack.dsytrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DSYTRS solves a system of linear equations A*X = B with a real
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by DSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by DSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dsytrs2"></A>
- <H2>dsytrs2</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dsytrs2( uplo, a, ipiv, b)
- or
- NumRu::Lapack.dsytrs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DSYTRS2 solves a system of linear equations A*X = B with a real
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by DSYTRF and converted by DSYCONV.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by DSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dtb.html b/doc/dtb.html
deleted file mode 100644
index cd97c04..0000000
--- a/doc/dtb.html
+++ /dev/null
@@ -1,292 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for triangular band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for triangular band matrix</H1>
- <UL>
- <LI><A HREF="#dtbcon">dtbcon</A> : </LI>
- <LI><A HREF="#dtbrfs">dtbrfs</A> : </LI>
- <LI><A HREF="#dtbtrs">dtbtrs</A> : </LI>
- </UL>
-
- <A NAME="dtbcon"></A>
- <H2>dtbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dtbcon( norm, uplo, diag, kd, ab)
- or
- NumRu::Lapack.dtbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTBCON estimates the reciprocal of the condition number of a
-* triangular band matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtbrfs"></A>
- <H2>dtbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.dtbrfs( uplo, trans, diag, kd, ab, b, x)
- or
- NumRu::Lapack.dtbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTBRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular band
-* coefficient matrix.
-*
-* The solution matrix X must be computed by DTBTRS or some other
-* means before entering this routine. DTBRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtbtrs"></A>
- <H2>dtbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dtbtrs( uplo, trans, diag, kd, ab, b)
- or
- NumRu::Lapack.dtbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DTBTRS solves a triangular system of the form
-*
-* A * X = B or A**T * X = B,
-*
-* where A is a triangular band matrix of order N, and B is an
-* N-by NRHS matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of AB. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dtg.html b/doc/dtg.html
deleted file mode 100644
index 2a070f8..0000000
--- a/doc/dtg.html
+++ /dev/null
@@ -1,1753 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</H1>
- <UL>
- <LI><A HREF="#dtgevc">dtgevc</A> : </LI>
- <LI><A HREF="#dtgex2">dtgex2</A> : </LI>
- <LI><A HREF="#dtgexc">dtgexc</A> : </LI>
- <LI><A HREF="#dtgsen">dtgsen</A> : </LI>
- <LI><A HREF="#dtgsja">dtgsja</A> : </LI>
- <LI><A HREF="#dtgsna">dtgsna</A> : </LI>
- <LI><A HREF="#dtgsy2">dtgsy2</A> : </LI>
- <LI><A HREF="#dtgsyl">dtgsyl</A> : </LI>
- </UL>
-
- <A NAME="dtgevc"></A>
- <H2>dtgevc</H2>
-
- <PRE>
-USAGE:
- m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr)
- or
- NumRu::Lapack.dtgevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DTGEVC computes some or all of the right and/or left eigenvectors of
-* a pair of real matrices (S,P), where S is a quasi-triangular matrix
-* and P is upper triangular. Matrix pairs of this type are produced by
-* the generalized Schur factorization of a matrix pair (A,B):
-*
-* A = Q*S*Z**T, B = Q*P*Z**T
-*
-* as computed by DGGHRD + DHGEQZ.
-*
-* The right eigenvector x and the left eigenvector y of (S,P)
-* corresponding to an eigenvalue w are defined by:
-*
-* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
-*
-* where y**H denotes the conjugate tranpose of y.
-* The eigenvalues are not input to this routine, but are computed
-* directly from the diagonal blocks of S and P.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
-* where Z and Q are input matrices.
-* If Q and Z are the orthogonal factors from the generalized Schur
-* factorization of a matrix pair (A,B), then Z*X and Q*Y
-* are the matrices of right and left eigenvectors of (A,B).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed by the matrices in VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* specified by the logical array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY='S', SELECT specifies the eigenvectors to be
-* computed. If w(j) is a real eigenvalue, the corresponding
-* real eigenvector is computed if SELECT(j) is .TRUE..
-* If w(j) and w(j+1) are the real and imaginary parts of a
-* complex eigenvalue, the corresponding complex eigenvector
-* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
-* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
-* set to .FALSE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrices S and P. N >= 0.
-*
-* S (input) DOUBLE PRECISION array, dimension (LDS,N)
-* The upper quasi-triangular matrix S from a generalized Schur
-* factorization, as computed by DHGEQZ.
-*
-* LDS (input) INTEGER
-* The leading dimension of array S. LDS >= max(1,N).
-*
-* P (input) DOUBLE PRECISION array, dimension (LDP,N)
-* The upper triangular matrix P from a generalized Schur
-* factorization, as computed by DHGEQZ.
-* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
-* of S must be in positive diagonal form.
-*
-* LDP (input) INTEGER
-* The leading dimension of array P. LDP >= max(1,N).
-*
-* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the orthogonal matrix Q
-* of left Schur vectors returned by DHGEQZ).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
-* SELECT, stored consecutively in the columns of
-* VL, in the same order as their eigenvalues.
-*
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part, and the second the imaginary part.
-*
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'B', LDVL >= N.
-*
-* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Z (usually the orthogonal matrix Z
-* of right Schur vectors returned by DHGEQZ).
-*
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
-* if HOWMNY = 'B' or 'b', the matrix Z*X;
-* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
-* specified by SELECT, stored consecutively in the
-* columns of VR, in the same order as their
-* eigenvalues.
-*
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part and the second the imaginary part.
-*
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B', LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
-* is set to N. Each selected real eigenvector occupies one
-* column and each selected complex eigenvector occupies two
-* columns.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
-* eigenvalue.
-*
-
-* Further Details
-* ===============
-*
-* Allocation of workspace:
-* ---------- -- ---------
-*
-* WORK( j ) = 1-norm of j-th column of A, above the diagonal
-* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
-* WORK( 2*N+1:3*N ) = real part of eigenvector
-* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
-* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
-* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
-*
-* Rowwise vs. columnwise solution methods:
-* ------- -- ---------- -------- -------
-*
-* Finding a generalized eigenvector consists basically of solving the
-* singular triangular system
-*
-* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
-*
-* Consider finding the i-th right eigenvector (assume all eigenvalues
-* are real). The equation to be solved is:
-* n i
-* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
-* k=j k=j
-*
-* where C = (A - w B) (The components v(i+1:n) are 0.)
-*
-* The "rowwise" method is:
-*
-* (1) v(i) := 1
-* for j = i-1,. . .,1:
-* i
-* (2) compute s = - sum C(j,k) v(k) and
-* k=j+1
-*
-* (3) v(j) := s / C(j,j)
-*
-* Step 2 is sometimes called the "dot product" step, since it is an
-* inner product between the j-th row and the portion of the eigenvector
-* that has been computed so far.
-*
-* The "columnwise" method consists basically in doing the sums
-* for all the rows in parallel. As each v(j) is computed, the
-* contribution of v(j) times the j-th column of C is added to the
-* partial sums. Since FORTRAN arrays are stored columnwise, this has
-* the advantage that at each step, the elements of C that are accessed
-* are adjacent to one another, whereas with the rowwise method, the
-* elements accessed at a step are spaced LDS (and LDP) words apart.
-*
-* When finding left eigenvectors, the matrix in question is the
-* transpose of the one in storage, so the rowwise method then
-* actually accesses columns of A and B at each step, and so is the
-* preferred method.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtgex2"></A>
- <H2>dtgex2</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2)
- or
- NumRu::Lapack.dtgex2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
-* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
-* (A, B) by an orthogonal equivalence transformation.
-*
-* (A, B) must be in generalized real Schur canonical form (as returned
-* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
-* diagonal blocks. B is upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimensions (LDA,N)
-* On entry, the matrix A in the pair (A, B).
-* On exit, the updated matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimensions (LDB,N)
-* On entry, the matrix B in the pair (A, B).
-* On exit, the updated matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
-* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
-* On exit, the updated matrix Q.
-* Not referenced if WANTQ = .FALSE..
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
-* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
-* On exit, the updated matrix Z.
-* Not referenced if WANTZ = .FALSE..
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* J1 (input) INTEGER
-* The index to the first block (A11, B11). 1 <= J1 <= N.
-*
-* N1 (input) INTEGER
-* The order of the first block (A11, B11). N1 = 0, 1 or 2.
-*
-* N2 (input) INTEGER
-* The order of the second block (A22, B22). N2 = 0, 1 or 2.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )
-*
-* INFO (output) INTEGER
-* =0: Successful exit
-* >0: If INFO = 1, the transformed matrix (A, B) would be
-* too far from generalized Schur form; the blocks are
-* not swapped and (A, B) and (Q, Z) are unchanged.
-* The problem of swapping is too ill-conditioned.
-* <0: If INFO = -16: LWORK is too small. Appropriate value
-* for LWORK is returned in WORK(1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* In the current code both weak and strong stability tests are
-* performed. The user can omit the strong stability test by changing
-* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
-* details.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software,
-* Report UMINF - 94.04, Department of Computing Science, Umea
-* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
-* Note 87. To appear in Numerical Algorithms, 1996.
-*
-* =====================================================================
-* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO
-* loops. Sven Hammarling, 1/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtgexc"></A>
- <H2>dtgexc</H2>
-
- <PRE>
-USAGE:
- work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, lwork)
- or
- NumRu::Lapack.dtgexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTGEXC reorders the generalized real Schur decomposition of a real
-* matrix pair (A,B) using an orthogonal equivalence transformation
-*
-* (A, B) = Q * (A, B) * Z',
-*
-* so that the diagonal block of (A, B) with row index IFST is moved
-* to row ILST.
-*
-* (A, B) must be in generalized real Schur canonical form (as returned
-* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
-* diagonal blocks. B is upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the matrix A in generalized real Schur canonical
-* form.
-* On exit, the updated matrix A, again in generalized
-* real Schur canonical form.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
-* On entry, the matrix B in generalized real Schur canonical
-* form (A,B).
-* On exit, the updated matrix B, again in generalized
-* real Schur canonical form (A,B).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
-* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
-* On exit, the updated matrix Q.
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
-* On exit, the updated matrix Z.
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* IFST (input/output) INTEGER
-* ILST (input/output) INTEGER
-* Specify the reordering of the diagonal blocks of (A, B).
-* The block with row index IFST is moved to row ILST, by a
-* sequence of swapping between adjacent blocks.
-* On exit, if IFST pointed on entry to the second row of
-* a 2-by-2 block, it is changed to point to the first row;
-* ILST always points to the first row of the block in its
-* final position (which may differ from its input value by
-* +1 or -1). 1 <= IFST, ILST <= N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* =0: successful exit.
-* <0: if INFO = -i, the i-th argument had an illegal value.
-* =1: The transformed matrix pair (A, B) would be too far
-* from generalized Schur form; the problem is ill-
-* conditioned. (A, B) may have been partially reordered,
-* and ILST points to the first row of the current
-* position of the block being moved.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtgsen"></A>
- <H2>dtgsen</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.dtgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)
- or
- NumRu::Lapack.dtgsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTGSEN reorders the generalized real Schur decomposition of a real
-* matrix pair (A, B) (in terms of an orthonormal equivalence trans-
-* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
-* appears in the leading diagonal blocks of the upper quasi-triangular
-* matrix A and the upper triangular B. The leading columns of Q and
-* Z form orthonormal bases of the corresponding left and right eigen-
-* spaces (deflating subspaces). (A, B) must be in generalized real
-* Schur canonical form (as returned by DGGES), i.e. A is block upper
-* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
-* triangular.
-*
-* DTGSEN also computes the generalized eigenvalues
-*
-* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
-*
-* of the reordered matrix pair (A, B).
-*
-* Optionally, DTGSEN computes the estimates of reciprocal condition
-* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
-* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
-* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
-* the selected cluster and the eigenvalues outside the cluster, resp.,
-* and norms of "projections" onto left and right eigenspaces w.r.t.
-* the selected cluster in the (1,1)-block.
-*
-
-* Arguments
-* =========
-*
-* IJOB (input) INTEGER
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (PL and PR) or the deflating subspaces
-* (Difu and Difl):
-* =0: Only reorder w.r.t. SELECT. No extras.
-* =1: Reciprocal of norms of "projections" onto left and right
-* eigenspaces w.r.t. the selected cluster (PL and PR).
-* =2: Upper bounds on Difu and Difl. F-norm-based estimate
-* (DIF(1:2)).
-* =3: Estimate of Difu and Difl. 1-norm-based estimate
-* (DIF(1:2)).
-* About 5 times as expensive as IJOB = 2.
-* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
-* version to get it all.
-* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster.
-* To select a real eigenvalue w(j), SELECT(j) must be set to
-* .TRUE.. To select a complex conjugate pair of eigenvalues
-* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
-* either SELECT(j) or SELECT(j+1) or both must be set to
-* .TRUE.; a complex conjugate pair of eigenvalues must be
-* either both included in the cluster or both excluded.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension(LDA,N)
-* On entry, the upper quasi-triangular matrix A, with (A, B) in
-* generalized real Schur canonical form.
-* On exit, A is overwritten by the reordered matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension(LDB,N)
-* On entry, the upper triangular matrix B, with (A, B) in
-* generalized real Schur canonical form.
-* On exit, B is overwritten by the reordered matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
-* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
-* and BETA(j),j=1,...,N are the diagonals of the complex Schur
-* form (S,T) that would result if the 2-by-2 diagonal blocks of
-* the real generalized Schur form of (A,B) were further reduced
-* to triangular form using complex unitary transformations.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) negative.
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
-* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
-* On exit, Q has been postmultiplied by the left orthogonal
-* transformation matrix which reorder (A, B); The leading M
-* columns of Q form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1;
-* and if WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
-* On exit, Z has been postmultiplied by the left orthogonal
-* transformation matrix which reorder (A, B); The leading M
-* columns of Z form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1;
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* M (output) INTEGER
-* The dimension of the specified pair of left and right eigen-
-* spaces (deflating subspaces). 0 <= M <= N.
-*
-* PL (output) DOUBLE PRECISION
-* PR (output) DOUBLE PRECISION
-* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
-* reciprocal of the norm of "projections" onto left and right
-* eigenspaces with respect to the selected cluster.
-* 0 < PL, PR <= 1.
-* If M = 0 or M = N, PL = PR = 1.
-* If IJOB = 0, 2 or 3, PL and PR are not referenced.
-*
-* DIF (output) DOUBLE PRECISION array, dimension (2).
-* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
-* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
-* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
-* estimates of Difu and Difl.
-* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
-* If IJOB = 0 or 1, DIF is not referenced.
-*
-* WORK (workspace/output) DOUBLE PRECISION array,
-* dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 4*N+16.
-* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
-* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= 1.
-* If IJOB = 1, 2 or 4, LIWORK >= N+6.
-* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* =1: Reordering of (A, B) failed because the transformed
-* matrix pair (A, B) would be too far from generalized
-* Schur form; the problem is very ill-conditioned.
-* (A, B) may have been partially reordered.
-* If requested, 0 is returned in DIF(*), PL and PR.
-*
-
-* Further Details
-* ===============
-*
-* DTGSEN first collects the selected eigenvalues by computing
-* orthogonal U and W that move them to the top left corner of (A, B).
-* In other words, the selected eigenvalues are the eigenvalues of
-* (A11, B11) in:
-*
-* U'*(A, B)*W = (A11 A12) (B11 B12) n1
-* ( 0 A22),( 0 B22) n2
-* n1 n2 n1 n2
-*
-* where N = n1+n2 and U' means the transpose of U. The first n1 columns
-* of U and W span the specified pair of left and right eigenspaces
-* (deflating subspaces) of (A, B).
-*
-* If (A, B) has been obtained from the generalized real Schur
-* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
-* reordered generalized real Schur form of (C, D) is given by
-*
-* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
-*
-* and the first n1 columns of Q*U and Z*W span the corresponding
-* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
-*
-* Note that if the selected eigenvalue is sufficiently ill-conditioned,
-* then its value may differ significantly from its value before
-* reordering.
-*
-* The reciprocal condition numbers of the left and right eigenspaces
-* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
-* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
-*
-* The Difu and Difl are defined as:
-*
-* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
-* and
-* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
-*
-* where sigma-min(Zu) is the smallest singular value of the
-* (2*n1*n2)-by-(2*n1*n2) matrix
-*
-* Zu = [ kron(In2, A11) -kron(A22', In1) ]
-* [ kron(In2, B11) -kron(B22', In1) ].
-*
-* Here, Inx is the identity matrix of size nx and A22' is the
-* transpose of A22. kron(X, Y) is the Kronecker product between
-* the matrices X and Y.
-*
-* When DIF(2) is small, small changes in (A, B) can cause large changes
-* in the deflating subspace. An approximate (asymptotic) bound on the
-* maximum angular error in the computed deflating subspaces is
-*
-* EPS * norm((A, B)) / DIF(2),
-*
-* where EPS is the machine precision.
-*
-* The reciprocal norm of the projectors on the left and right
-* eigenspaces associated with (A11, B11) may be returned in PL and PR.
-* They are computed as follows. First we compute L and R so that
-* P*(A, B)*Q is block diagonal, where
-*
-* P = ( I -L ) n1 Q = ( I R ) n1
-* ( 0 I ) n2 and ( 0 I ) n2
-* n1 n2 n1 n2
-*
-* and (L, R) is the solution to the generalized Sylvester equation
-*
-* A11*R - L*A22 = -A12
-* B11*R - L*B22 = -B12
-*
-* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
-* An approximate (asymptotic) bound on the average absolute error of
-* the selected eigenvalues is
-*
-* EPS * norm((A, B)) / PL.
-*
-* There are also global error bounds which valid for perturbations up
-* to a certain restriction: A lower bound (x) on the smallest
-* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
-* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
-* (i.e. (A + E, B + F), is
-*
-* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
-*
-* An approximate bound on x can be computed from DIF(1:2), PL and PR.
-*
-* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
-* (L', R') and unperturbed (L, R) left and right deflating subspaces
-* associated with the selected cluster in the (1,1)-blocks can be
-* bounded as
-*
-* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
-* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
-*
-* See LAPACK User's Guide section 4.11 or the following references
-* for more information.
-*
-* Note that if the default method for computing the Frobenius-norm-
-* based estimate DIF is not wanted (see DLATDF), then the parameter
-* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF
-* (IJOB = 2 will be used)). See DTGSYL for more details.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software,
-* Report UMINF - 94.04, Department of Computing Science, Umea
-* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
-* Note 87. To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
-* 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtgsja"></A>
- <H2>dtgsja</H2>
-
- <PRE>
-USAGE:
- alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.dtgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)
- or
- NumRu::Lapack.dtgsja # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )
-
-* Purpose
-* =======
-*
-* DTGSJA computes the generalized singular value decomposition (GSVD)
-* of two real upper triangular (or trapezoidal) matrices A and B.
-*
-* On entry, it is assumed that matrices A and B have the following
-* forms, which may be obtained by the preprocessing subroutine DGGSVP
-* from a general M-by-N matrix A and P-by-N matrix B:
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* B = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal.
-*
-* On exit,
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
-*
-* where U, V and Q are orthogonal matrices, Z' denotes the transpose
-* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
-* ``diagonal'' matrices, which are of the following structures:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 ) K
-* L ( 0 0 R22 ) L
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The computation of the orthogonal transformation matrices U, V or Q
-* is optional. These matrices may either be formed explicitly, or they
-* may be postmultiplied into input matrices U1, V1, or Q1.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': U must contain an orthogonal matrix U1 on entry, and
-* the product U1*U is returned;
-* = 'I': U is initialized to the unit matrix, and the
-* orthogonal matrix U is returned;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': V must contain an orthogonal matrix V1 on entry, and
-* the product V1*V is returned;
-* = 'I': V is initialized to the unit matrix, and the
-* orthogonal matrix V is returned;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and
-* the product Q1*Q is returned;
-* = 'I': Q is initialized to the unit matrix, and the
-* orthogonal matrix Q is returned;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* K (input) INTEGER
-* L (input) INTEGER
-* K and L specify the subblocks in the input matrices A and B:
-* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
-* of A and B, whose GSVD is going to be computed by DTGSJA.
-* See Further Details.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
-* matrix R or part of R. See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
-* a part of R. See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) DOUBLE PRECISION
-* TOLB (input) DOUBLE PRECISION
-* TOLA and TOLB are the convergence criteria for the Jacobi-
-* Kogbetliantz iteration procedure. Generally, they are the
-* same as used in the preprocessing step, say
-* TOLA = max(M,N)*norm(A)*MAZHEPS,
-* TOLB = max(P,N)*norm(B)*MAZHEPS.
-*
-* ALPHA (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = diag(C),
-* BETA(K+1:K+L) = diag(S),
-* or if M-K-L < 0,
-* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
-* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
-* Furthermore, if K+L < N,
-* ALPHA(K+L+1:N) = 0 and
-* BETA(K+L+1:N) = 0.
-*
-* U (input/output) DOUBLE PRECISION array, dimension (LDU,M)
-* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
-* the orthogonal matrix returned by DGGSVP).
-* On exit,
-* if JOBU = 'I', U contains the orthogonal matrix U;
-* if JOBU = 'U', U contains the product U1*U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (input/output) DOUBLE PRECISION array, dimension (LDV,P)
-* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
-* the orthogonal matrix returned by DGGSVP).
-* On exit,
-* if JOBV = 'I', V contains the orthogonal matrix V;
-* if JOBV = 'V', V contains the product V1*V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
-* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
-* the orthogonal matrix returned by DGGSVP).
-* On exit,
-* if JOBQ = 'I', Q contains the orthogonal matrix Q;
-* if JOBQ = 'Q', Q contains the product Q1*Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* NCYCLE (output) INTEGER
-* The number of cycles required for convergence.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the procedure does not converge after MAXIT cycles.
-*
-* Internal Parameters
-* ===================
-*
-* MAXIT INTEGER
-* MAXIT specifies the total loops that the iterative procedure
-* may take. If after MAXIT cycles, the routine fails to
-* converge, we return INFO = 1.
-*
-
-* Further Details
-* ===============
-*
-* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
-* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
-* matrix B13 to the form:
-*
-* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
-*
-* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
-* of Z. C1 and S1 are diagonal matrices satisfying
-*
-* C1**2 + S1**2 = I,
-*
-* and R1 is an L-by-L nonsingular upper triangular matrix.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtgsna"></A>
- <H2>dtgsna</H2>
-
- <PRE>
-USAGE:
- s, dif, m, work, info = NumRu::Lapack.dtgsna( job, howmny, select, a, b, vl, vr, lwork)
- or
- NumRu::Lapack.dtgsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTGSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or eigenvectors of a matrix pair (A, B) in
-* generalized real Schur canonical form (or of any matrix pair
-* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
-* Z' denotes the transpose of Z.
-*
-* (A, B) must be in generalized real Schur form (as returned by DGGES),
-* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
-* blocks. B is upper triangular.
-*
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (DIF):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (DIF);
-* = 'B': for both eigenvalues and eigenvectors (S and DIF).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the eigenpair corresponding to a real eigenvalue w(j),
-* SELECT(j) must be set to .TRUE.. To select condition numbers
-* corresponding to a complex conjugate pair of eigenvalues w(j)
-* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
-* set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the square matrix pair (A, B). N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The upper quasi-triangular matrix A in the pair (A,B).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,N)
-* The upper triangular matrix B in the pair (A,B).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
-* If JOB = 'E' or 'B', VL must contain left eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns of VL, as returned by DTGEVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1.
-* If JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
-* If JOB = 'E' or 'B', VR must contain right eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns ov VR, as returned by DTGEVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1.
-* If JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array. For a complex conjugate pair of eigenvalues two
-* consecutive elements of S are set to the same value. Thus
-* S(j), DIF(j), and the j-th columns of VL and VR all
-* correspond to the same eigenpair (but not in general the
-* j-th eigenpair, unless all eigenpairs are selected).
-* If JOB = 'V', S is not referenced.
-*
-* DIF (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array. For a complex eigenvector two
-* consecutive elements of DIF are set to the same value. If
-* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
-* is set to 0; this can only occur when the true value would be
-* very small anyway.
-* If JOB = 'E', DIF is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S and DIF. MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and DIF used to store
-* the specified condition numbers; for each selected real
-* eigenvalue one element is used, and for each selected complex
-* conjugate pair of eigenvalues, two elements are used.
-* If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (N + 6)
-* If JOB = 'E', IWORK is not referenced.
-*
-* INFO (output) INTEGER
-* =0: Successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value
-*
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of a generalized eigenvalue
-* w = (a, b) is defined as
-*
-* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
-*
-* where u and v are the left and right eigenvectors of (A, B)
-* corresponding to w; |z| denotes the absolute value of the complex
-* number, and norm(u) denotes the 2-norm of the vector u.
-* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
-* of the matrix pair (A, B). If both a and b equal zero, then (A B) is
-* singular and S(I) = -1 is returned.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(A, B) / S(I)
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number DIF(i) of right eigenvector u
-* and left eigenvector v corresponding to the generalized eigenvalue w
-* is defined as follows:
-*
-* a) If the i-th eigenvalue w = (a,b) is real
-*
-* Suppose U and V are orthogonal transformations such that
-*
-* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1
-* ( 0 S22 ),( 0 T22 ) n-1
-* 1 n-1 1 n-1
-*
-* Then the reciprocal condition number DIF(i) is
-*
-* Difl((a, b), (S22, T22)) = sigma-min( Zl ),
-*
-* where sigma-min(Zl) denotes the smallest singular value of the
-* 2(n-1)-by-2(n-1) matrix
-*
-* Zl = [ kron(a, In-1) -kron(1, S22) ]
-* [ kron(b, In-1) -kron(1, T22) ] .
-*
-* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
-* Kronecker product between the matrices X and Y.
-*
-* Note that if the default method for computing DIF(i) is wanted
-* (see DLATDF), then the parameter DIFDRI (see below) should be
-* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).
-* See DTGSYL for more details.
-*
-* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
-*
-* Suppose U and V are orthogonal transformations such that
-*
-* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2
-* ( 0 S22 ),( 0 T22) n-2
-* 2 n-2 2 n-2
-*
-* and (S11, T11) corresponds to the complex conjugate eigenvalue
-* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
-* that
-*
-* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )
-* ( 0 s22 ) ( 0 t22 )
-*
-* where the generalized eigenvalues w = s11/t11 and
-* conjg(w) = s22/t22.
-*
-* Then the reciprocal condition number DIF(i) is bounded by
-*
-* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
-*
-* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
-* Z1 is the complex 2-by-2 matrix
-*
-* Z1 = [ s11 -s22 ]
-* [ t11 -t22 ],
-*
-* This is done by computing (using real arithmetic) the
-* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
-* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
-* the determinant of X.
-*
-* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
-* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
-*
-* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]
-* [ kron(T11', In-2) -kron(I2, T22) ]
-*
-* Note that if the default method for computing DIF is wanted (see
-* DLATDF), then the parameter DIFDRI (see below) should be changed
-* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL
-* for more details.
-*
-* For each eigenvalue/vector specified by SELECT, DIF stores a
-* Frobenius norm-based estimate of Difl.
-*
-* An approximate error bound for the i-th computed eigenvector VL(i) or
-* VR(i) is given by
-*
-* EPS * norm(A, B) / DIF(i).
-*
-* See ref. [2-3] for more details and further references.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software,
-* Report UMINF - 94.04, Department of Computing Science, Umea
-* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
-* Note 87. To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
-* No 1, 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtgsy2"></A>
- <H2>dtgsy2</H2>
-
- <PRE>
-USAGE:
- scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.dtgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)
- or
- NumRu::Lapack.dtgsy2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )
-
-* Purpose
-* =======
-*
-* DTGSY2 solves the generalized Sylvester equation:
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F,
-*
-* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
-* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
-* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
-* must be in generalized Schur canonical form, i.e. A, B are upper
-* quasi triangular and D, E are upper triangular. The solution (R, L)
-* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
-* chosen to avoid overflow.
-*
-* In matrix notation solving equation (1) corresponds to solve
-* Z*x = scale*b, where Z is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ],
-*
-* Ik is the identity matrix of size k and X' is the transpose of X.
-* kron(X, Y) is the Kronecker product between the matrices X and Y.
-* In the process of solving (1), we solve a number of such systems
-* where Dim(In), Dim(In) = 1 or 2.
-*
-* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
-* which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * -F
-*
-* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
-* sigma_min(Z) using reverse communicaton with DLACON.
-*
-* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL
-* of an upper bound on the separation between to matrix pairs. Then
-* the input (A, D), (B, E) are sub-pencils of the matrix pair in
-* DTGSYL. See DTGSYL for details.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N', solve the generalized Sylvester equation (1).
-* = 'T': solve the 'transposed' system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* = 0: solve (1) only.
-* = 1: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (look ahead strategy is used).
-* = 2: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (DGECON on sub-systems is used.)
-* Not referenced if TRANS = 'T'.
-*
-* M (input) INTEGER
-* On entry, M specifies the order of A and D, and the row
-* dimension of C, F, R and L.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of B and E, and the column
-* dimension of C, F, R and L.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA, M)
-* On entry, A contains an upper quasi triangular matrix.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1, M).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB, N)
-* On entry, B contains an upper quasi triangular matrix.
-*
-* LDB (input) INTEGER
-* The leading dimension of the matrix B. LDB >= max(1, N).
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1).
-* On exit, if IJOB = 0, C has been overwritten by the
-* solution R.
-*
-* LDC (input) INTEGER
-* The leading dimension of the matrix C. LDC >= max(1, M).
-*
-* D (input) DOUBLE PRECISION array, dimension (LDD, M)
-* On entry, D contains an upper triangular matrix.
-*
-* LDD (input) INTEGER
-* The leading dimension of the matrix D. LDD >= max(1, M).
-*
-* E (input) DOUBLE PRECISION array, dimension (LDE, N)
-* On entry, E contains an upper triangular matrix.
-*
-* LDE (input) INTEGER
-* The leading dimension of the matrix E. LDE >= max(1, N).
-*
-* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1).
-* On exit, if IJOB = 0, F has been overwritten by the
-* solution L.
-*
-* LDF (input) INTEGER
-* The leading dimension of the matrix F. LDF >= max(1, M).
-*
-* SCALE (output) DOUBLE PRECISION
-* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
-* R and L (C and F on entry) will hold the solutions to a
-* slightly perturbed system but the input matrices A, B, D and
-* E have not been changed. If SCALE = 0, R and L will hold the
-* solutions to the homogeneous system with C = F = 0. Normally,
-* SCALE = 1.
-*
-* RDSUM (input/output) DOUBLE PRECISION
-* On entry, the sum of squares of computed contributions to
-* the Dif-estimate under computation by DTGSYL, where the
-* scaling factor RDSCAL (see below) has been factored out.
-* On exit, the corresponding sum of squares updated with the
-* contributions from the current sub-system.
-* If TRANS = 'T' RDSUM is not touched.
-* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.
-*
-* RDSCAL (input/output) DOUBLE PRECISION
-* On entry, scaling factor used to prevent overflow in RDSUM.
-* On exit, RDSCAL is updated w.r.t. the current contributions
-* in RDSUM.
-* If TRANS = 'T', RDSCAL is not touched.
-* NOTE: RDSCAL only makes sense when DTGSY2 is called by
-* DTGSYL.
-*
-* IWORK (workspace) INTEGER array, dimension (M+N+2)
-*
-* PQ (output) INTEGER
-* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
-* 8-by-8) solved by this routine.
-*
-* INFO (output) INTEGER
-* On exit, if INFO is set to
-* =0: Successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* >0: The matrix pairs (A, D) and (B, E) have common or very
-* close eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-* Replaced various illegal calls to DCOPY by calls to DLASET.
-* Sven Hammarling, 27/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtgsyl"></A>
- <H2>dtgsyl</H2>
-
- <PRE>
-USAGE:
- scale, dif, work, info, c, f = NumRu::Lapack.dtgsyl( trans, ijob, a, b, c, d, e, f, lwork)
- or
- NumRu::Lapack.dtgsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTGSYL solves the generalized Sylvester equation:
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F
-*
-* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
-* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
-* respectively, with real entries. (A, D) and (B, E) must be in
-* generalized (real) Schur canonical form, i.e. A, B are upper quasi
-* triangular and D, E are upper triangular.
-*
-* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
-* scaling factor chosen to avoid overflow.
-*
-* In matrix notation (1) is equivalent to solve Zx = scale b, where
-* Z is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ].
-*
-* Here Ik is the identity matrix of size k and X' is the transpose of
-* X. kron(X, Y) is the Kronecker product between the matrices X and Y.
-*
-* If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b,
-* which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * (-F)
-*
-* This case (TRANS = 'T') is used to compute an one-norm-based estimate
-* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
-* and (B,E), using DLACON.
-*
-* If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate
-* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
-* reciprocal of the smallest singular value of Z. See [1-2] for more
-* information.
-*
-* This is a level 3 BLAS algorithm.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N', solve the generalized Sylvester equation (1).
-* = 'T', solve the 'transposed' system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* =0: solve (1) only.
-* =1: The functionality of 0 and 3.
-* =2: The functionality of 0 and 4.
-* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* (look ahead strategy IJOB = 1 is used).
-* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* ( DGECON on sub-systems is used ).
-* Not referenced if TRANS = 'T'.
-*
-* M (input) INTEGER
-* The order of the matrices A and D, and the row dimension of
-* the matrices C, F, R and L.
-*
-* N (input) INTEGER
-* The order of the matrices B and E, and the column dimension
-* of the matrices C, F, R and L.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA, M)
-* The upper quasi triangular matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, M).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB, N)
-* The upper quasi triangular matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1, N).
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
-* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1, M).
-*
-* D (input) DOUBLE PRECISION array, dimension (LDD, M)
-* The upper triangular matrix D.
-*
-* LDD (input) INTEGER
-* The leading dimension of the array D. LDD >= max(1, M).
-*
-* E (input) DOUBLE PRECISION array, dimension (LDE, N)
-* The upper triangular matrix E.
-*
-* LDE (input) INTEGER
-* The leading dimension of the array E. LDE >= max(1, N).
-*
-* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
-* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDF (input) INTEGER
-* The leading dimension of the array F. LDF >= max(1, M).
-*
-* DIF (output) DOUBLE PRECISION
-* On exit DIF is the reciprocal of a lower bound of the
-* reciprocal of the Dif-function, i.e. DIF is an upper bound of
-* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
-* IF IJOB = 0 or TRANS = 'T', DIF is not touched.
-*
-* SCALE (output) DOUBLE PRECISION
-* On exit SCALE is the scaling factor in (1) or (3).
-* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
-* to a slightly perturbed system but the input matrices A, B, D
-* and E have not been changed. If SCALE = 0, C and F hold the
-* solutions R and L, respectively, to the homogeneous system
-* with C = F = 0. Normally, SCALE = 1.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK > = 1.
-* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M+N+6)
-*
-* INFO (output) INTEGER
-* =0: successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* >0: (A, D) and (B, E) have common or close eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
-* No 1, 1996.
-*
-* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
-* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
-* Appl., 15(4):1045-1060, 1994
-*
-* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
-* Condition Estimators for Solving the Generalized Sylvester
-* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
-* July 1989, pp 745-751.
-*
-* =====================================================================
-* Replaced various illegal calls to DCOPY by calls to DLASET.
-* Sven Hammarling, 1/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dtp.html b/doc/dtp.html
deleted file mode 100644
index d76f52f..0000000
--- a/doc/dtp.html
+++ /dev/null
@@ -1,549 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for triangular, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for triangular, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#dtpcon">dtpcon</A> : </LI>
- <LI><A HREF="#dtprfs">dtprfs</A> : </LI>
- <LI><A HREF="#dtptri">dtptri</A> : </LI>
- <LI><A HREF="#dtptrs">dtptrs</A> : </LI>
- <LI><A HREF="#dtpttf">dtpttf</A> : </LI>
- <LI><A HREF="#dtpttr">dtpttr</A> : </LI>
- </UL>
-
- <A NAME="dtpcon"></A>
- <H2>dtpcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dtpcon( norm, uplo, diag, ap)
- or
- NumRu::Lapack.dtpcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTPCON estimates the reciprocal of the condition number of a packed
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtprfs"></A>
- <H2>dtprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.dtprfs( uplo, trans, diag, ap, b, x)
- or
- NumRu::Lapack.dtprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTPRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular packed
-* coefficient matrix.
-*
-* The solution matrix X must be computed by DTPTRS or some other
-* means before entering this routine. DTPRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtptri"></A>
- <H2>dtptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.dtptri( uplo, diag, n, ap)
- or
- NumRu::Lapack.dtptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* DTPTRI computes the inverse of a real upper or lower triangular
-* matrix A stored in packed format.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangular matrix A, stored
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same packed storage format.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* Further Details
-* ===============
-*
-* A triangular matrix A can be transferred to packed storage using one
-* of the following program segments:
-*
-* UPLO = 'U': UPLO = 'L':
-*
-* JC = 1 JC = 1
-* DO 2 J = 1, N DO 2 J = 1, N
-* DO 1 I = 1, J DO 1 I = J, N
-* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
-* 1 CONTINUE 1 CONTINUE
-* JC = JC + J JC = JC + N - J + 1
-* 2 CONTINUE 2 CONTINUE
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtptrs"></A>
- <H2>dtptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dtptrs( uplo, trans, diag, n, ap, b)
- or
- NumRu::Lapack.dtptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DTPTRS solves a triangular system of the form
-*
-* A * X = B or A**T * X = B,
-*
-* where A is a triangular matrix of order N stored in packed format,
-* and B is an N-by-NRHS matrix. A check is made to verify that A is
-* nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtpttf"></A>
- <H2>dtpttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.dtpttf( transr, uplo, n, ap)
- or
- NumRu::Lapack.dtpttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )
-
-* Purpose
-* =======
-*
-* DTPTTF copies a triangular matrix A from standard packed format (TP)
-* to rectangular full packed format (TF).
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal format is wanted;
-* = 'T': ARF in Conjugate-transpose format is wanted.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A stored in
-* RFP format. For a further discussion see Notes below.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Rectangular Full Packed (RFP) Format when N is
-* even. We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* the transpose of the first three columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* the transpose of the last three columns of AP lower.
-* This covers the case N even and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 03 04 05 33 43 53
-* 13 14 15 00 44 54
-* 23 24 25 10 11 55
-* 33 34 35 20 21 22
-* 00 44 45 30 31 32
-* 01 11 55 40 41 42
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We then consider Rectangular Full Packed (RFP) Format when N is
-* odd. We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* the transpose of the first two columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* the transpose of the last two columns of AP lower.
-* This covers the case N odd and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 02 03 04 00 33 43
-* 12 13 14 10 11 44
-* 22 23 24 20 21 22
-* 00 33 34 30 31 32
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-* RFP A RFP A
-*
-* 02 12 22 00 01 00 10 20 30 40 50
-* 03 13 23 33 11 33 11 21 31 41 51
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtpttr"></A>
- <H2>dtpttr</H2>
-
- <PRE>
-USAGE:
- a, info = NumRu::Lapack.dtpttr( uplo, ap)
- or
- NumRu::Lapack.dtpttr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* DTPTTR copies a triangular matrix A from standard packed format (TP)
-* to standard full format (TR).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular.
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* A (output) DOUBLE PRECISION array, dimension ( LDA, N )
-* On exit, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dtr.html b/doc/dtr.html
deleted file mode 100644
index e9d7016..0000000
--- a/doc/dtr.html
+++ /dev/null
@@ -1,1381 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for triangular (or in some cases quasi-triangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for triangular (or in some cases quasi-triangular) matrix</H1>
- <UL>
- <LI><A HREF="#dtrcon">dtrcon</A> : </LI>
- <LI><A HREF="#dtrevc">dtrevc</A> : </LI>
- <LI><A HREF="#dtrexc">dtrexc</A> : </LI>
- <LI><A HREF="#dtrrfs">dtrrfs</A> : </LI>
- <LI><A HREF="#dtrsen">dtrsen</A> : </LI>
- <LI><A HREF="#dtrsna">dtrsna</A> : </LI>
- <LI><A HREF="#dtrsyl">dtrsyl</A> : </LI>
- <LI><A HREF="#dtrti2">dtrti2</A> : </LI>
- <LI><A HREF="#dtrtri">dtrtri</A> : </LI>
- <LI><A HREF="#dtrtrs">dtrtrs</A> : </LI>
- <LI><A HREF="#dtrttf">dtrttf</A> : </LI>
- <LI><A HREF="#dtrttp">dtrttp</A> : </LI>
- </UL>
-
- <A NAME="dtrcon"></A>
- <H2>dtrcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.dtrcon( norm, uplo, diag, a)
- or
- NumRu::Lapack.dtrcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTRCON estimates the reciprocal of the condition number of a
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrevc"></A>
- <H2>dtrevc</H2>
-
- <PRE>
-USAGE:
- m, info, select, vl, vr = NumRu::Lapack.dtrevc( side, howmny, select, t, vl, vr)
- or
- NumRu::Lapack.dtrevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DTREVC computes some or all of the right and/or left eigenvectors of
-* a real upper quasi-triangular matrix T.
-* Matrices of this type are produced by the Schur factorization of
-* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.
-*
-* The right eigenvector x and the left eigenvector y of T corresponding
-* to an eigenvalue w are defined by:
-*
-* T*x = w*x, (y**H)*T = w*(y**H)
-*
-* where y**H denotes the conjugate transpose of y.
-* The eigenvalues are not input to this routine, but are read directly
-* from the diagonal blocks of T.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
-* input matrix. If Q is the orthogonal factor that reduces a matrix
-* A to Schur form T, then Q*X and Q*Y are the matrices of right and
-* left eigenvectors of A.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed by the matrices in VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* as indicated by the logical array SELECT.
-*
-* SELECT (input/output) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
-* computed.
-* If w(j) is a real eigenvalue, the corresponding real
-* eigenvector is computed if SELECT(j) is .TRUE..
-* If w(j) and w(j+1) are the real and imaginary parts of a
-* complex eigenvalue, the corresponding complex eigenvector is
-* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
-* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
-* .FALSE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input) DOUBLE PRECISION array, dimension (LDT,N)
-* The upper quasi-triangular matrix T in Schur canonical form.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the orthogonal matrix Q
-* of Schur vectors returned by DHSEQR).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VL, in the same order as their
-* eigenvalues.
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part, and the second the imaginary part.
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'B', LDVL >= N.
-*
-* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Q (usually the orthogonal matrix Q
-* of Schur vectors returned by DHSEQR).
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*X;
-* if HOWMNY = 'S', the right eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VR, in the same order as their
-* eigenvalues.
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part and the second the imaginary part.
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B', LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors.
-* If HOWMNY = 'A' or 'B', M is set to N.
-* Each selected real eigenvector occupies one column and each
-* selected complex eigenvector occupies two columns.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The algorithm used in this program is basically backward (forward)
-* substitution, with scaling to make the the code robust against
-* possible overflow.
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x| + |y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrexc"></A>
- <H2>dtrexc</H2>
-
- <PRE>
-USAGE:
- info, t, q, ifst, ilst = NumRu::Lapack.dtrexc( compq, t, q, ifst, ilst)
- or
- NumRu::Lapack.dtrexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )
-
-* Purpose
-* =======
-*
-* DTREXC reorders the real Schur factorization of a real matrix
-* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
-* moved to row ILST.
-*
-* The real Schur form T is reordered by an orthogonal similarity
-* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
-* is updated by postmultiplying it with Z.
-*
-* T must be in Schur canonical form (as returned by DHSEQR), that is,
-* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
-* 2-by-2 diagonal block has its diagonal elements equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
-* On entry, the upper quasi-triangular matrix T, in Schur
-* Schur canonical form.
-* On exit, the reordered upper quasi-triangular matrix, again
-* in Schur canonical form.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* orthogonal transformation matrix Z which reorders T.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* IFST (input/output) INTEGER
-* ILST (input/output) INTEGER
-* Specify the reordering of the diagonal blocks of T.
-* The block with row index IFST is moved to row ILST, by a
-* sequence of transpositions between adjacent blocks.
-* On exit, if IFST pointed on entry to the second row of a
-* 2-by-2 block, it is changed to point to the first row; ILST
-* always points to the first row of the block in its final
-* position (which may differ from its input value by +1 or -1).
-* 1 <= IFST <= N; 1 <= ILST <= N.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: two adjacent blocks were too close to swap (the problem
-* is very ill-conditioned); T may have been partially
-* reordered, and ILST points to the first row of the
-* current position of the block being moved.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrrfs"></A>
- <H2>dtrrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.dtrrfs( uplo, trans, diag, a, b, x)
- or
- NumRu::Lapack.dtrrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTRRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular
-* coefficient matrix.
-*
-* The solution matrix X must be computed by DTRTRS or some other
-* means before entering this routine. DTRRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrsen"></A>
- <H2>dtrsen</H2>
-
- <PRE>
-USAGE:
- wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.dtrsen( job, compq, select, t, q, lwork, liwork)
- or
- NumRu::Lapack.dtrsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTRSEN reorders the real Schur factorization of a real matrix
-* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
-* the leading diagonal blocks of the upper quasi-triangular matrix T,
-* and the leading columns of Q form an orthonormal basis of the
-* corresponding right invariant subspace.
-*
-* Optionally the routine computes the reciprocal condition numbers of
-* the cluster of eigenvalues and/or the invariant subspace.
-*
-* T must be in Schur canonical form (as returned by DHSEQR), that is,
-* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
-* 2-by-2 diagonal block has its diagonal elemnts equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (S) or the invariant subspace (SEP):
-* = 'N': none;
-* = 'E': for eigenvalues only (S);
-* = 'V': for invariant subspace only (SEP);
-* = 'B': for both eigenvalues and invariant subspace (S and
-* SEP).
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster. To
-* select a real eigenvalue w(j), SELECT(j) must be set to
-* .TRUE.. To select a complex conjugate pair of eigenvalues
-* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
-* either SELECT(j) or SELECT(j+1) or both must be set to
-* .TRUE.; a complex conjugate pair of eigenvalues must be
-* either both included in the cluster or both excluded.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
-* On entry, the upper quasi-triangular matrix T, in Schur
-* canonical form.
-* On exit, T is overwritten by the reordered matrix T, again in
-* Schur canonical form, with the selected eigenvalues in the
-* leading diagonal blocks.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* orthogonal transformation matrix which reorders T; the
-* leading M columns of Q form an orthonormal basis for the
-* specified invariant subspace.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
-*
-* WR (output) DOUBLE PRECISION array, dimension (N)
-* WI (output) DOUBLE PRECISION array, dimension (N)
-* The real and imaginary parts, respectively, of the reordered
-* eigenvalues of T. The eigenvalues are stored in the same
-* order as on the diagonal of T, with WR(i) = T(i,i) and, if
-* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
-* WI(i+1) = -WI(i). Note that if a complex eigenvalue is
-* sufficiently ill-conditioned, then its value may differ
-* significantly from its value before reordering.
-*
-* M (output) INTEGER
-* The dimension of the specified invariant subspace.
-* 0 < = M <= N.
-*
-* S (output) DOUBLE PRECISION
-* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
-* condition number for the selected cluster of eigenvalues.
-* S cannot underestimate the true reciprocal condition number
-* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
-* If JOB = 'N' or 'V', S is not referenced.
-*
-* SEP (output) DOUBLE PRECISION
-* If JOB = 'V' or 'B', SEP is the estimated reciprocal
-* condition number of the specified invariant subspace. If
-* M = 0 or N, SEP = norm(T).
-* If JOB = 'N' or 'E', SEP is not referenced.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If JOB = 'N', LWORK >= max(1,N);
-* if JOB = 'E', LWORK >= max(1,M*(N-M));
-* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOB = 'N' or 'E', LIWORK >= 1;
-* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: reordering of T failed because some eigenvalues are too
-* close to separate (the problem is very ill-conditioned);
-* T may have been partially reordered, and WR and WI
-* contain the eigenvalues in the same order as in T; S and
-* SEP (if requested) are set to zero.
-*
-
-* Further Details
-* ===============
-*
-* DTRSEN first collects the selected eigenvalues by computing an
-* orthogonal transformation Z to move them to the top left corner of T.
-* In other words, the selected eigenvalues are the eigenvalues of T11
-* in:
-*
-* Z'*T*Z = ( T11 T12 ) n1
-* ( 0 T22 ) n2
-* n1 n2
-*
-* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
-* of Z span the specified invariant subspace of T.
-*
-* If T has been obtained from the real Schur factorization of a matrix
-* A = Q*T*Q', then the reordered real Schur factorization of A is given
-* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
-* the corresponding invariant subspace of A.
-*
-* The reciprocal condition number of the average of the eigenvalues of
-* T11 may be returned in S. S lies between 0 (very badly conditioned)
-* and 1 (very well conditioned). It is computed as follows. First we
-* compute R so that
-*
-* P = ( I R ) n1
-* ( 0 0 ) n2
-* n1 n2
-*
-* is the projector on the invariant subspace associated with T11.
-* R is the solution of the Sylvester equation:
-*
-* T11*R - R*T22 = T12.
-*
-* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
-* the two-norm of M. Then S is computed as the lower bound
-*
-* (1 + F-norm(R)**2)**(-1/2)
-*
-* on the reciprocal of 2-norm(P), the true reciprocal condition number.
-* S cannot underestimate 1 / 2-norm(P) by more than a factor of
-* sqrt(N).
-*
-* An approximate error bound for the computed average of the
-* eigenvalues of T11 is
-*
-* EPS * norm(T) / S
-*
-* where EPS is the machine precision.
-*
-* The reciprocal condition number of the right invariant subspace
-* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
-* SEP is defined as the separation of T11 and T22:
-*
-* sep( T11, T22 ) = sigma-min( C )
-*
-* where sigma-min(C) is the smallest singular value of the
-* n1*n2-by-n1*n2 matrix
-*
-* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
-*
-* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
-* product. We estimate sigma-min(C) by the reciprocal of an estimate of
-* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
-* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
-*
-* When SEP is small, small changes in T can cause large changes in
-* the invariant subspace. An approximate bound on the maximum angular
-* error in the computed right invariant subspace is
-*
-* EPS * norm(T) / SEP
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrsna"></A>
- <H2>dtrsna</H2>
-
- <PRE>
-USAGE:
- s, sep, m, info = NumRu::Lapack.dtrsna( job, howmny, select, t, vl, vr, ldwork)
- or
- NumRu::Lapack.dtrsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTRSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or right eigenvectors of a real upper
-* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
-* orthogonal).
-*
-* T must be in Schur canonical form (as returned by DHSEQR), that is,
-* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
-* 2-by-2 diagonal block has its diagonal elements equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (SEP):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (SEP);
-* = 'B': for both eigenvalues and eigenvectors (S and SEP).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the eigenpair corresponding to a real eigenvalue w(j),
-* SELECT(j) must be set to .TRUE.. To select condition numbers
-* corresponding to a complex conjugate pair of eigenvalues w(j)
-* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
-* set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input) DOUBLE PRECISION array, dimension (LDT,N)
-* The upper quasi-triangular matrix T, in Schur canonical form.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
-* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
-* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VL, as returned by
-* DHSEIN or DTREVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
-* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
-* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VR, as returned by
-* DHSEIN or DTREVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array. For a complex conjugate pair of eigenvalues two
-* consecutive elements of S are set to the same value. Thus
-* S(j), SEP(j), and the j-th columns of VL and VR all
-* correspond to the same eigenpair (but not in general the
-* j-th eigenpair, unless all eigenpairs are selected).
-* If JOB = 'V', S is not referenced.
-*
-* SEP (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array. For a complex eigenvector two
-* consecutive elements of SEP are set to the same value. If
-* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
-* is set to 0; this can only occur when the true value would be
-* very small anyway.
-* If JOB = 'E', SEP is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S (if JOB = 'E' or 'B')
-* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and/or SEP actually
-* used to store the estimated condition numbers.
-* If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)
-* If JOB = 'E', WORK is not referenced.
-*
-* LDWORK (input) INTEGER
-* The leading dimension of the array WORK.
-* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
-*
-* IWORK (workspace) INTEGER array, dimension (2*(N-1))
-* If JOB = 'E', IWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of an eigenvalue lambda is
-* defined as
-*
-* S(lambda) = |v'*u| / (norm(u)*norm(v))
-*
-* where u and v are the right and left eigenvectors of T corresponding
-* to lambda; v' denotes the conjugate-transpose of v, and norm(u)
-* denotes the Euclidean norm. These reciprocal condition numbers always
-* lie between zero (very badly conditioned) and one (very well
-* conditioned). If n = 1, S(lambda) is defined to be 1.
-*
-* An approximate error bound for a computed eigenvalue W(i) is given by
-*
-* EPS * norm(T) / S(i)
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number of the right eigenvector u
-* corresponding to lambda is defined as follows. Suppose
-*
-* T = ( lambda c )
-* ( 0 T22 )
-*
-* Then the reciprocal condition number is
-*
-* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
-*
-* where sigma-min denotes the smallest singular value. We approximate
-* the smallest singular value by the reciprocal of an estimate of the
-* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
-* defined to be abs(T(1,1)).
-*
-* An approximate error bound for a computed right eigenvector VR(i)
-* is given by
-*
-* EPS * norm(T) / SEP(i)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrsyl"></A>
- <H2>dtrsyl</H2>
-
- <PRE>
-USAGE:
- scale, info, c = NumRu::Lapack.dtrsyl( trana, tranb, isgn, a, b, c)
- or
- NumRu::Lapack.dtrsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* DTRSYL solves the real Sylvester matrix equation:
-*
-* op(A)*X + X*op(B) = scale*C or
-* op(A)*X - X*op(B) = scale*C,
-*
-* where op(A) = A or A**T, and A and B are both upper quasi-
-* triangular. A is M-by-M and B is N-by-N; the right hand side C and
-* the solution X are M-by-N; and scale is an output scale factor, set
-* <= 1 to avoid overflow in X.
-*
-* A and B must be in Schur canonical form (as returned by DHSEQR), that
-* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
-* each 2-by-2 diagonal block has its diagonal elements equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* TRANA (input) CHARACTER*1
-* Specifies the option op(A):
-* = 'N': op(A) = A (No transpose)
-* = 'T': op(A) = A**T (Transpose)
-* = 'C': op(A) = A**H (Conjugate transpose = Transpose)
-*
-* TRANB (input) CHARACTER*1
-* Specifies the option op(B):
-* = 'N': op(B) = B (No transpose)
-* = 'T': op(B) = B**T (Transpose)
-* = 'C': op(B) = B**H (Conjugate transpose = Transpose)
-*
-* ISGN (input) INTEGER
-* Specifies the sign in the equation:
-* = +1: solve op(A)*X + X*op(B) = scale*C
-* = -1: solve op(A)*X - X*op(B) = scale*C
-*
-* M (input) INTEGER
-* The order of the matrix A, and the number of rows in the
-* matrices X and C. M >= 0.
-*
-* N (input) INTEGER
-* The order of the matrix B, and the number of columns in the
-* matrices X and C. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,M)
-* The upper quasi-triangular matrix A, in Schur canonical form.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,N)
-* The upper quasi-triangular matrix B, in Schur canonical form.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
-* On entry, the M-by-N right hand side matrix C.
-* On exit, C is overwritten by the solution matrix X.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M)
-*
-* SCALE (output) DOUBLE PRECISION
-* The scale factor, scale, set <= 1 to avoid overflow in X.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: A and B have common or very close eigenvalues; perturbed
-* values were used to solve the equation (but the matrices
-* A and B are unchanged).
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrti2"></A>
- <H2>dtrti2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dtrti2( uplo, diag, a)
- or
- NumRu::Lapack.dtrti2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* DTRTI2 computes the inverse of a real upper or lower triangular
-* matrix.
-*
-* This is the Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the matrix A is upper or lower triangular.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* DIAG (input) CHARACTER*1
-* Specifies whether or not the matrix A is unit triangular.
-* = 'N': Non-unit triangular
-* = 'U': Unit triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading n by n upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-*
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrtri"></A>
- <H2>dtrtri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.dtrtri( uplo, diag, a)
- or
- NumRu::Lapack.dtrtri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* DTRTRI computes the inverse of a real upper or lower triangular
-* matrix A.
-*
-* This is the Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrtrs"></A>
- <H2>dtrtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.dtrtrs( uplo, trans, diag, a, b)
- or
- NumRu::Lapack.dtrtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* DTRTRS solves a triangular system of the form
-*
-* A * X = B or A**T * X = B,
-*
-* where A is a triangular matrix of order N, and B is an N-by-NRHS
-* matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the solutions
-* X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrttf"></A>
- <H2>dtrttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.dtrttf( transr, uplo, a)
- or
- NumRu::Lapack.dtrttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )
-
-* Purpose
-* =======
-*
-* DTRTTF copies a triangular matrix A from standard full format (TR)
-* to rectangular full packed format (TF) .
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal form is wanted;
-* = 'T': ARF in Transpose form is wanted.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N).
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1,N).
-*
-* ARF (output) DOUBLE PRECISION array, dimension (NT).
-* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Rectangular Full Packed (RFP) Format when N is
-* even. We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* the transpose of the first three columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* the transpose of the last three columns of AP lower.
-* This covers the case N even and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 03 04 05 33 43 53
-* 13 14 15 00 44 54
-* 23 24 25 10 11 55
-* 33 34 35 20 21 22
-* 00 44 45 30 31 32
-* 01 11 55 40 41 42
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We then consider Rectangular Full Packed (RFP) Format when N is
-* odd. We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* the transpose of the first two columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* the transpose of the last two columns of AP lower.
-* This covers the case N odd and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 02 03 04 00 33 43
-* 12 13 14 10 11 44
-* 22 23 24 20 21 22
-* 00 33 34 30 31 32
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-* RFP A RFP A
-*
-* 02 12 22 00 01 00 10 20 30 40 50
-* 03 13 23 33 11 33 11 21 31 41 51
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* Reference
-* =========
-*
-* =====================================================================
-*
-* ..
-* .. Local Scalars ..
- LOGICAL LOWER, NISODD, NORMALTRANSR
- INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MOD
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtrttp"></A>
- <H2>dtrttp</H2>
-
- <PRE>
-USAGE:
- ap, info = NumRu::Lapack.dtrttp( uplo, a)
- or
- NumRu::Lapack.dtrttp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO )
-
-* Purpose
-* =======
-*
-* DTRTTP copies a triangular matrix A from full format (TR) to standard
-* packed format (TP).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular.
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrices AP and A. N >= 0.
-*
-* A (input) DOUBLE PRECISION array, dimension (LDA,N)
-* On exit, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2
-* On exit, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dtz.html b/doc/dtz.html
deleted file mode 100644
index dcf2b23..0000000
--- a/doc/dtz.html
+++ /dev/null
@@ -1,216 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for trapezoidal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for trapezoidal matrix</H1>
- <UL>
- <LI><A HREF="#dtzrqf">dtzrqf</A> : </LI>
- <LI><A HREF="#dtzrzf">dtzrzf</A> : </LI>
- </UL>
-
- <A NAME="dtzrqf"></A>
- <H2>dtzrqf</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.dtzrqf( a)
- or
- NumRu::Lapack.dtzrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine DTZRZF.
-*
-* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
-* to upper triangular form by means of orthogonal transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* orthogonal matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), which is used to introduce zeros into
-* the ( m - k + 1 )th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="dtzrzf"></A>
- <H2>dtzrzf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.dtzrzf( a, lwork)
- or
- NumRu::Lapack.dtzrzf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
-* to upper triangular form by means of orthogonal transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* orthogonal matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) DOUBLE PRECISION array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), which is used to introduce zeros into
-* the ( m - k + 1 )th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/dup.html b/doc/dup.html
deleted file mode 100644
index a5132bb..0000000
--- a/doc/dup.html
+++ /dev/null
@@ -1,22 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>DOUBLE PRECISION routines for (complex) unitary, packed storageBDbidiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>DOUBLE PRECISION routines for (complex) unitary, packed storageBDbidiagonal matrix</H1>
- <UL>
- <LI><A HREF="#dup">dup</A> : </LI>
- </UL>
-
- <A NAME="dup"></A>
- <H2>dup</H2>
-
- <PRE>
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="d.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/index.html b/doc/index.html
deleted file mode 100644
index b045fd9..0000000
--- a/doc/index.html
+++ /dev/null
@@ -1,16 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>LAPACK routines</TITLE>
- </HEAD>
- <BODY>
- <H1>Data types</H1>
- <UL>
- <LI><A HREF="s.html">S: REAL</A></LI>
- <LI><A HREF="d.html">D: DOUBLE PRECISION</A></LI>
- <LI><A HREF="c.html">C: COMPLEX</A></LI>
- <LI><A HREF="z.html">Z: COMPLEX*16 or DOUBLE COMPLEX</A></LI>
- <LI><A HREF="ds.html">DS: Data type in double but solving problem using single precision</A></LI>
- <LI><A HREF="zc.html">ZC: Data type in complex*16 but solving problem using complex precision</A></LI>
- </UL>
- </BODY>
-</HTML>
diff --git a/doc/s.html b/doc/s.html
deleted file mode 100644
index 1aabb24..0000000
--- a/doc/s.html
+++ /dev/null
@@ -1,35 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines</TITLE>
- </HEAD>
- <BODY>
- <H1>REAL routines</H1>
- <UL>
- <LI><A HREF="sbd.html">BD: bidiagonal</A></LI>
- <LI><A HREF="sdi.html">DI: diagonal</A></LI>
- <LI><A HREF="sgb.html">GB: general band</A></LI>
- <LI><A HREF="sge.html">GE: general (i.e., unsymmetric, in some cases rectangular)</A></LI>
- <LI><A HREF="sgg.html">GG: general matrices, generalized problem (i.e., a pair of general matrices)</A></LI>
- <LI><A HREF="sgt.html">GT: general tridiagonal</A></LI>
- <LI><A HREF="shg.html">HG: upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix)</A></LI>
- <LI><A HREF="shs.html">HS: upper Hessenberg</A></LI>
- <LI><A HREF="sop.html">OP: (real) orthogonal, packed storage</A></LI>
- <LI><A HREF="sor.html">OR: (real) orthogonal</A></LI>
- <LI><A HREF="spb.html">PB: symmetric or Hermitian positive definite band</A></LI>
- <LI><A HREF="spo.html">PO: symmetric or Hermitian positive definite</A></LI>
- <LI><A HREF="spp.html">PP: symmetric or Hermitian positive definite, packed storage</A></LI>
- <LI><A HREF="spt.html">PT: symmetric or Hermitian positive definite tridiagonal</A></LI>
- <LI><A HREF="ssb.html">SB: (real) symmetric band</A></LI>
- <LI><A HREF="ssp.html">SP: symmetric, packed storage</A></LI>
- <LI><A HREF="sst.html">ST: (real) symmetric tridiagonal</A></LI>
- <LI><A HREF="ssy.html">SY: symmetric</A></LI>
- <LI><A HREF="stb.html">TB: triangular band</A></LI>
- <LI><A HREF="stg.html">TG: triangular matrices, generalized problem (i.e., a pair of triangular matrices)</A></LI>
- <LI><A HREF="stp.html">TP: triangular, packed storage</A></LI>
- <LI><A HREF="str.html">TR: triangular (or in some cases quasi-triangular)</A></LI>
- <LI><A HREF="stz.html">TZ: trapezoidal</A></LI>
- </UL>
- <HR />
- <A HREF="index.html">back to data types</A>
- </BODY>
-</HTML>
diff --git a/doc/sbd.html b/doc/sbd.html
deleted file mode 100644
index a35b2d5..0000000
--- a/doc/sbd.html
+++ /dev/null
@@ -1,308 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for bidiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for bidiagonal matrix</H1>
- <UL>
- <LI><A HREF="#sbdsdc">sbdsdc</A> : </LI>
- <LI><A HREF="#sbdsqr">sbdsqr</A> : </LI>
- </UL>
-
- <A NAME="sbdsdc"></A>
- <H2>sbdsdc</H2>
-
- <PRE>
-USAGE:
- u, vt, q, iq, info, d, e = NumRu::Lapack.sbdsdc( uplo, compq, d, e, ldu, ldvt)
- or
- NumRu::Lapack.sbdsdc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SBDSDC computes the singular value decomposition (SVD) of a real
-* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
-* using a divide and conquer method, where S is a diagonal matrix
-* with non-negative diagonal elements (the singular values of B), and
-* U and VT are orthogonal matrices of left and right singular vectors,
-* respectively. SBDSDC can be used to compute all singular values,
-* and optionally, singular vectors or singular vectors in compact form.
-*
-* This code makes very mild assumptions about floating point
-* arithmetic. It will work on machines with a guard digit in
-* add/subtract, or on those binary machines without guard digits
-* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
-* It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none. See SLASD3 for details.
-*
-* The code currently calls SLASDQ if singular values only are desired.
-* However, it can be slightly modified to compute singular values
-* using the divide and conquer method.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': B is upper bidiagonal.
-* = 'L': B is lower bidiagonal.
-*
-* COMPQ (input) CHARACTER*1
-* Specifies whether singular vectors are to be computed
-* as follows:
-* = 'N': Compute singular values only;
-* = 'P': Compute singular values and compute singular
-* vectors in compact form;
-* = 'I': Compute singular values and singular vectors.
-*
-* N (input) INTEGER
-* The order of the matrix B. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the bidiagonal matrix B.
-* On exit, if INFO=0, the singular values of B.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the elements of E contain the offdiagonal
-* elements of the bidiagonal matrix whose SVD is desired.
-* On exit, E has been destroyed.
-*
-* U (output) REAL array, dimension (LDU,N)
-* If COMPQ = 'I', then:
-* On exit, if INFO = 0, U contains the left singular vectors
-* of the bidiagonal matrix.
-* For other values of COMPQ, U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1.
-* If singular vectors are desired, then LDU >= max( 1, N ).
-*
-* VT (output) REAL array, dimension (LDVT,N)
-* If COMPQ = 'I', then:
-* On exit, if INFO = 0, VT' contains the right singular
-* vectors of the bidiagonal matrix.
-* For other values of COMPQ, VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1.
-* If singular vectors are desired, then LDVT >= max( 1, N ).
-*
-* Q (output) REAL array, dimension (LDQ)
-* If COMPQ = 'P', then:
-* On exit, if INFO = 0, Q and IQ contain the left
-* and right singular vectors in a compact form,
-* requiring O(N log N) space instead of 2*N**2.
-* In particular, Q contains all the REAL data in
-* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
-* words of memory, where SMLSIZ is returned by ILAENV and
-* is equal to the maximum size of the subproblems at the
-* bottom of the computation tree (usually about 25).
-* For other values of COMPQ, Q is not referenced.
-*
-* IQ (output) INTEGER array, dimension (LDIQ)
-* If COMPQ = 'P', then:
-* On exit, if INFO = 0, Q and IQ contain the left
-* and right singular vectors in a compact form,
-* requiring O(N log N) space instead of 2*N**2.
-* In particular, IQ contains all INTEGER data in
-* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
-* words of memory, where SMLSIZ is returned by ILAENV and
-* is equal to the maximum size of the subproblems at the
-* bottom of the computation tree (usually about 25).
-* For other values of COMPQ, IQ is not referenced.
-*
-* WORK (workspace) REAL array, dimension (MAX(1,LWORK))
-* If COMPQ = 'N' then LWORK >= (4 * N).
-* If COMPQ = 'P' then LWORK >= (6 * N).
-* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
-*
-* IWORK (workspace) INTEGER array, dimension (8*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The algorithm failed to compute a singular value.
-* The update process of divide and conquer failed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-* =====================================================================
-* Changed dimension statement in comment describing E from (N) to
-* (N-1). Sven, 17 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sbdsqr"></A>
- <H2>sbdsqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, vt, u, c = NumRu::Lapack.sbdsqr( uplo, nru, d, e, vt, u, c)
- or
- NumRu::Lapack.sbdsqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SBDSQR computes the singular values and, optionally, the right and/or
-* left singular vectors from the singular value decomposition (SVD) of
-* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
-* zero-shift QR algorithm. The SVD of B has the form
-*
-* B = Q * S * P**T
-*
-* where S is the diagonal matrix of singular values, Q is an orthogonal
-* matrix of left singular vectors, and P is an orthogonal matrix of
-* right singular vectors. If left singular vectors are requested, this
-* subroutine actually returns U*Q instead of Q, and, if right singular
-* vectors are requested, this subroutine returns P**T*VT instead of
-* P**T, for given real input matrices U and VT. When U and VT are the
-* orthogonal matrices that reduce a general matrix A to bidiagonal
-* form: A = U*B*VT, as computed by SGEBRD, then
-*
-* A = (U*Q) * S * (P**T*VT)
-*
-* is the SVD of A. Optionally, the subroutine may also compute Q**T*C
-* for a given real input matrix C.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices With
-* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
-* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
-* no. 5, pp. 873-912, Sept 1990) and
-* "Accurate singular values and differential qd algorithms," by
-* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
-* Department, University of California at Berkeley, July 1992
-* for a detailed description of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': B is upper bidiagonal;
-* = 'L': B is lower bidiagonal.
-*
-* N (input) INTEGER
-* The order of the matrix B. N >= 0.
-*
-* NCVT (input) INTEGER
-* The number of columns of the matrix VT. NCVT >= 0.
-*
-* NRU (input) INTEGER
-* The number of rows of the matrix U. NRU >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the bidiagonal matrix B.
-* On exit, if INFO=0, the singular values of B in decreasing
-* order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the N-1 offdiagonal elements of the bidiagonal
-* matrix B.
-* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
-* will contain the diagonal and superdiagonal elements of a
-* bidiagonal matrix orthogonally equivalent to the one given
-* as input.
-*
-* VT (input/output) REAL array, dimension (LDVT, NCVT)
-* On entry, an N-by-NCVT matrix VT.
-* On exit, VT is overwritten by P**T * VT.
-* Not referenced if NCVT = 0.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT.
-* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
-*
-* U (input/output) REAL array, dimension (LDU, N)
-* On entry, an NRU-by-N matrix U.
-* On exit, U is overwritten by U * Q.
-* Not referenced if NRU = 0.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,NRU).
-*
-* C (input/output) REAL array, dimension (LDC, NCC)
-* On entry, an N-by-NCC matrix C.
-* On exit, C is overwritten by Q**T * C.
-* Not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0:
-* if NCVT = NRU = NCC = 0,
-* = 1, a split was marked by a positive value in E
-* = 2, current block of Z not diagonalized after 30*N
-* iterations (in inner while loop)
-* = 3, termination criterion of outer while loop not met
-* (program created more than N unreduced blocks)
-* else NCVT = NRU = NCC = 0,
-* the algorithm did not converge; D and E contain the
-* elements of a bidiagonal matrix which is orthogonally
-* similar to the input matrix B; if INFO = i, i
-* elements of E have not converged to zero.
-*
-* Internal Parameters
-* ===================
-*
-* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))
-* TOLMUL controls the convergence criterion of the QR loop.
-* If it is positive, TOLMUL*EPS is the desired relative
-* precision in the computed singular values.
-* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
-* desired absolute accuracy in the computed singular
-* values (corresponds to relative accuracy
-* abs(TOLMUL*EPS) in the largest singular value.
-* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
-* between 10 (for fast convergence) and .1/EPS
-* (for there to be some accuracy in the results).
-* Default is to lose at either one eighth or 2 of the
-* available decimal digits in each computed singular value
-* (whichever is smaller).
-*
-* MAXITR INTEGER, default = 6
-* MAXITR controls the maximum number of passes of the
-* algorithm through its inner loop. The algorithms stops
-* (and so fails to converge) if the number of passes
-* through the inner loop exceeds MAXITR*N**2.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sdi.html b/doc/sdi.html
deleted file mode 100644
index 5b524e8..0000000
--- a/doc/sdi.html
+++ /dev/null
@@ -1,89 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for diagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for diagonal matrix</H1>
- <UL>
- <LI><A HREF="#sdisna">sdisna</A> : </LI>
- </UL>
-
- <A NAME="sdisna"></A>
- <H2>sdisna</H2>
-
- <PRE>
-USAGE:
- sep, info = NumRu::Lapack.sdisna( job, n, d)
- or
- NumRu::Lapack.sdisna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )
-
-* Purpose
-* =======
-*
-* SDISNA computes the reciprocal condition numbers for the eigenvectors
-* of a real symmetric or complex Hermitian matrix or for the left or
-* right singular vectors of a general m-by-n matrix. The reciprocal
-* condition number is the 'gap' between the corresponding eigenvalue or
-* singular value and the nearest other one.
-*
-* The bound on the error, measured by angle in radians, in the I-th
-* computed vector is given by
-*
-* SLAMCH( 'E' ) * ( ANORM / SEP( I ) )
-*
-* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed
-* to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of
-* the error bound.
-*
-* SDISNA may also be used to compute error bounds for eigenvectors of
-* the generalized symmetric definite eigenproblem.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies for which problem the reciprocal condition numbers
-* should be computed:
-* = 'E': the eigenvectors of a symmetric/Hermitian matrix;
-* = 'L': the left singular vectors of a general matrix;
-* = 'R': the right singular vectors of a general matrix.
-*
-* M (input) INTEGER
-* The number of rows of the matrix. M >= 0.
-*
-* N (input) INTEGER
-* If JOB = 'L' or 'R', the number of columns of the matrix,
-* in which case N >= 0. Ignored if JOB = 'E'.
-*
-* D (input) REAL array, dimension (M) if JOB = 'E'
-* dimension (min(M,N)) if JOB = 'L' or 'R'
-* The eigenvalues (if JOB = 'E') or singular values (if JOB =
-* 'L' or 'R') of the matrix, in either increasing or decreasing
-* order. If singular values, they must be non-negative.
-*
-* SEP (output) REAL array, dimension (M) if JOB = 'E'
-* dimension (min(M,N)) if JOB = 'L' or 'R'
-* The reciprocal condition numbers of the vectors.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sgb.html b/doc/sgb.html
deleted file mode 100644
index 836fc08..0000000
--- a/doc/sgb.html
+++ /dev/null
@@ -1,1898 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for general band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for general band matrix</H1>
- <UL>
- <LI><A HREF="#sgbbrd">sgbbrd</A> : </LI>
- <LI><A HREF="#sgbcon">sgbcon</A> : </LI>
- <LI><A HREF="#sgbequ">sgbequ</A> : </LI>
- <LI><A HREF="#sgbequb">sgbequb</A> : </LI>
- <LI><A HREF="#sgbrfs">sgbrfs</A> : </LI>
- <LI><A HREF="#sgbrfsx">sgbrfsx</A> : </LI>
- <LI><A HREF="#sgbsv">sgbsv</A> : </LI>
- <LI><A HREF="#sgbsvx">sgbsvx</A> : </LI>
- <LI><A HREF="#sgbsvxx">sgbsvxx</A> : </LI>
- <LI><A HREF="#sgbtf2">sgbtf2</A> : </LI>
- <LI><A HREF="#sgbtrf">sgbtrf</A> : </LI>
- <LI><A HREF="#sgbtrs">sgbtrs</A> : </LI>
- </UL>
-
- <A NAME="sgbbrd"></A>
- <H2>sgbbrd</H2>
-
- <PRE>
-USAGE:
- d, e, q, pt, info, ab, c = NumRu::Lapack.sgbbrd( vect, kl, ku, ab, c)
- or
- NumRu::Lapack.sgbbrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGBBRD reduces a real general m-by-n band matrix A to upper
-* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
-*
-* The routine computes B, and optionally forms Q or P', or computes
-* Q'*C for a given matrix C.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether or not the matrices Q and P' are to be
-* formed.
-* = 'N': do not form Q or P';
-* = 'Q': form Q only;
-* = 'P': form P' only;
-* = 'B': form both.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals of the matrix A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals of the matrix A. KU >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the m-by-n band matrix A, stored in rows 1 to
-* KL+KU+1. The j-th column of A is stored in the j-th column of
-* the array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-* On exit, A is overwritten by values generated during the
-* reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KL+KU+1.
-*
-* D (output) REAL array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B.
-*
-* E (output) REAL array, dimension (min(M,N)-1)
-* The superdiagonal elements of the bidiagonal matrix B.
-*
-* Q (output) REAL array, dimension (LDQ,M)
-* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
-* If VECT = 'N' or 'P', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
-*
-* PT (output) REAL array, dimension (LDPT,N)
-* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
-* If VECT = 'N' or 'Q', the array PT is not referenced.
-*
-* LDPT (input) INTEGER
-* The leading dimension of the array PT.
-* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
-*
-* C (input/output) REAL array, dimension (LDC,NCC)
-* On entry, an m-by-ncc matrix C.
-* On exit, C is overwritten by Q'*C.
-* C is not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
-*
-* WORK (workspace) REAL array, dimension (2*max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbcon"></A>
- <H2>sgbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.sgbcon( norm, kl, ku, ab, ipiv, anorm)
- or
- NumRu::Lapack.sgbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGBCON estimates the reciprocal of the condition number of a real
-* general band matrix A, in either the 1-norm or the infinity-norm,
-* using the LU factorization computed by SGBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by SGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* ANORM (input) REAL
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbequ"></A>
- <H2>sgbequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequ( m, kl, ku, ab)
- or
- NumRu::Lapack.sgbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SGBEQU computes row and column scalings intended to equilibrate an
-* M-by-N band matrix A and reduce its condition number. R returns the
-* row scale factors and C the column scale factors, chosen to try to
-* make the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
-* column of A is stored in the j-th column of the array AB as
-* follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0, or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbequb"></A>
- <H2>sgbequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequb( kl, ku, ab)
- or
- NumRu::Lapack.sgbequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SGBEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from SGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= max(1,M).
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbrfs"></A>
- <H2>sgbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.sgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)
- or
- NumRu::Lapack.sgbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is banded, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) REAL array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by SGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from SGBTRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbrfsx"></A>
- <H2>sgbrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.sgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.sgbrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGBRFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from SGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbsv"></A>
- <H2>sgbsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab, b = NumRu::Lapack.sgbsv( kl, ku, ab, b)
- or
- NumRu::Lapack.sgbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SGBSV computes the solution to a real system of linear equations
-* A * X = B, where A is a band matrix of order N with KL subdiagonals
-* and KU superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as A = L * U, where L is a product of permutation
-* and unit lower triangular matrices with KL subdiagonals, and U is
-* upper triangular with KL+KU superdiagonals. The factored form of A
-* is then used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL SGBTRF, SGBTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbsvx"></A>
- <H2>sgbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.sgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.sgbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGBSVX uses the LU factorization to compute the solution to a real
-* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
-* where A is a band matrix of order N with KL subdiagonals and KU
-* superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed by this subroutine:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = L * U,
-* where L is a product of permutation and unit lower triangular
-* matrices with KL subdiagonals, and U is upper triangular with
-* KL+KU superdiagonals.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB and IPIV contain the factored form of
-* A. If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* AB, AFB, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then A must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) REAL array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by SGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns details of the LU factorization of A.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns details of the LU factorization of the equilibrated
-* matrix A (see the description of AB for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = L*U
-* as computed by SGBTRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) REAL array, dimension (3*N)
-* On exit, WORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If WORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* WORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-*
-* value of RCOND would suggest.
-
-* =====================================================================
-* Moved setting of INFO = N+1 so INFO does not subsequently get
-* overwritten. Sven, 17 Mar 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbsvxx"></A>
- <H2>sgbsvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.sgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.sgbsvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGBSVXX uses the LU factorization to compute the solution to a
-* real system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. SGBSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* SGBSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* SGBSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what SGBSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose = Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then AB must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) REAL array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by SGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by SGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In SGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbtf2"></A>
- <H2>sgbtf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.sgbtf2( m, kl, ku, ab)
- or
- NumRu::Lapack.sgbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* SGBTF2 computes an LU factorization of a real m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U, because of fill-in resulting from the row
-* interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbtrf"></A>
- <H2>sgbtrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.sgbtrf( m, kl, ku, ab)
- or
- NumRu::Lapack.sgbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* SGBTRF computes an LU factorization of a real m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgbtrs"></A>
- <H2>sgbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.sgbtrs( trans, kl, ku, ab, ipiv, b)
- or
- NumRu::Lapack.sgbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SGBTRS solves a system of linear equations
-* A * X = B or A' * X = B
-* with a general band matrix A using the LU factorization computed
-* by SGBTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A'* X = B (Transpose)
-* = 'C': A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by SGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sge.html b/doc/sge.html
deleted file mode 100644
index 5719895..0000000
--- a/doc/sge.html
+++ /dev/null
@@ -1,7403 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for general (i.e., unsymmetric, in some cases rectangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for general (i.e., unsymmetric, in some cases rectangular) matrix</H1>
- <UL>
- <LI><A HREF="#sgebak">sgebak</A> : </LI>
- <LI><A HREF="#sgebal">sgebal</A> : </LI>
- <LI><A HREF="#sgebd2">sgebd2</A> : </LI>
- <LI><A HREF="#sgebrd">sgebrd</A> : </LI>
- <LI><A HREF="#sgecon">sgecon</A> : </LI>
- <LI><A HREF="#sgeequ">sgeequ</A> : </LI>
- <LI><A HREF="#sgeequb">sgeequb</A> : </LI>
- <LI><A HREF="#sgees">sgees</A> : </LI>
- <LI><A HREF="#sgeesx">sgeesx</A> : </LI>
- <LI><A HREF="#sgeev">sgeev</A> : </LI>
- <LI><A HREF="#sgeevx">sgeevx</A> : </LI>
- <LI><A HREF="#sgegs">sgegs</A> : </LI>
- <LI><A HREF="#sgegv">sgegv</A> : </LI>
- <LI><A HREF="#sgehd2">sgehd2</A> : </LI>
- <LI><A HREF="#sgehrd">sgehrd</A> : </LI>
- <LI><A HREF="#sgejsv">sgejsv</A> : </LI>
- <LI><A HREF="#sgelq2">sgelq2</A> : </LI>
- <LI><A HREF="#sgelqf">sgelqf</A> : </LI>
- <LI><A HREF="#sgels">sgels</A> : </LI>
- <LI><A HREF="#sgelsd">sgelsd</A> : </LI>
- <LI><A HREF="#sgelss">sgelss</A> : </LI>
- <LI><A HREF="#sgelsx">sgelsx</A> : </LI>
- <LI><A HREF="#sgelsy">sgelsy</A> : </LI>
- <LI><A HREF="#sgeql2">sgeql2</A> : </LI>
- <LI><A HREF="#sgeqlf">sgeqlf</A> : </LI>
- <LI><A HREF="#sgeqp3">sgeqp3</A> : </LI>
- <LI><A HREF="#sgeqpf">sgeqpf</A> : </LI>
- <LI><A HREF="#sgeqr2">sgeqr2</A> : </LI>
- <LI><A HREF="#sgeqr2p">sgeqr2p</A> : </LI>
- <LI><A HREF="#sgeqrf">sgeqrf</A> : </LI>
- <LI><A HREF="#sgeqrfp">sgeqrfp</A> : </LI>
- <LI><A HREF="#sgerfs">sgerfs</A> : </LI>
- <LI><A HREF="#sgerfsx">sgerfsx</A> : </LI>
- <LI><A HREF="#sgerq2">sgerq2</A> : </LI>
- <LI><A HREF="#sgerqf">sgerqf</A> : </LI>
- <LI><A HREF="#sgesc2">sgesc2</A> : </LI>
- <LI><A HREF="#sgesdd">sgesdd</A> : </LI>
- <LI><A HREF="#sgesv">sgesv</A> : </LI>
- <LI><A HREF="#sgesvd">sgesvd</A> : </LI>
- <LI><A HREF="#sgesvj">sgesvj</A> : </LI>
- <LI><A HREF="#sgesvx">sgesvx</A> : </LI>
- <LI><A HREF="#sgesvxx">sgesvxx</A> : </LI>
- <LI><A HREF="#sgetc2">sgetc2</A> : </LI>
- <LI><A HREF="#sgetf2">sgetf2</A> : </LI>
- <LI><A HREF="#sgetrf">sgetrf</A> : </LI>
- <LI><A HREF="#sgetri">sgetri</A> : </LI>
- <LI><A HREF="#sgetrs">sgetrs</A> : </LI>
- </UL>
-
- <A NAME="sgebak"></A>
- <H2>sgebak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.sgebak( job, side, ilo, ihi, scale, v)
- or
- NumRu::Lapack.sgebak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* SGEBAK forms the right or left eigenvectors of a real general matrix
-* by backward transformation on the computed eigenvectors of the
-* balanced matrix output by SGEBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N', do nothing, return immediately;
-* = 'P', do backward transformation for permutation only;
-* = 'S', do backward transformation for scaling only;
-* = 'B', do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to SGEBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by SGEBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* SCALE (input) REAL array, dimension (N)
-* Details of the permutation and scaling factors, as returned
-* by SGEBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) REAL array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by SHSEIN or STREVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgebal"></A>
- <H2>sgebal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, scale, info, a = NumRu::Lapack.sgebal( job, a)
- or
- NumRu::Lapack.sgebal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* SGEBAL balances a general real matrix A. This involves, first,
-* permuting A by a similarity transformation to isolate eigenvalues
-* in the first 1 to ILO-1 and last IHI+1 to N elements on the
-* diagonal; and second, applying a diagonal similarity transformation
-* to rows and columns ILO to IHI to make the rows and columns as
-* close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrix, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A:
-* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
-* for i = 1,...,N;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* SCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied to
-* A. If P(j) is the index of the row and column interchanged
-* with row and column j and D(j) is the scaling factor
-* applied to row and column j, then
-* SCALE(j) = P(j) for j = 1,...,ILO-1
-* = D(j) for j = ILO,...,IHI
-* = P(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The permutations consist of row and column interchanges which put
-* the matrix in the form
-*
-* ( T1 X Y )
-* P A P = ( 0 B Z )
-* ( 0 0 T2 )
-*
-* where T1 and T2 are upper triangular matrices whose eigenvalues lie
-* along the diagonal. The column indices ILO and IHI mark the starting
-* and ending columns of the submatrix B. Balancing consists of applying
-* a diagonal similarity transformation inv(D) * B * D to make the
-* 1-norms of each row of B and its corresponding column nearly equal.
-* The output matrix is
-*
-* ( T1 X*D Y )
-* ( 0 inv(D)*B*D inv(D)*Z ).
-* ( 0 0 T2 )
-*
-* Information about the permutations P and the diagonal matrix D is
-* returned in the vector SCALE.
-*
-* This subroutine is based on the EISPACK routine BALANC.
-*
-* Modified by Tzu-Yi Chen, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgebd2"></A>
- <H2>sgebd2</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, info, a = NumRu::Lapack.sgebd2( m, a)
- or
- NumRu::Lapack.sgebd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEBD2 reduces a real general m by n matrix A to upper or lower
-* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the m by n general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the orthogonal matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the orthogonal matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) REAL array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) REAL array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q. See Further Details.
-*
-* TAUP (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix P. See Further Details.
-*
-* WORK (workspace) REAL array, dimension (max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
-* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
-* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgebrd"></A>
- <H2>sgebrd</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, work, info, a = NumRu::Lapack.sgebrd( m, a, lwork)
- or
- NumRu::Lapack.sgebrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEBRD reduces a general real M-by-N matrix A to upper or lower
-* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the orthogonal matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the orthogonal matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the orthogonal matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) REAL array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) REAL array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q. See Further Details.
-*
-* TAUP (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix P. See Further Details.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,M,N).
-* For optimum performance LWORK >= (M+N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
-* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are real scalars, and v and u are real vectors;
-* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
-* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgecon"></A>
- <H2>sgecon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.sgecon( norm, a, anorm)
- or
- NumRu::Lapack.sgecon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGECON estimates the reciprocal of the condition number of a general
-* real matrix A, in either the 1-norm or the infinity-norm, using
-* the LU factorization computed by SGETRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by SGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) REAL
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeequ"></A>
- <H2>sgeequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequ( a)
- or
- NumRu::Lapack.sgeequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SGEEQU computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeequb"></A>
- <H2>sgeequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequb( a)
- or
- NumRu::Lapack.sgeequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SGEEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from SGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) REAL array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) REAL array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) REAL
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) REAL
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgees"></A>
- <H2>sgees</H2>
-
- <PRE>
-USAGE:
- sdim, wr, wi, vs, work, info, a = NumRu::Lapack.sgees( jobvs, sort, a, lwork){|a,b| ... }
- or
- NumRu::Lapack.sgees # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEES computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues, the real Schur form T, and, optionally, the matrix of
-* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* real Schur form so that selected eigenvalues are at the top left.
-* The leading columns of Z then form an orthonormal basis for the
-* invariant subspace corresponding to the selected eigenvalues.
-*
-* A matrix is in real Schur form if it is upper quasi-triangular with
-* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
-* form
-* [ a b ]
-* [ c a ]
-*
-* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* If SORT = 'N', SELECT is not referenced.
-* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
-* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
-* conjugate pair of eigenvalues is selected, then both complex
-* eigenvalues are selected.
-* Note that a selected complex eigenvalue may no longer
-* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned); in this
-* case INFO is set to N+2 (see INFO below).
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten by its real Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELECT is true. (Complex conjugate
-* pairs for which SELECT is true for either
-* eigenvalue count as 2.)
-*
-* WR (output) REAL array, dimension (N)
-* WI (output) REAL array, dimension (N)
-* WR and WI contain the real and imaginary parts,
-* respectively, of the computed eigenvalues in the same order
-* that they appear on the diagonal of the output Schur form T.
-* Complex conjugate pairs of eigenvalues will appear
-* consecutively with the eigenvalue having the positive
-* imaginary part first.
-*
-* VS (output) REAL array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1; if
-* JOBVS = 'V', LDVS >= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,3*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
-* contain those eigenvalues which have converged; if
-* JOBVS = 'V', VS contains the matrix which reduces A
-* to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because some
-* eigenvalues were too close to separate (the problem
-* is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of some
-* complex eigenvalues so that leading eigenvalues in
-* the Schur form no longer satisfy SELECT=.TRUE. This
-* could also be caused by underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeesx"></A>
- <H2>sgeesx</H2>
-
- <PRE>
-USAGE:
- sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.sgeesx( jobvs, sort, sense, a, lwork, liwork){|a,b| ... }
- or
- NumRu::Lapack.sgeesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEESX computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues, the real Schur form T, and, optionally, the matrix of
-* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* real Schur form so that selected eigenvalues are at the top left;
-* computes a reciprocal condition number for the average of the
-* selected eigenvalues (RCONDE); and computes a reciprocal condition
-* number for the right invariant subspace corresponding to the
-* selected eigenvalues (RCONDV). The leading columns of Z form an
-* orthonormal basis for this invariant subspace.
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
-* these quantities are called s and sep respectively).
-*
-* A real matrix is in real Schur form if it is upper quasi-triangular
-* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
-* the form
-* [ a b ]
-* [ c a ]
-*
-* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* If SORT = 'N', SELECT is not referenced.
-* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
-* SELECT(WR(j),WI(j)) is true; i.e., if either one of a
-* complex conjugate pair of eigenvalues is selected, then both
-* are. Note that a selected complex eigenvalue may no longer
-* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned); in this
-* case INFO may be set to N+3 (see INFO below).
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for average of selected eigenvalues only;
-* = 'V': Computed for selected right invariant subspace only;
-* = 'B': Computed for both.
-* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the N-by-N matrix A.
-* On exit, A is overwritten by its real Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELECT is true. (Complex conjugate
-* pairs for which SELECT is true for either
-* eigenvalue count as 2.)
-*
-* WR (output) REAL array, dimension (N)
-* WI (output) REAL array, dimension (N)
-* WR and WI contain the real and imaginary parts, respectively,
-* of the computed eigenvalues, in the same order that they
-* appear on the diagonal of the output Schur form T. Complex
-* conjugate pairs of eigenvalues appear consecutively with the
-* eigenvalue having the positive imaginary part first.
-*
-* VS (output) REAL array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1, and if
-* JOBVS = 'V', LDVS >= N.
-*
-* RCONDE (output) REAL
-* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
-* condition number for the average of the selected eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) REAL
-* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
-* condition number for the selected right invariant subspace.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,3*N).
-* Also, if SENSE = 'E' or 'V' or 'B',
-* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
-* selected eigenvalues computed by this routine. Note that
-* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
-* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
-* 'B' this may not be large enough.
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates upper bounds on the optimal sizes of the
-* arrays WORK and IWORK, returns these values as the first
-* entries of the WORK and IWORK arrays, and no error messages
-* related to LWORK or LIWORK are issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
-* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
-* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
-* may not be large enough.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates upper bounds on the optimal sizes of
-* the arrays WORK and IWORK, returns these values as the first
-* entries of the WORK and IWORK arrays, and no error messages
-* related to LWORK or LIWORK are issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
-* contain those eigenvalues which have converged; if
-* JOBVS = 'V', VS contains the transformation which
-* reduces A to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because some
-* eigenvalues were too close to separate (the problem
-* is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of some
-* complex eigenvalues so that leading eigenvalues in
-* the Schur form no longer satisfy SELECT=.TRUE. This
-* could also be caused by underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeev"></A>
- <H2>sgeev</H2>
-
- <PRE>
-USAGE:
- wr, wi, vl, vr, work, info, a = NumRu::Lapack.sgeev( jobvl, jobvr, a, lwork)
- or
- NumRu::Lapack.sgeev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEEV computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of A are computed.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* WR (output) REAL array, dimension (N)
-* WI (output) REAL array, dimension (N)
-* WR and WI contain the real and imaginary parts,
-* respectively, of the computed eigenvalues. Complex
-* conjugate pairs of eigenvalues appear consecutively
-* with the eigenvalue having the positive imaginary part
-* first.
-*
-* VL (output) REAL array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* If the j-th eigenvalue is real, then u(j) = VL(:,j),
-* the j-th column of VL.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
-* u(j+1) = VL(:,j) - i*VL(:,j+1).
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) REAL array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* If the j-th eigenvalue is real, then v(j) = VR(:,j),
-* the j-th column of VR.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
-* v(j+1) = VR(:,j) - i*VR(:,j+1).
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1; if
-* JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,3*N), and
-* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
-* performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors have been computed;
-* elements i+1:N of WR and WI contain eigenvalues which
-* have converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeevx"></A>
- <H2>sgeevx</H2>
-
- <PRE>
-USAGE:
- wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.sgeevx( balanc, jobvl, jobvr, sense, a, lwork)
- or
- NumRu::Lapack.sgeevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* Optionally also, it computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
-* (RCONDE), and reciprocal condition numbers for the right
-* eigenvectors (RCONDV).
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-* Balancing a matrix means permuting the rows and columns to make it
-* more nearly upper triangular, and applying a diagonal similarity
-* transformation D * A * D**(-1), where D is a diagonal matrix, to
-* make its rows and columns closer in norm and the condition numbers
-* of its eigenvalues and eigenvectors smaller. The computed
-* reciprocal condition numbers correspond to the balanced matrix.
-* Permuting rows and columns will not change the condition numbers
-* (in exact arithmetic) but diagonal scaling will. For further
-* explanation of balancing, see section 4.10.2 of the LAPACK
-* Users' Guide.
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Indicates how the input matrix should be diagonally scaled
-* and/or permuted to improve the conditioning of its
-* eigenvalues.
-* = 'N': Do not diagonally scale or permute;
-* = 'P': Perform permutations to make the matrix more nearly
-* upper triangular. Do not diagonally scale;
-* = 'S': Diagonally scale the matrix, i.e. replace A by
-* D*A*D**(-1), where D is a diagonal matrix chosen
-* to make the rows and columns of A more equal in
-* norm. Do not permute;
-* = 'B': Both diagonally scale and permute A.
-*
-* Computed reciprocal condition numbers will be for the matrix
-* after balancing and/or permuting. Permuting does not change
-* condition numbers (in exact arithmetic), but balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVL must = 'V'.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVR must = 'V'.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for eigenvalues only;
-* = 'V': Computed for right eigenvectors only;
-* = 'B': Computed for eigenvalues and right eigenvectors.
-*
-* If SENSE = 'E' or 'B', both left and right eigenvectors
-* must also be computed (JOBVL = 'V' and JOBVR = 'V').
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten. If JOBVL = 'V' or
-* JOBVR = 'V', A contains the real Schur form of the balanced
-* version of the input matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* WR (output) REAL array, dimension (N)
-* WI (output) REAL array, dimension (N)
-* WR and WI contain the real and imaginary parts,
-* respectively, of the computed eigenvalues. Complex
-* conjugate pairs of eigenvalues will appear consecutively
-* with the eigenvalue having the positive imaginary part
-* first.
-*
-* VL (output) REAL array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* If the j-th eigenvalue is real, then u(j) = VL(:,j),
-* the j-th column of VL.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
-* u(j+1) = VL(:,j) - i*VL(:,j+1).
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) REAL array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* If the j-th eigenvalue is real, then v(j) = VR(:,j),
-* the j-th column of VR.
-* If the j-th and (j+1)-st eigenvalues form a complex
-* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
-* v(j+1) = VR(:,j) - i*VR(:,j+1).
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values determined when A was
-* balanced. The balanced A(i,j) = 0 if I > J and
-* J = 1,...,ILO-1 or I = IHI+1,...,N.
-*
-* SCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* when balancing A. If P(j) is the index of the row and column
-* interchanged with row and column j, and D(j) is the scaling
-* factor applied to row and column j, then
-* SCALE(J) = P(J), for J = 1,...,ILO-1
-* = D(J), for J = ILO,...,IHI
-* = P(J) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) REAL
-* The one-norm of the balanced matrix (the maximum
-* of the sum of absolute values of elements of any column).
-*
-* RCONDE (output) REAL array, dimension (N)
-* RCONDE(j) is the reciprocal condition number of the j-th
-* eigenvalue.
-*
-* RCONDV (output) REAL array, dimension (N)
-* RCONDV(j) is the reciprocal condition number of the j-th
-* right eigenvector.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. If SENSE = 'N' or 'E',
-* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
-* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (2*N-2)
-* If SENSE = 'N' or 'E', not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors or condition numbers
-* have been computed; elements 1:ILO-1 and i+1:N of WR
-* and WI contain eigenvalues which have converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgegs"></A>
- <H2>sgegs</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgegs( jobvsl, jobvsr, a, b, lwork)
- or
- NumRu::Lapack.sgegs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine SGGES.
-*
-* SGEGS computes the eigenvalues, real Schur form, and, optionally,
-* left and or/right Schur vectors of a real matrix pair (A,B).
-* Given two square matrices A and B, the generalized real Schur
-* factorization has the form
-*
-* A = Q*S*Z**T, B = Q*T*Z**T
-*
-* where Q and Z are orthogonal matrices, T is upper triangular, and S
-* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal
-* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs
-* of eigenvalues of (A,B). The columns of Q are the left Schur vectors
-* and the columns of Z are the right Schur vectors.
-*
-* If only the eigenvalues of (A,B) are needed, the driver routine
-* SGEGV should be used instead. See SGEGV for a description of the
-* eigenvalues of the generalized nonsymmetric eigenvalue problem
-* (GNEP).
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors (returned in VSL).
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors (returned in VSR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the matrix A.
-* On exit, the upper quasi-triangular matrix S from the
-* generalized real Schur factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the matrix B.
-* On exit, the upper triangular matrix T from the generalized
-* real Schur factorization.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) REAL array, dimension (N)
-* The real parts of each scalar alpha defining an eigenvalue
-* of GNEP.
-*
-* ALPHAI (output) REAL array, dimension (N)
-* The imaginary parts of each scalar alpha defining an
-* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
-* eigenvalue is real; if positive, then the j-th and (j+1)-st
-* eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) = -ALPHAI(j).
-*
-* BETA (output) REAL array, dimension (N)
-* The scalars beta that define the eigenvalues of GNEP.
-* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
-* beta = BETA(j) represent the j-th eigenvalue of the matrix
-* pair (A,B), in one of the forms lambda = alpha/beta or
-* mu = beta/alpha. Since either lambda or mu may overflow,
-* they should not, in general, be computed.
-*
-* VSL (output) REAL array, dimension (LDVSL,N)
-* If JOBVSL = 'V', the matrix of left Schur vectors Q.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) REAL array, dimension (LDVSR,N)
-* If JOBVSR = 'V', the matrix of right Schur vectors Z.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,4*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:
-* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR
-* The optimal LWORK is 2*N + N*(NB+1).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
-* be correct for j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from SGGBAL
-* =N+2: error return from SGEQRF
-* =N+3: error return from SORMQR
-* =N+4: error return from SORGQR
-* =N+5: error return from SGGHRD
-* =N+6: error return from SHGEQZ (other than failed
-* iteration)
-* =N+7: error return from SGGBAK (computing VSL)
-* =N+8: error return from SGGBAK (computing VSR)
-* =N+9: error return from SLASCL (various places)
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgegv"></A>
- <H2>sgegv</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sgegv( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.sgegv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine SGGEV.
-*
-* SGEGV computes the eigenvalues and, optionally, the left and/or right
-* eigenvectors of a real matrix pair (A,B).
-* Given two square matrices A and B,
-* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
-* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
-* that
-*
-* A*x = lambda*B*x.
-*
-* An alternate form is to find the eigenvalues mu and corresponding
-* eigenvectors y such that
-*
-* mu*A*y = B*y.
-*
-* These two forms are equivalent with mu = 1/lambda and x = y if
-* neither lambda nor mu is zero. In order to deal with the case that
-* lambda or mu is zero or small, two values alpha and beta are returned
-* for each eigenvalue, such that lambda = alpha/beta and
-* mu = beta/alpha.
-*
-* The vectors x and y in the above equations are right eigenvectors of
-* the matrix pair (A,B). Vectors u and v satisfying
-*
-* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
-*
-* are left eigenvectors of (A,B).
-*
-* Note: this routine performs "full balancing" on A and B -- see
-* "Further Details", below.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors (returned
-* in VL).
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors (returned
-* in VR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the matrix A.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit A
-* contains the real Schur form of A from the generalized Schur
-* factorization of the pair (A,B) after balancing.
-* If no eigenvectors were computed, then only the diagonal
-* blocks from the Schur form will be correct. See SGGHRD and
-* SHGEQZ for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the matrix B.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
-* upper triangular matrix obtained from B in the generalized
-* Schur factorization of the pair (A,B) after balancing.
-* If no eigenvectors were computed, then only those elements of
-* B corresponding to the diagonal blocks from the Schur form of
-* A will be correct. See SGGHRD and SHGEQZ for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) REAL array, dimension (N)
-* The real parts of each scalar alpha defining an eigenvalue of
-* GNEP.
-*
-* ALPHAI (output) REAL array, dimension (N)
-* The imaginary parts of each scalar alpha defining an
-* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
-* eigenvalue is real; if positive, then the j-th and
-* (j+1)-st eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) = -ALPHAI(j).
-*
-* BETA (output) REAL array, dimension (N)
-* The scalars beta that define the eigenvalues of GNEP.
-*
-* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
-* beta = BETA(j) represent the j-th eigenvalue of the matrix
-* pair (A,B), in one of the forms lambda = alpha/beta or
-* mu = beta/alpha. Since either lambda or mu may overflow,
-* they should not, in general, be computed.
-*
-* VL (output) REAL array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored
-* in the columns of VL, in the same order as their eigenvalues.
-* If the j-th eigenvalue is real, then u(j) = VL(:,j).
-* If the j-th and (j+1)-st eigenvalues form a complex conjugate
-* pair, then
-* u(j) = VL(:,j) + i*VL(:,j+1)
-* and
-* u(j+1) = VL(:,j) - i*VL(:,j+1).
-*
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvectors
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) REAL array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors x(j) are stored
-* in the columns of VR, in the same order as their eigenvalues.
-* If the j-th eigenvalue is real, then x(j) = VR(:,j).
-* If the j-th and (j+1)-st eigenvalues form a complex conjugate
-* pair, then
-* x(j) = VR(:,j) + i*VR(:,j+1)
-* and
-* x(j+1) = VR(:,j) - i*VR(:,j+1).
-*
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvalues
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,8*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:
-* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;
-* The optimal LWORK is:
-* 2*N + MAX( 6*N, N*(NB+1) ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
-* should be correct for j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from SGGBAL
-* =N+2: error return from SGEQRF
-* =N+3: error return from SORMQR
-* =N+4: error return from SORGQR
-* =N+5: error return from SGGHRD
-* =N+6: error return from SHGEQZ (other than failed
-* iteration)
-* =N+7: error return from STGEVC
-* =N+8: error return from SGGBAK (computing VL)
-* =N+9: error return from SGGBAK (computing VR)
-* =N+10: error return from SLASCL (various calls)
-*
-
-* Further Details
-* ===============
-*
-* Balancing
-* ---------
-*
-* This driver calls SGGBAL to both permute and scale rows and columns
-* of A and B. The permutations PL and PR are chosen so that PL*A*PR
-* and PL*B*R will be upper triangular except for the diagonal blocks
-* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
-* possible. The diagonal scaling matrices DL and DR are chosen so
-* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
-* one (except for the elements that start out zero.)
-*
-* After the eigenvalues and eigenvectors of the balanced matrices
-* have been computed, SGGBAK transforms the eigenvectors back to what
-* they would have been (in perfect arithmetic) if they had not been
-* balanced.
-*
-* Contents of A and B on Exit
-* -------- -- - --- - -- ----
-*
-* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
-* both), then on exit the arrays A and B will contain the real Schur
-* form[*] of the "balanced" versions of A and B. If no eigenvectors
-* are computed, then only the diagonal blocks will be correct.
-*
-* [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations",
-* by Golub & van Loan, pub. by Johns Hopkins U. Press.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgehd2"></A>
- <H2>sgehd2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.sgehd2( ilo, ihi, a)
- or
- NumRu::Lapack.sgehd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEHD2 reduces a real general matrix A to upper Hessenberg form H by
-* an orthogonal similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to SGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= max(1,N).
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the n by n general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the orthogonal matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) REAL array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgehrd"></A>
- <H2>sgehrd</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.sgehrd( ilo, ihi, a, lwork)
- or
- NumRu::Lapack.sgehrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEHRD reduces a real general matrix A to upper Hessenberg form H by
-* an orthogonal similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to SGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the orthogonal matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) REAL array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
-* zero.
-*
-* WORK (workspace/output) REAL array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* This file is a slight modification of LAPACK-3.0's DGEHRD
-* subroutine incorporating improvements proposed by Quintana-Orti and
-* Van de Geijn (2006). (See DLAHR2.)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgejsv"></A>
- <H2>sgejsv</H2>
-
- <PRE>
-USAGE:
- sva, u, v, iwork, info, work = NumRu::Lapack.sgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work)
- or
- NumRu::Lapack.sgejsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-* SGEJSV computes the singular value decomposition (SVD) of a real M-by-N
-* matrix [A], where M >= N. The SVD of [A] is written as
-*
-* [A] = [U] * [SIGMA] * [V]^t,
-*
-* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N
-* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and
-* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are
-* the singular values of [A]. The columns of [U] and [V] are the left and
-* the right singular vectors of [A], respectively. The matrices [U] and [V]
-* are computed and stored in the arrays U and V, respectively. The diagonal
-* of [SIGMA] is computed and stored in the array SVA.
-*
-
-* Arguments
-* =========
-*
-* JOBA (input) CHARACTER*1
-* Specifies the level of accuracy:
-* = 'C': This option works well (high relative accuracy) if A = B * D,
-* with well-conditioned B and arbitrary diagonal matrix D.
-* The accuracy cannot be spoiled by COLUMN scaling. The
-* accuracy of the computed output depends on the condition of
-* B, and the procedure aims at the best theoretical accuracy.
-* The relative error max_{i=1:N}|d sigma_i| / sigma_i is
-* bounded by f(M,N)*epsilon* cond(B), independent of D.
-* The input matrix is preprocessed with the QRF with column
-* pivoting. This initial preprocessing and preconditioning by
-* a rank revealing QR factorization is common for all values of
-* JOBA. Additional actions are specified as follows:
-* = 'E': Computation as with 'C' with an additional estimate of the
-* condition number of B. It provides a realistic error bound.
-* = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings
-* D1, D2, and well-conditioned matrix C, this option gives
-* higher accuracy than the 'C' option. If the structure of the
-* input matrix is not known, and relative accuracy is
-* desirable, then this option is advisable. The input matrix A
-* is preprocessed with QR factorization with FULL (row and
-* column) pivoting.
-* = 'G' Computation as with 'F' with an additional estimate of the
-* condition number of B, where A=D*B. If A has heavily weighted
-* rows, then using this condition number gives too pessimistic
-* error bound.
-* = 'A': Small singular values are the noise and the matrix is treated
-* as numerically rank defficient. The error in the computed
-* singular values is bounded by f(m,n)*epsilon*||A||.
-* The computed SVD A = U * S * V^t restores A up to
-* f(m,n)*epsilon*||A||.
-* This gives the procedure the licence to discard (set to zero)
-* all singular values below N*epsilon*||A||.
-* = 'R': Similar as in 'A'. Rank revealing property of the initial
-* QR factorization is used do reveal (using triangular factor)
-* a gap sigma_{r+1} < epsilon * sigma_r in which case the
-* numerical RANK is declared to be r. The SVD is computed with
-* absolute error bounds, but more accurately than with 'A'.
-*
-* JOBU (input) CHARACTER*1
-* Specifies whether to compute the columns of U:
-* = 'U': N columns of U are returned in the array U.
-* = 'F': full set of M left sing. vectors is returned in the array U.
-* = 'W': U may be used as workspace of length M*N. See the description
-* of U.
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* Specifies whether to compute the matrix V:
-* = 'V': N columns of V are returned in the array V; Jacobi rotations
-* are not explicitly accumulated.
-* = 'J': N columns of V are returned in the array V, but they are
-* computed as the product of Jacobi rotations. This option is
-* allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.
-* = 'W': V may be used as workspace of length N*N. See the description
-* of V.
-* = 'N': V is not computed.
-*
-* JOBR (input) CHARACTER*1
-* Specifies the RANGE for the singular values. Issues the licence to
-* set to zero small positive singular values if they are outside
-* specified range. If A .NE. 0 is scaled so that the largest singular
-* value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues
-* the licence to kill columns of A whose norm in c*A is less than
-* SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN,
-* where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').
-* = 'N': Do not kill small columns of c*A. This option assumes that
-* BLAS and QR factorizations and triangular solvers are
-* implemented to work in that range. If the condition of A
-* is greater than BIG, use SGESVJ.
-* = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)]
-* (roughly, as described above). This option is recommended.
-* ===========================
-* For computing the singular values in the FULL range [SFMIN,BIG]
-* use SGESVJ.
-*
-* JOBT (input) CHARACTER*1
-* If the matrix is square then the procedure may determine to use
-* transposed A if A^t seems to be better with respect to convergence.
-* If the matrix is not square, JOBT is ignored. This is subject to
-* changes in the future.
-* The decision is based on two values of entropy over the adjoint
-* orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).
-* = 'T': transpose if entropy test indicates possibly faster
-* convergence of Jacobi process if A^t is taken as input. If A is
-* replaced with A^t, then the row pivoting is included automatically.
-* = 'N': do not speculate.
-* This option can be used to compute only the singular values, or the
-* full SVD (U, SIGMA and V). For only one set of singular vectors
-* (U or V), the caller should provide both U and V, as one of the
-* matrices is used as workspace if the matrix A is transposed.
-* The implementer can easily remove this constraint and make the
-* code more complicated. See the descriptions of U and V.
-*
-* JOBP (input) CHARACTER*1
-* Issues the licence to introduce structured perturbations to drown
-* denormalized numbers. This licence should be active if the
-* denormals are poorly implemented, causing slow computation,
-* especially in cases of fast convergence (!). For details see [1,2].
-* For the sake of simplicity, this perturbations are included only
-* when the full SVD or only the singular values are requested. The
-* implementer/user can easily add the perturbation for the cases of
-* computing one set of singular vectors.
-* = 'P': introduce perturbation
-* = 'N': do not perturb
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. M >= N >= 0.
-*
-* A (input/workspace) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* SVA (workspace/output) REAL array, dimension (N)
-* On exit,
-* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the
-* computation SVA contains Euclidean column norms of the
-* iterated matrices in the array A.
-* - For WORK(1) .NE. WORK(2): The singular values of A are
-* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if
-* sigma_max(A) overflows or if small singular values have been
-* saved from underflow by scaling the input matrix A.
-* - If JOBR='R' then some of the singular values may be returned
-* as exact zeros obtained by "set to zero" because they are
-* below the numerical rank threshold or are denormalized numbers.
-*
-* U (workspace/output) REAL array, dimension ( LDU, N )
-* If JOBU = 'U', then U contains on exit the M-by-N matrix of
-* the left singular vectors.
-* If JOBU = 'F', then U contains on exit the M-by-M matrix of
-* the left singular vectors, including an ONB
-* of the orthogonal complement of the Range(A).
-* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N),
-* then U is used as workspace if the procedure
-* replaces A with A^t. In that case, [V] is computed
-* in U as left singular vectors of A^t and then
-* copied back to the V array. This 'W' option is just
-* a reminder to the caller that in this case U is
-* reserved as workspace of length N*N.
-* If JOBU = 'N' U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U, LDU >= 1.
-* IF JOBU = 'U' or 'F' or 'W', then LDU >= M.
-*
-* V (workspace/output) REAL array, dimension ( LDV, N )
-* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of
-* the right singular vectors;
-* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N),
-* then V is used as workspace if the pprocedure
-* replaces A with A^t. In that case, [U] is computed
-* in V as right singular vectors of A^t and then
-* copied back to the U array. This 'W' option is just
-* a reminder to the caller that in this case V is
-* reserved as workspace of length N*N.
-* If JOBV = 'N' V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V, LDV >= 1.
-* If JOBV = 'V' or 'J' or 'W', then LDV >= N.
-*
-* WORK (workspace/output) REAL array, dimension at least LWORK.
-* On exit,
-* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such
-* that SCALE*SVA(1:N) are the computed singular values
-* of A. (See the description of SVA().)
-* WORK(2) = See the description of WORK(1).
-* WORK(3) = SCONDA is an estimate for the condition number of
-* column equilibrated A. (If JOBA .EQ. 'E' or 'G')
-* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).
-* It is computed using SPOCON. It holds
-* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA
-* where R is the triangular factor from the QRF of A.
-* However, if R is truncated and the numerical rank is
-* determined to be strictly smaller than N, SCONDA is
-* returned as -1, thus indicating that the smallest
-* singular values might be lost.
-*
-* If full SVD is needed, the following two condition numbers are
-* useful for the analysis of the algorithm. They are provied for
-* a developer/implementer who is familiar with the details of
-* the method.
-*
-* WORK(4) = an estimate of the scaled condition number of the
-* triangular factor in the first QR factorization.
-* WORK(5) = an estimate of the scaled condition number of the
-* triangular factor in the second QR factorization.
-* The following two parameters are computed if JOBT .EQ. 'T'.
-* They are provided for a developer/implementer who is familiar
-* with the details of the method.
-*
-* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy
-* of diag(A^t*A) / Trace(A^t*A) taken as point in the
-* probability simplex.
-* WORK(7) = the entropy of A*A^t.
-*
-* LWORK (input) INTEGER
-* Length of WORK to confirm proper allocation of work space.
-* LWORK depends on the job:
-*
-* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and
-* -> .. no scaled condition estimate required ( JOBE.EQ.'N'):
-* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.
-* For optimal performance (blocked code) the optimal value
-* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal
-* block size for xGEQP3/xGEQRF.
-* -> .. an estimate of the scaled condition number of A is
-* required (JOBA='E', 'G'). In this case, LWORK is the maximum
-* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7).
-*
-* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'),
-* -> the minimal requirement is LWORK >= max(2*N+M,7).
-* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),
-* where NB is the optimal block size.
-*
-* If SIGMA and the left singular vectors are needed
-* -> the minimal requirement is LWORK >= max(2*N+M,7).
-* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),
-* where NB is the optimal block size.
-*
-* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and
-* -> .. the singular vectors are computed without explicit
-* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N
-* -> .. in the iterative part, the Jacobi rotations are
-* explicitly accumulated (option, see the description of JOBV),
-* then the minimal requirement is LWORK >= max(M+3*N+N*N,7).
-* For better performance, if NB is the optimal block size,
-* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7).
-*
-* IWORK (workspace/output) INTEGER array, dimension M+3*N.
-* On exit,
-* IWORK(1) = the numerical rank determined after the initial
-* QR factorization with pivoting. See the descriptions
-* of JOBA and JOBR.
-* IWORK(2) = the number of the computed nonzero singular values
-* IWORK(3) = if nonzero, a warning message:
-* If IWORK(3).EQ.1 then some of the column norms of A
-* were denormalized floats. The requested high accuracy
-* is not warranted by the data.
-*
-* INFO (output) INTEGER
-* < 0 : if INFO = -i, then the i-th argument had an illegal value.
-* = 0 : successfull exit;
-* > 0 : SGEJSV did not converge in the maximal allowed number
-* of sweeps. The computed values may be inaccurate.
-*
-
-* Further Details
-* ===============
-*
-* SGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,
-* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an
-* additional row pivoting can be used as a preprocessor, which in some
-* cases results in much higher accuracy. An example is matrix A with the
-* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned
-* diagonal matrices and C is well-conditioned matrix. In that case, complete
-* pivoting in the first QR factorizations provides accuracy dependent on the
-* condition number of C, and independent of D1, D2. Such higher accuracy is
-* not completely understood theoretically, but it works well in practice.
-* Further, if A can be written as A = B*D, with well-conditioned B and some
-* diagonal D, then the high accuracy is guaranteed, both theoretically and
-* in software, independent of D. For more details see [1], [2].
-* The computational range for the singular values can be the full range
-* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS
-* & LAPACK routines called by SGEJSV are implemented to work in that range.
-* If that is not the case, then the restriction for safe computation with
-* the singular values in the range of normalized IEEE numbers is that the
-* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not
-* overflow. This code (SGEJSV) is best used in this restricted range,
-* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are
-* returned as zeros. See JOBR for details on this.
-* Further, this implementation is somewhat slower than the one described
-* in [1,2] due to replacement of some non-LAPACK components, and because
-* the choice of some tuning parameters in the iterative part (SGESVJ) is
-* left to the implementer on a particular machine.
-* The rank revealing QR factorization (in this code: SGEQP3) should be
-* implemented as in [3]. We have a new version of SGEQP3 under development
-* that is more robust than the current one in LAPACK, with a cleaner cut in
-* rank defficient cases. It will be available in the SIGMA library [4].
-* If M is much larger than N, it is obvious that the inital QRF with
-* column pivoting can be preprocessed by the QRF without pivoting. That
-* well known trick is not used in SGEJSV because in some cases heavy row
-* weighting can be treated with complete pivoting. The overhead in cases
-* M much larger than N is then only due to pivoting, but the benefits in
-* terms of accuracy have prevailed. The implementer/user can incorporate
-* this extra QRF step easily. The implementer can also improve data movement
-* (matrix transpose, matrix copy, matrix transposed copy) - this
-* implementation of SGEJSV uses only the simplest, naive data movement.
-*
-* Contributors
-*
-* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
-*
-* References
-*
-* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.
-* LAPACK Working note 169.
-* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.
-* LAPACK Working note 170.
-* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR
-* factorization software - a case study.
-* ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28.
-* LAPACK Working note 176.
-* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
-* QSVD, (H,K)-SVD computations.
-* Department of Mathematics, University of Zagreb, 2008.
-*
-* Bugs, examples and comments
-*
-* Please report all bugs and send interesting examples and/or comments to
-* drmac at math.hr. Thank you.
-*
-* ===========================================================================
-*
-* .. Local Parameters ..
- REAL ZERO, ONE
- PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
-* ..
-* .. Local Scalars ..
- REAL AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK,
- & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM,
- & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC
- INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING
- LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC,
- & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN,
- & NOSCAL, ROWPIV, RSVEC, TRANSP
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, ALOG, AMAX1, AMIN1, FLOAT,
- & MAX0, MIN0, NINT, SIGN, SQRT
-* ..
-* .. External Functions ..
- REAL SLAMCH, SNRM2
- INTEGER ISAMAX
- LOGICAL LSAME
- EXTERNAL ISAMAX, LSAME, SLAMCH, SNRM2
-* ..
-* .. External Subroutines ..
- EXTERNAL SCOPY, SGELQF, SGEQP3, SGEQRF, SLACPY, SLASCL,
- & SLASET, SLASSQ, SLASWP, SORGQR, SORMLQ,
- & SORMQR, SPOCON, SSCAL, SSWAP, STRSM, XERBLA
-*
- EXTERNAL SGESVJ
-* ..
-*
-* Test the input arguments
-*
- LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' )
- JRACC = LSAME( JOBV, 'J' )
- RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC
- ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' )
- L2RANK = LSAME( JOBA, 'R' )
- L2ABER = LSAME( JOBA, 'A' )
- ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' )
- L2TRAN = LSAME( JOBT, 'T' )
- L2KILL = LSAME( JOBR, 'R' )
- DEFR = LSAME( JOBR, 'N' )
- L2PERT = LSAME( JOBP, 'P' )
-*
- IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR.
- & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN
- INFO = - 1
- ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR.
- & LSAME( JOBU, 'W' )) ) THEN
- INFO = - 2
- ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR.
- & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN
- INFO = - 3
- ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN
- INFO = - 4
- ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN
- INFO = - 5
- ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN
- INFO = - 6
- ELSE IF ( M .LT. 0 ) THEN
- INFO = - 7
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN
- INFO = - 8
- ELSE IF ( LDA .LT. M ) THEN
- INFO = - 10
- ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN
- INFO = - 13
- ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN
- INFO = - 14
- ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND.
- & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR.
- & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND.
- & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR.
- & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.
- & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.
- & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N))
- & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N)))
- & THEN
- INFO = - 17
- ELSE
-* #:)
- INFO = 0
- END IF
-*
- IF ( INFO .NE. 0 ) THEN
-* #:(
- CALL XERBLA( 'SGEJSV', - INFO )
- END IF
-*
-* Quick return for void matrix (Y3K safe)
-* #:)
- IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN
-*
-* Determine whether the matrix U should be M x N or M x M
-*
- IF ( LSVEC ) THEN
- N1 = N
- IF ( LSAME( JOBU, 'F' ) ) N1 = M
- END IF
-*
-* Set numerical parameters
-*
-*! NOTE: Make sure SLAMCH() does not fail on the target architecture.
-*
- EPSLN = SLAMCH('Epsilon')
- SFMIN = SLAMCH('SafeMinimum')
- SMALL = SFMIN / EPSLN
- BIG = SLAMCH('O')
-*
-* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N
-*
-*(!) If necessary, scale SVA() to protect the largest norm from
-* overflow. It is possible that this scaling pushes the smallest
-* column norm left from the underflow threshold (extreme case).
-*
- SCALEM = ONE / SQRT(FLOAT(M)*FLOAT(N))
- NOSCAL = .TRUE.
- GOSCAL = .TRUE.
- DO 1874 p = 1, N
- AAPP = ZERO
- AAQQ = ONE
- CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 9
- CALL XERBLA( 'SGEJSV', -INFO )
- RETURN
- END IF
- AAQQ = SQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN
- SVA(p) = AAPP * AAQQ
- ELSE
- NOSCAL = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALEM )
- IF ( GOSCAL ) THEN
- GOSCAL = .FALSE.
- CALL SSCAL( p-1, SCALEM, SVA, 1 )
- END IF
- END IF
- 1874 CONTINUE
-*
- IF ( NOSCAL ) SCALEM = ONE
-*
- AAPP = ZERO
- AAQQ = BIG
- DO 4781 p = 1, N
- AAPP = AMAX1( AAPP, SVA(p) )
- IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( AAQQ, SVA(p) )
- 4781 CONTINUE
-*
-* Quick return for zero M x N matrix
-* #:)
- IF ( AAPP .EQ. ZERO ) THEN
- IF ( LSVEC ) CALL SLASET( 'G', M, N1, ZERO, ONE, U, LDU )
- IF ( RSVEC ) CALL SLASET( 'G', N, N, ZERO, ONE, V, LDV )
- WORK(1) = ONE
- WORK(2) = ONE
- IF ( ERREST ) WORK(3) = ONE
- IF ( LSVEC .AND. RSVEC ) THEN
- WORK(4) = ONE
- WORK(5) = ONE
- END IF
- IF ( L2TRAN ) THEN
- WORK(6) = ZERO
- WORK(7) = ZERO
- END IF
- IWORK(1) = 0
- IWORK(2) = 0
- RETURN
- END IF
-*
-* Issue warning if denormalized column norms detected. Override the
-* high relative accuracy request. Issue licence to kill columns
-* (set them to zero) whose norm is less than sigma_max / BIG (roughly).
-* #:(
- WARNING = 0
- IF ( AAQQ .LE. SFMIN ) THEN
- L2RANK = .TRUE.
- L2KILL = .TRUE.
- WARNING = 1
- END IF
-*
-* Quick return for one-column matrix
-* #:)
- IF ( N .EQ. 1 ) THEN
-*
- IF ( LSVEC ) THEN
- CALL SLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )
- CALL SLACPY( 'A', M, 1, A, LDA, U, LDU )
-* computing all M left singular vectors of the M x 1 matrix
- IF ( N1 .NE. N ) THEN
- CALL SGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )
- CALL SORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )
- CALL SCOPY( M, A(1,1), 1, U(1,1), 1 )
- END IF
- END IF
- IF ( RSVEC ) THEN
- V(1,1) = ONE
- END IF
- IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN
- SVA(1) = SVA(1) / SCALEM
- SCALEM = ONE
- END IF
- WORK(1) = ONE / SCALEM
- WORK(2) = ONE
- IF ( SVA(1) .NE. ZERO ) THEN
- IWORK(1) = 1
- IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN
- IWORK(2) = 1
- ELSE
- IWORK(2) = 0
- END IF
- ELSE
- IWORK(1) = 0
- IWORK(2) = 0
- END IF
- IF ( ERREST ) WORK(3) = ONE
- IF ( LSVEC .AND. RSVEC ) THEN
- WORK(4) = ONE
- WORK(5) = ONE
- END IF
- IF ( L2TRAN ) THEN
- WORK(6) = ZERO
- WORK(7) = ZERO
- END IF
- RETURN
-*
- END IF
-*
- TRANSP = .FALSE.
- L2TRAN = L2TRAN .AND. ( M .EQ. N )
-*
- AATMAX = -ONE
- AATMIN = BIG
- IF ( ROWPIV .OR. L2TRAN ) THEN
-*
-* Compute the row norms, needed to determine row pivoting sequence
-* (in the case of heavily row weighted A, row pivoting is strongly
-* advised) and to collect information needed to compare the
-* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).
-*
- IF ( L2TRAN ) THEN
- DO 1950 p = 1, M
- XSC = ZERO
- TEMP1 = ONE
- CALL SLASSQ( N, A(p,1), LDA, XSC, TEMP1 )
-* SLASSQ gets both the ell_2 and the ell_infinity norm
-* in one pass through the vector
- WORK(M+N+p) = XSC * SCALEM
- WORK(N+p) = XSC * (SCALEM*SQRT(TEMP1))
- AATMAX = AMAX1( AATMAX, WORK(N+p) )
- IF (WORK(N+p) .NE. ZERO) AATMIN = AMIN1(AATMIN,WORK(N+p))
- 1950 CONTINUE
- ELSE
- DO 1904 p = 1, M
- WORK(M+N+p) = SCALEM*ABS( A(p,ISAMAX(N,A(p,1),LDA)) )
- AATMAX = AMAX1( AATMAX, WORK(M+N+p) )
- AATMIN = AMIN1( AATMIN, WORK(M+N+p) )
- 1904 CONTINUE
- END IF
-*
- END IF
-*
-* For square matrix A try to determine whether A^t would be better
-* input for the preconditioned Jacobi SVD, with faster convergence.
-* The decision is based on an O(N) function of the vector of column
-* and row norms of A, based on the Shannon entropy. This should give
-* the right choice in most cases when the difference actually matters.
-* It may fail and pick the slower converging side.
-*
- ENTRA = ZERO
- ENTRAT = ZERO
- IF ( L2TRAN ) THEN
-*
- XSC = ZERO
- TEMP1 = ONE
- CALL SLASSQ( N, SVA, 1, XSC, TEMP1 )
- TEMP1 = ONE / TEMP1
-*
- ENTRA = ZERO
- DO 1113 p = 1, N
- BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1
- IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * ALOG(BIG1)
- 1113 CONTINUE
- ENTRA = - ENTRA / ALOG(FLOAT(N))
-*
-* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.
-* It is derived from the diagonal of A^t * A. Do the same with the
-* diagonal of A * A^t, compute the entropy of the corresponding
-* probability distribution. Note that A * A^t and A^t * A have the
-* same trace.
-*
- ENTRAT = ZERO
- DO 1114 p = N+1, N+M
- BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1
- IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * ALOG(BIG1)
- 1114 CONTINUE
- ENTRAT = - ENTRAT / ALOG(FLOAT(M))
-*
-* Analyze the entropies and decide A or A^t. Smaller entropy
-* usually means better input for the algorithm.
-*
- TRANSP = ( ENTRAT .LT. ENTRA )
-*
-* If A^t is better than A, transpose A.
-*
- IF ( TRANSP ) THEN
-* In an optimal implementation, this trivial transpose
-* should be replaced with faster transpose.
- DO 1115 p = 1, N - 1
- DO 1116 q = p + 1, N
- TEMP1 = A(q,p)
- A(q,p) = A(p,q)
- A(p,q) = TEMP1
- 1116 CONTINUE
- 1115 CONTINUE
- DO 1117 p = 1, N
- WORK(M+N+p) = SVA(p)
- SVA(p) = WORK(N+p)
- 1117 CONTINUE
- TEMP1 = AAPP
- AAPP = AATMAX
- AATMAX = TEMP1
- TEMP1 = AAQQ
- AAQQ = AATMIN
- AATMIN = TEMP1
- KILL = LSVEC
- LSVEC = RSVEC
- RSVEC = KILL
- IF ( LSVEC ) N1 = N
-*
- ROWPIV = .TRUE.
- END IF
-*
- END IF
-* END IF L2TRAN
-*
-* Scale the matrix so that its maximal singular value remains less
-* than SQRT(BIG) -- the matrix is scaled so that its maximal column
-* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep
-* SQRT(BIG) instead of BIG is the fact that SGEJSV uses LAPACK and
-* BLAS routines that, in some implementations, are not capable of
-* working in the full interval [SFMIN,BIG] and that they may provoke
-* overflows in the intermediate results. If the singular values spread
-* from SFMIN to BIG, then SGESVJ will compute them. So, in that case,
-* one should use SGESVJ instead of SGEJSV.
-*
- BIG1 = SQRT( BIG )
- TEMP1 = SQRT( BIG / FLOAT(N) )
-*
- CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR )
- IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN
- AAQQ = ( AAQQ / AAPP ) * TEMP1
- ELSE
- AAQQ = ( AAQQ * TEMP1 ) / AAPP
- END IF
- TEMP1 = TEMP1 * SCALEM
- CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR )
-*
-* To undo scaling at the end of this procedure, multiply the
-* computed singular values with USCAL2 / USCAL1.
-*
- USCAL1 = TEMP1
- USCAL2 = AAPP
-*
- IF ( L2KILL ) THEN
-* L2KILL enforces computation of nonzero singular values in
-* the restricted range of condition number of the initial A,
-* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN).
- XSC = SQRT( SFMIN )
- ELSE
- XSC = SMALL
-*
-* Now, if the condition number of A is too big,
-* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN,
-* as a precaution measure, the full SVD is computed using SGESVJ
-* with accumulated Jacobi rotations. This provides numerically
-* more robust computation, at the cost of slightly increased run
-* time. Depending on the concrete implementation of BLAS and LAPACK
-* (i.e. how they behave in presence of extreme ill-conditioning) the
-* implementor may decide to remove this switch.
- IF ( ( AAQQ.LT.SQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN
- JRACC = .TRUE.
- END IF
-*
- END IF
- IF ( AAQQ .LT. XSC ) THEN
- DO 700 p = 1, N
- IF ( SVA(p) .LT. XSC ) THEN
- CALL SLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA )
- SVA(p) = ZERO
- END IF
- 700 CONTINUE
- END IF
-*
-* Preconditioning using QR factorization with pivoting
-*
- IF ( ROWPIV ) THEN
-* Optional row permutation (Bjoerck row pivoting):
-* A result by Cox and Higham shows that the Bjoerck's
-* row pivoting combined with standard column pivoting
-* has similar effect as Powell-Reid complete pivoting.
-* The ell-infinity norms of A are made nonincreasing.
- DO 1952 p = 1, M - 1
- q = ISAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1
- IWORK(2*N+p) = q
- IF ( p .NE. q ) THEN
- TEMP1 = WORK(M+N+p)
- WORK(M+N+p) = WORK(M+N+q)
- WORK(M+N+q) = TEMP1
- END IF
- 1952 CONTINUE
- CALL SLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 )
- END IF
-*
-* End of the preparation phase (scaling, optional sorting and
-* transposing, optional flushing of small columns).
-*
-* Preconditioning
-*
-* If the full SVD is needed, the right singular vectors are computed
-* from a matrix equation, and for that we need theoretical analysis
-* of the Businger-Golub pivoting. So we use SGEQP3 as the first RR QRF.
-* In all other cases the first RR QRF can be chosen by other criteria
-* (eg speed by replacing global with restricted window pivoting, such
-* as in SGEQPX from TOMS # 782). Good results will be obtained using
-* SGEQPX with properly (!) chosen numerical parameters.
-* Any improvement of SGEQP3 improves overal performance of SGEJSV.
-*
-* A * P1 = Q1 * [ R1^t 0]^t:
- DO 1963 p = 1, N
-* .. all columns are free columns
- IWORK(p) = 0
- 1963 CONTINUE
- CALL SGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR )
-*
-* The upper triangular matrix R1 from the first QRF is inspected for
-* rank deficiency and possibilities for deflation, or possible
-* ill-conditioning. Depending on the user specified flag L2RANK,
-* the procedure explores possibilities to reduce the numerical
-* rank by inspecting the computed upper triangular factor. If
-* L2RANK or L2ABER are up, then SGEJSV will compute the SVD of
-* A + dA, where ||dA|| <= f(M,N)*EPSLN.
-*
- NR = 1
- IF ( L2ABER ) THEN
-* Standard absolute error bound suffices. All sigma_i with
-* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an
-* agressive enforcement of lower numerical rank by introducing a
-* backward error of the order of N*EPSLN*||A||.
- TEMP1 = SQRT(FLOAT(N))*EPSLN
- DO 3001 p = 2, N
- IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN
- NR = NR + 1
- ELSE
- GO TO 3002
- END IF
- 3001 CONTINUE
- 3002 CONTINUE
- ELSE IF ( L2RANK ) THEN
-* .. similarly as above, only slightly more gentle (less agressive).
-* Sudden drop on the diagonal of R1 is used as the criterion for
-* close-to-rank-defficient.
- TEMP1 = SQRT(SFMIN)
- DO 3401 p = 2, N
- IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR.
- & ( ABS(A(p,p)) .LT. SMALL ) .OR.
- & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402
- NR = NR + 1
- 3401 CONTINUE
- 3402 CONTINUE
-*
- ELSE
-* The goal is high relative accuracy. However, if the matrix
-* has high scaled condition number the relative accuracy is in
-* general not feasible. Later on, a condition number estimator
-* will be deployed to estimate the scaled condition number.
-* Here we just remove the underflowed part of the triangular
-* factor. This prevents the situation in which the code is
-* working hard to get the accuracy not warranted by the data.
- TEMP1 = SQRT(SFMIN)
- DO 3301 p = 2, N
- IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR.
- & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302
- NR = NR + 1
- 3301 CONTINUE
- 3302 CONTINUE
-*
- END IF
-*
- ALMORT = .FALSE.
- IF ( NR .EQ. N ) THEN
- MAXPRJ = ONE
- DO 3051 p = 2, N
- TEMP1 = ABS(A(p,p)) / SVA(IWORK(p))
- MAXPRJ = AMIN1( MAXPRJ, TEMP1 )
- 3051 CONTINUE
- IF ( MAXPRJ**2 .GE. ONE - FLOAT(N)*EPSLN ) ALMORT = .TRUE.
- END IF
-*
-*
- SCONDA = - ONE
- CONDR1 = - ONE
- CONDR2 = - ONE
-*
- IF ( ERREST ) THEN
- IF ( N .EQ. NR ) THEN
- IF ( RSVEC ) THEN
-* .. V is available as workspace
- CALL SLACPY( 'U', N, N, A, LDA, V, LDV )
- DO 3053 p = 1, N
- TEMP1 = SVA(IWORK(p))
- CALL SSCAL( p, ONE/TEMP1, V(1,p), 1 )
- 3053 CONTINUE
- CALL SPOCON( 'U', N, V, LDV, ONE, TEMP1,
- & WORK(N+1), IWORK(2*N+M+1), IERR )
- ELSE IF ( LSVEC ) THEN
-* .. U is available as workspace
- CALL SLACPY( 'U', N, N, A, LDA, U, LDU )
- DO 3054 p = 1, N
- TEMP1 = SVA(IWORK(p))
- CALL SSCAL( p, ONE/TEMP1, U(1,p), 1 )
- 3054 CONTINUE
- CALL SPOCON( 'U', N, U, LDU, ONE, TEMP1,
- & WORK(N+1), IWORK(2*N+M+1), IERR )
- ELSE
- CALL SLACPY( 'U', N, N, A, LDA, WORK(N+1), N )
- DO 3052 p = 1, N
- TEMP1 = SVA(IWORK(p))
- CALL SSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 )
- 3052 CONTINUE
-* .. the columns of R are scaled to have unit Euclidean lengths.
- CALL SPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1,
- & WORK(N+N*N+1), IWORK(2*N+M+1), IERR )
- END IF
- SCONDA = ONE / SQRT(TEMP1)
-* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).
-* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA
- ELSE
- SCONDA = - ONE
- END IF
- END IF
-*
- L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) )
-* If there is no violent scaling, artificial perturbation is not needed.
-*
-* Phase 3:
-*
- IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN
-*
-* Singular Values only
-*
-* .. transpose A(1:NR,1:N)
- DO 1946 p = 1, MIN0( N-1, NR )
- CALL SCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 )
- 1946 CONTINUE
-*
-* The following two DO-loops introduce small relative perturbation
-* into the strict upper triangle of the lower triangular matrix.
-* Small entries below the main diagonal are also changed.
-* This modification is useful if the computing environment does not
-* provide/allow FLUSH TO ZERO underflow, for it prevents many
-* annoying denormalized numbers in case of strongly scaled matrices.
-* The perturbation is structured so that it does not introduce any
-* new perturbation of the singular values, and it does not destroy
-* the job done by the preconditioner.
-* The licence for this perturbation is in the variable L2PERT, which
-* should be .FALSE. if FLUSH TO ZERO underflow is active.
-*
- IF ( .NOT. ALMORT ) THEN
-*
- IF ( L2PERT ) THEN
-* XSC = SQRT(SMALL)
- XSC = EPSLN / FLOAT(N)
- DO 4947 q = 1, NR
- TEMP1 = XSC*ABS(A(q,q))
- DO 4949 p = 1, N
- IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )
- & .OR. ( p .LT. q ) )
- & A(p,q) = SIGN( TEMP1, A(p,q) )
- 4949 CONTINUE
- 4947 CONTINUE
- ELSE
- CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA )
- END IF
-*
-* .. second preconditioning using the QR factorization
-*
- CALL SGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR )
-*
-* .. and transpose upper to lower triangular
- DO 1948 p = 1, NR - 1
- CALL SCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 )
- 1948 CONTINUE
-*
- END IF
-*
-* Row-cyclic Jacobi SVD algorithm with column pivoting
-*
-* .. again some perturbation (a "background noise") is added
-* to drown denormals
- IF ( L2PERT ) THEN
-* XSC = SQRT(SMALL)
- XSC = EPSLN / FLOAT(N)
- DO 1947 q = 1, NR
- TEMP1 = XSC*ABS(A(q,q))
- DO 1949 p = 1, NR
- IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )
- & .OR. ( p .LT. q ) )
- & A(p,q) = SIGN( TEMP1, A(p,q) )
- 1949 CONTINUE
- 1947 CONTINUE
- ELSE
- CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA )
- END IF
-*
-* .. and one-sided Jacobi rotations are started on a lower
-* triangular matrix (plus perturbation which is ignored in
-* the part which destroys triangular form (confusing?!))
-*
- CALL SGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,
- & N, V, LDV, WORK, LWORK, INFO )
-*
- SCALEM = WORK(1)
- NUMRANK = NINT(WORK(2))
-*
-*
- ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN
-*
-* -> Singular Values and Right Singular Vectors <-
-*
- IF ( ALMORT ) THEN
-*
-* .. in this case NR equals N
- DO 1998 p = 1, NR
- CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )
- 1998 CONTINUE
- CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
-*
- CALL SGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,
- & WORK, LWORK, INFO )
- SCALEM = WORK(1)
- NUMRANK = NINT(WORK(2))
-
- ELSE
-*
-* .. two more QR factorizations ( one QRF is not enough, two require
-* accumulated product of Jacobi rotations, three are perfect )
-*
- CALL SLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )
- CALL SGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)
- CALL SLACPY( 'Lower', NR, NR, A, LDA, V, LDV )
- CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
- CALL SGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
- DO 8998 p = 1, NR
- CALL SCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )
- 8998 CONTINUE
- CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
-*
- CALL SGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,
- & LDU, WORK(N+1), LWORK, INFO )
- SCALEM = WORK(N+1)
- NUMRANK = NINT(WORK(N+2))
- IF ( NR .LT. N ) THEN
- CALL SLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV )
- CALL SLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV )
- CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )
- END IF
-*
- CALL SORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK,
- & V, LDV, WORK(N+1), LWORK-N, IERR )
-*
- END IF
-*
- DO 8991 p = 1, N
- CALL SCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )
- 8991 CONTINUE
- CALL SLACPY( 'All', N, N, A, LDA, V, LDV )
-*
- IF ( TRANSP ) THEN
- CALL SLACPY( 'All', N, N, V, LDV, U, LDU )
- END IF
-*
- ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN
-*
-* .. Singular Values and Left Singular Vectors ..
-*
-* .. second preconditioning step to avoid need to accumulate
-* Jacobi rotations in the Jacobi iterations.
- DO 1965 p = 1, NR
- CALL SCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )
- 1965 CONTINUE
- CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )
-*
- CALL SGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
-*
- DO 1967 p = 1, NR - 1
- CALL SCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )
- 1967 CONTINUE
- CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )
-*
- CALL SGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A,
- & LDA, WORK(N+1), LWORK-N, INFO )
- SCALEM = WORK(N+1)
- NUMRANK = NINT(WORK(N+2))
-*
- IF ( NR .LT. M ) THEN
- CALL SLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )
- IF ( NR .LT. N1 ) THEN
- CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )
- CALL SLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )
- END IF
- END IF
-*
- CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
-*
- IF ( ROWPIV )
- & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
- DO 1974 p = 1, N1
- XSC = ONE / SNRM2( M, U(1,p), 1 )
- CALL SSCAL( M, XSC, U(1,p), 1 )
- 1974 CONTINUE
-*
- IF ( TRANSP ) THEN
- CALL SLACPY( 'All', N, N, U, LDU, V, LDV )
- END IF
-*
- ELSE
-*
-* .. Full SVD ..
-*
- IF ( .NOT. JRACC ) THEN
-*
- IF ( .NOT. ALMORT ) THEN
-*
-* Second Preconditioning Step (QRF [with pivoting])
-* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is
-* equivalent to an LQF CALL. Since in many libraries the QRF
-* seems to be better optimized than the LQF, we do explicit
-* transpose and use the QRF. This is subject to changes in an
-* optimized implementation of SGEJSV.
-*
- DO 1968 p = 1, NR
- CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )
- 1968 CONTINUE
-*
-* .. the following two loops perturb small entries to avoid
-* denormals in the second QR factorization, where they are
-* as good as zeros. This is done to avoid painfully slow
-* computation with denormals. The relative size of the perturbation
-* is a parameter that can be changed by the implementer.
-* This perturbation device will be obsolete on machines with
-* properly implemented arithmetic.
-* To switch it off, set L2PERT=.FALSE. To remove it from the
-* code, remove the action under L2PERT=.TRUE., leave the ELSE part.
-* The following two loops should be blocked and fused with the
-* transposed copy above.
-*
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL)
- DO 2969 q = 1, NR
- TEMP1 = XSC*ABS( V(q,q) )
- DO 2968 p = 1, N
- IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )
- & .OR. ( p .LT. q ) )
- & V(p,q) = SIGN( TEMP1, V(p,q) )
- IF ( p. LT. q ) V(p,q) = - V(p,q)
- 2968 CONTINUE
- 2969 CONTINUE
- ELSE
- CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
- END IF
-*
-* Estimate the row scaled condition number of R1
-* (If R1 is rectangular, N > NR, then the condition number
-* of the leading NR x NR submatrix is estimated.)
-*
- CALL SLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )
- DO 3950 p = 1, NR
- TEMP1 = SNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)
- CALL SSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)
- 3950 CONTINUE
- CALL SPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1,
- & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR)
- CONDR1 = ONE / SQRT(TEMP1)
-* .. here need a second oppinion on the condition number
-* .. then assume worst case scenario
-* R1 is OK for inverse <=> CONDR1 .LT. FLOAT(N)
-* more conservative <=> CONDR1 .LT. SQRT(FLOAT(N))
-*
- COND_OK = SQRT(FLOAT(NR))
-*[TP] COND_OK is a tuning parameter.
-
- IF ( CONDR1 .LT. COND_OK ) THEN
-* .. the second QRF without pivoting. Note: in an optimized
-* implementation, this QRF should be implemented as the QRF
-* of a lower triangular matrix.
-* R1^t = Q2 * R2
- CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
-*
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL)/EPSLN
- DO 3959 p = 2, NR
- DO 3958 q = 1, p - 1
- TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))
- IF ( ABS(V(q,p)) .LE. TEMP1 )
- & V(q,p) = SIGN( TEMP1, V(q,p) )
- 3958 CONTINUE
- 3959 CONTINUE
- END IF
-*
- IF ( NR .NE. N )
-* .. save ...
- & CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )
-*
-* .. this transposed copy should be better than naive
- DO 1969 p = 1, NR - 1
- CALL SCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 )
- 1969 CONTINUE
-*
- CONDR2 = CONDR1
-*
- ELSE
-*
-* .. ill-conditioned case: second QRF with pivoting
-* Note that windowed pivoting would be equaly good
-* numerically, and more run-time efficient. So, in
-* an optimal implementation, the next call to SGEQP3
-* should be replaced with eg. CALL SGEQPX (ACM TOMS #782)
-* with properly (carefully) chosen parameters.
-*
-* R1^t * P2 = Q2 * R2
- DO 3003 p = 1, NR
- IWORK(N+p) = 0
- 3003 CONTINUE
- CALL SGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),
- & WORK(2*N+1), LWORK-2*N, IERR )
-** CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),
-** & LWORK-2*N, IERR )
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL)
- DO 3969 p = 2, NR
- DO 3968 q = 1, p - 1
- TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))
- IF ( ABS(V(q,p)) .LE. TEMP1 )
- & V(q,p) = SIGN( TEMP1, V(q,p) )
- 3968 CONTINUE
- 3969 CONTINUE
- END IF
-*
- CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )
-*
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL)
- DO 8970 p = 2, NR
- DO 8971 q = 1, p - 1
- TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))
- V(p,q) = - SIGN( TEMP1, V(q,p) )
- 8971 CONTINUE
- 8970 CONTINUE
- ELSE
- CALL SLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV )
- END IF
-* Now, compute R2 = L3 * Q3, the LQ factorization.
- CALL SGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1),
- & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR )
-* .. and estimate the condition number
- CALL SLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )
- DO 4950 p = 1, NR
- TEMP1 = SNRM2( p, WORK(2*N+N*NR+NR+p), NR )
- CALL SSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )
- 4950 CONTINUE
- CALL SPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1,
- & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR )
- CONDR2 = ONE / SQRT(TEMP1)
-*
- IF ( CONDR2 .GE. COND_OK ) THEN
-* .. save the Householder vectors used for Q3
-* (this overwrittes the copy of R2, as it will not be
-* needed in this branch, but it does not overwritte the
-* Huseholder vectors of Q2.).
- CALL SLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N )
-* .. and the rest of the information on Q3 is in
-* WORK(2*N+N*NR+1:2*N+N*NR+N)
- END IF
-*
- END IF
-*
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL)
- DO 4968 q = 2, NR
- TEMP1 = XSC * V(q,q)
- DO 4969 p = 1, q - 1
-* V(p,q) = - SIGN( TEMP1, V(q,p) )
- V(p,q) = - SIGN( TEMP1, V(p,q) )
- 4969 CONTINUE
- 4968 CONTINUE
- ELSE
- CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV )
- END IF
-*
-* Second preconditioning finished; continue with Jacobi SVD
-* The input matrix is lower trinagular.
-*
-* Recover the right singular vectors as solution of a well
-* conditioned triangular matrix equation.
-*
- IF ( CONDR1 .LT. COND_OK ) THEN
-*
- CALL SGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U,
- & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO )
- SCALEM = WORK(2*N+N*NR+NR+1)
- NUMRANK = NINT(WORK(2*N+N*NR+NR+2))
- DO 3970 p = 1, NR
- CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )
- CALL SSCAL( NR, SVA(p), V(1,p), 1 )
- 3970 CONTINUE
-
-* .. pick the right matrix equation and solve it
-*
- IF ( NR. EQ. N ) THEN
-* :)) .. best case, R1 is inverted. The solution of this matrix
-* equation is Q2*V2 = the product of the Jacobi rotations
-* used in SGESVJ, premultiplied with the orthogonal matrix
-* from the second QR factorization.
- CALL STRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV )
- ELSE
-* .. R1 is well conditioned, but non-square. Transpose(R2)
-* is inverted to get the product of the Jacobi rotations
-* used in SGESVJ. The Q-factor from the second QR
-* factorization is then built in explicitly.
- CALL STRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),
- & N,V,LDV)
- IF ( NR .LT. N ) THEN
- CALL SLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)
- CALL SLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)
- CALL SLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)
- END IF
- CALL SORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR)
- END IF
-*
- ELSE IF ( CONDR2 .LT. COND_OK ) THEN
-*
-* :) .. the input matrix A is very likely a relative of
-* the Kahan matrix :)
-* The matrix R2 is inverted. The solution of the matrix equation
-* is Q3^T*V3 = the product of the Jacobi rotations (appplied to
-* the lower triangular L3 from the LQ factorization of
-* R2=L3*Q3), pre-multiplied with the transposed Q3.
- CALL SGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U,
- & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )
- SCALEM = WORK(2*N+N*NR+NR+1)
- NUMRANK = NINT(WORK(2*N+N*NR+NR+2))
- DO 3870 p = 1, NR
- CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )
- CALL SSCAL( NR, SVA(p), U(1,p), 1 )
- 3870 CONTINUE
- CALL STRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU)
-* .. apply the permutation from the second QR factorization
- DO 873 q = 1, NR
- DO 872 p = 1, NR
- WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)
- 872 CONTINUE
- DO 874 p = 1, NR
- U(p,q) = WORK(2*N+N*NR+NR+p)
- 874 CONTINUE
- 873 CONTINUE
- IF ( NR .LT. N ) THEN
- CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )
- CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )
- CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )
- END IF
- CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )
- ELSE
-* Last line of defense.
-* #:( This is a rather pathological case: no scaled condition
-* improvement after two pivoted QR factorizations. Other
-* possibility is that the rank revealing QR factorization
-* or the condition estimator has failed, or the COND_OK
-* is set very close to ONE (which is unnecessary). Normally,
-* this branch should never be executed, but in rare cases of
-* failure of the RRQR or condition estimator, the last line of
-* defense ensures that SGEJSV completes the task.
-* Compute the full SVD of L3 using SGESVJ with explicit
-* accumulation of Jacobi rotations.
- CALL SGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U,
- & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )
- SCALEM = WORK(2*N+N*NR+NR+1)
- NUMRANK = NINT(WORK(2*N+N*NR+NR+2))
- IF ( NR .LT. N ) THEN
- CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )
- CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )
- CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )
- END IF
- CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )
-*
- CALL SORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N,
- & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1),
- & LWORK-2*N-N*NR-NR, IERR )
- DO 773 q = 1, NR
- DO 772 p = 1, NR
- WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)
- 772 CONTINUE
- DO 774 p = 1, NR
- U(p,q) = WORK(2*N+N*NR+NR+p)
- 774 CONTINUE
- 773 CONTINUE
-*
- END IF
-*
-* Permute the rows of V using the (column) permutation from the
-* first QRF. Also, scale the columns to make them unit in
-* Euclidean norm. This applies to all cases.
-*
- TEMP1 = SQRT(FLOAT(N)) * EPSLN
- DO 1972 q = 1, N
- DO 972 p = 1, N
- WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)
- 972 CONTINUE
- DO 973 p = 1, N
- V(p,q) = WORK(2*N+N*NR+NR+p)
- 973 CONTINUE
- XSC = ONE / SNRM2( N, V(1,q), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL SSCAL( N, XSC, V(1,q), 1 )
- 1972 CONTINUE
-* At this moment, V contains the right singular vectors of A.
-* Next, assemble the left singular vector matrix U (M x N).
- IF ( NR .LT. M ) THEN
- CALL SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )
- IF ( NR .LT. N1 ) THEN
- CALL SLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)
- CALL SLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU)
- END IF
- END IF
-*
-* The Q matrix from the first QRF is built into the left singular
-* matrix U. This applies to all cases.
-*
- CALL SORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
-
-* The columns of U are normalized. The cost is O(M*N) flops.
- TEMP1 = SQRT(FLOAT(M)) * EPSLN
- DO 1973 p = 1, NR
- XSC = ONE / SNRM2( M, U(1,p), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL SSCAL( M, XSC, U(1,p), 1 )
- 1973 CONTINUE
-*
-* If the initial QRF is computed with row pivoting, the left
-* singular vectors must be adjusted.
-*
- IF ( ROWPIV )
- & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
- ELSE
-*
-* .. the initial matrix A has almost orthogonal columns and
-* the second QRF is not needed
-*
- CALL SLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL)
- DO 5970 p = 2, N
- TEMP1 = XSC * WORK( N + (p-1)*N + p )
- DO 5971 q = 1, p - 1
- WORK(N+(q-1)*N+p)=-SIGN(TEMP1,WORK(N+(p-1)*N+q))
- 5971 CONTINUE
- 5970 CONTINUE
- ELSE
- CALL SLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )
- END IF
-*
- CALL SGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA,
- & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO )
-*
- SCALEM = WORK(N+N*N+1)
- NUMRANK = NINT(WORK(N+N*N+2))
- DO 6970 p = 1, N
- CALL SCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )
- CALL SSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )
- 6970 CONTINUE
-*
- CALL STRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,
- & ONE, A, LDA, WORK(N+1), N )
- DO 6972 p = 1, N
- CALL SCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )
- 6972 CONTINUE
- TEMP1 = SQRT(FLOAT(N))*EPSLN
- DO 6971 p = 1, N
- XSC = ONE / SNRM2( N, V(1,p), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL SSCAL( N, XSC, V(1,p), 1 )
- 6971 CONTINUE
-*
-* Assemble the left singular vector matrix U (M x N).
-*
- IF ( N .LT. M ) THEN
- CALL SLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU )
- IF ( N .LT. N1 ) THEN
- CALL SLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU )
- CALL SLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )
- END IF
- END IF
- CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
- TEMP1 = SQRT(FLOAT(M))*EPSLN
- DO 6973 p = 1, N1
- XSC = ONE / SNRM2( M, U(1,p), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL SSCAL( M, XSC, U(1,p), 1 )
- 6973 CONTINUE
-*
- IF ( ROWPIV )
- & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
- END IF
-*
-* end of the >> almost orthogonal case << in the full SVD
-*
- ELSE
-*
-* This branch deploys a preconditioned Jacobi SVD with explicitly
-* accumulated rotations. It is included as optional, mainly for
-* experimental purposes. It does perfom well, and can also be used.
-* In this implementation, this branch will be automatically activated
-* if the condition number sigma_max(A) / sigma_min(A) is predicted
-* to be greater than the overflow threshold. This is because the
-* a posteriori computation of the singular vectors assumes robust
-* implementation of BLAS and some LAPACK procedures, capable of working
-* in presence of extreme values. Since that is not always the case, ...
-*
- DO 7968 p = 1, NR
- CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )
- 7968 CONTINUE
-*
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL/EPSLN)
- DO 5969 q = 1, NR
- TEMP1 = XSC*ABS( V(q,q) )
- DO 5968 p = 1, N
- IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )
- & .OR. ( p .LT. q ) )
- & V(p,q) = SIGN( TEMP1, V(p,q) )
- IF ( p. LT. q ) V(p,q) = - V(p,q)
- 5968 CONTINUE
- 5969 CONTINUE
- ELSE
- CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )
- END IF
-
- CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),
- & LWORK-2*N, IERR )
- CALL SLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )
-*
- DO 7969 p = 1, NR
- CALL SCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )
- 7969 CONTINUE
-
- IF ( L2PERT ) THEN
- XSC = SQRT(SMALL/EPSLN)
- DO 9970 q = 2, NR
- DO 9971 p = 1, q - 1
- TEMP1 = XSC * AMIN1(ABS(U(p,p)),ABS(U(q,q)))
- U(p,q) = - SIGN( TEMP1, U(q,p) )
- 9971 CONTINUE
- 9970 CONTINUE
- ELSE
- CALL SLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )
- END IF
-
- CALL SGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA,
- & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO )
- SCALEM = WORK(2*N+N*NR+1)
- NUMRANK = NINT(WORK(2*N+N*NR+2))
-
- IF ( NR .LT. N ) THEN
- CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )
- CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )
- CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )
- END IF
-
- CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),
- & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )
-*
-* Permute the rows of V using the (column) permutation from the
-* first QRF. Also, scale the columns to make them unit in
-* Euclidean norm. This applies to all cases.
-*
- TEMP1 = SQRT(FLOAT(N)) * EPSLN
- DO 7972 q = 1, N
- DO 8972 p = 1, N
- WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)
- 8972 CONTINUE
- DO 8973 p = 1, N
- V(p,q) = WORK(2*N+N*NR+NR+p)
- 8973 CONTINUE
- XSC = ONE / SNRM2( N, V(1,q), 1 )
- IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )
- & CALL SSCAL( N, XSC, V(1,q), 1 )
- 7972 CONTINUE
-*
-* At this moment, V contains the right singular vectors of A.
-* Next, assemble the left singular vector matrix U (M x N).
-*
- IF ( NR .LT. M ) THEN
- CALL SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )
- IF ( NR .LT. N1 ) THEN
- CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU )
- CALL SLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )
- END IF
- END IF
-*
- CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,
- & LDU, WORK(N+1), LWORK-N, IERR )
-*
- IF ( ROWPIV )
- & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )
-*
-*
- END IF
- IF ( TRANSP ) THEN
-* .. swap U and V because the procedure worked on A^t
- DO 6974 p = 1, N
- CALL SSWAP( N, U(1,p), 1, V(1,p), 1 )
- 6974 CONTINUE
- END IF
-*
- END IF
-* end of the full SVD
-*
-* Undo scaling, if necessary (and possible)
-*
- IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN
- CALL SLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR )
- USCAL1 = ONE
- USCAL2 = ONE
- END IF
-*
- IF ( NR .LT. N ) THEN
- DO 3004 p = NR+1, N
- SVA(p) = ZERO
- 3004 CONTINUE
- END IF
-*
- WORK(1) = USCAL2 * SCALEM
- WORK(2) = USCAL1
- IF ( ERREST ) WORK(3) = SCONDA
- IF ( LSVEC .AND. RSVEC ) THEN
- WORK(4) = CONDR1
- WORK(5) = CONDR2
- END IF
- IF ( L2TRAN ) THEN
- WORK(6) = ENTRA
- WORK(7) = ENTRAT
- END IF
-*
- IWORK(1) = NR
- IWORK(2) = NUMRANK
- IWORK(3) = WARNING
-*
- RETURN
-* ..
-* .. END OF SGEJSV
-* ..
- END
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgelq2"></A>
- <H2>sgelq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.sgelq2( a)
- or
- NumRu::Lapack.sgelq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGELQ2 computes an LQ factorization of a real m by n matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m by min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) REAL array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgelqf"></A>
- <H2>sgelqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.sgelqf( m, a, lwork)
- or
- NumRu::Lapack.sgelqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGELQF computes an LQ factorization of a real M-by-N matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL SGELQ2, SLARFB, SLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgels"></A>
- <H2>sgels</H2>
-
- <PRE>
-USAGE:
- work, info, a, b = NumRu::Lapack.sgels( trans, m, a, b, lwork)
- or
- NumRu::Lapack.sgels # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGELS solves overdetermined or underdetermined real linear systems
-* involving an M-by-N matrix A, or its transpose, using a QR or LQ
-* factorization of A. It is assumed that A has full rank.
-*
-* The following options are provided:
-*
-* 1. If TRANS = 'N' and m >= n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A*X ||.
-*
-* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
-* an underdetermined system A * X = B.
-*
-* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
-* an undetermined system A**T * X = B.
-*
-* 4. If TRANS = 'T' and m < n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A**T * X ||.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N': the linear system involves A;
-* = 'T': the linear system involves A**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of the matrices B and X. NRHS >=0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if M >= N, A is overwritten by details of its QR
-* factorization as returned by SGEQRF;
-* if M < N, A is overwritten by details of its LQ
-* factorization as returned by SGELQF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the matrix B of right hand side vectors, stored
-* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
-* if TRANS = 'T'.
-* On exit, if INFO = 0, B is overwritten by the solution
-* vectors, stored columnwise:
-* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
-* squares solution vectors; the residual sum of squares for the
-* solution in each column is given by the sum of squares of
-* elements N+1 to M in that column;
-* if TRANS = 'N' and m < n, rows 1 to N of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'T' and m < n, rows 1 to M of B contain the
-* least squares solution vectors; the residual sum of squares
-* for the solution in each column is given by the sum of
-* squares of elements M+1 to N in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= MAX(1,M,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= max( 1, MN + max( MN, NRHS ) ).
-* For optimal performance,
-* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
-* where MN = min(M,N) and NB is the optimum block size.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of the
-* triangular factor of A is zero, so that A does not have
-* full rank; the least squares solution could not be
-* computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgelsd"></A>
- <H2>sgelsd</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, b = NumRu::Lapack.sgelsd( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.sgelsd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGELSD computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize 2-norm(| b - A*x |)
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The problem is solved in three steps:
-* (1) Reduce the coefficient matrix A to bidiagonal form with
-* Householder transformations, reducing the original problem
-* into a "bidiagonal least squares problem" (BLS)
-* (2) Solve the BLS using a divide and conquer approach.
-* (3) Apply back all the Householder tranformations to solve
-* the original least squares problem.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution
-* matrix X. If m >= n and RANK = n, the residual
-* sum-of-squares for the solution in the i-th column is given
-* by the sum of squares of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,max(M,N)).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK must be at least 1.
-* The exact minimum amount of workspace needed depends on M,
-* N and NRHS. As long as LWORK is at least
-* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
-* if M is greater than or equal to N or
-* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
-* if M is less than N, the code will execute correctly.
-* SMLSIZ is returned by ILAENV and is equal to the maximum
-* size of the subproblems at the bottom of the computation
-* tree (usually about 25), and
-* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the array WORK and the
-* minimum size of the array IWORK, and returns these values as
-* the first entries of the WORK and IWORK arrays, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
-* where MINMN = MIN( M,N ).
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Ren-Cang Li, Computer Science Division, University of
-* California at Berkeley, USA
-* Osni Marques, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgelss"></A>
- <H2>sgelss</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, a, b = NumRu::Lapack.sgelss( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.sgelss # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGELSS computes the minimum norm solution to a real linear least
-* squares problem:
-*
-* Minimize 2-norm(| b - A*x |).
-*
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
-* X.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the first min(m,n) rows of A are overwritten with
-* its right singular vectors, stored rowwise.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution
-* matrix X. If m >= n and RANK = n, the residual
-* sum-of-squares for the solution in the i-th column is given
-* by the sum of squares of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,max(M,N)).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1, and also:
-* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgelsx"></A>
- <H2>sgelsx</H2>
-
- <PRE>
-USAGE:
- rank, info, a, b, jpvt = NumRu::Lapack.sgelsx( m, a, b, jpvt, rcond)
- or
- NumRu::Lapack.sgelsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine SGELSY.
-*
-* SGELSX computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by orthogonal transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of elements N+1:M in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
-* initial column, otherwise it is a free column. Before
-* the QR factorization of A, all initial columns are
-* permuted to the leading positions; only the remaining
-* free columns are moved as a result of column pivoting
-* during the factorization.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace) REAL array, dimension
-* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgelsy"></A>
- <H2>sgelsy</H2>
-
- <PRE>
-USAGE:
- rank, work, info, a, b, jpvt = NumRu::Lapack.sgelsy( m, a, b, jpvt, rcond, lwork)
- or
- NumRu::Lapack.sgelsy # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGELSY computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by orthogonal transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-* This routine is basically identical to the original xGELSX except
-* three differences:
-* o The call to the subroutine xGEQPF has been substituted by the
-* the call to the subroutine xGEQP3. This subroutine is a Blas-3
-* version of the QR factorization with column pivoting.
-* o Matrix B (the right hand side) is updated with Blas-3.
-* o The permutation of matrix B (the right hand side) is faster and
-* more simple.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of AP, otherwise column i is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of AP
-* was the k-th column of A.
-*
-* RCOND (input) REAL
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* The unblocked strategy requires that:
-* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
-* where MN = min( M, N ).
-* The block algorithm requires that:
-* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
-* where NB is an upper bound on the blocksize returned
-* by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,
-* and SORMRZ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeql2"></A>
- <H2>sgeql2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.sgeql2( m, a)
- or
- NumRu::Lapack.sgeql2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEQL2 computes a QL factorization of a real m by n matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the m by n lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* orthogonal matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeqlf"></A>
- <H2>sgeqlf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.sgeqlf( m, a, lwork)
- or
- NumRu::Lapack.sgeqlf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEQLF computes a QL factorization of a real M-by-N matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the M-by-N lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* orthogonal matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL SGEQL2, SLARFB, SLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeqp3"></A>
- <H2>sgeqp3</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a, jpvt = NumRu::Lapack.sgeqp3( m, a, jpvt, lwork)
- or
- NumRu::Lapack.sgeqp3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEQP3 computes a QR factorization with column pivoting of a
-* matrix A: A*P = Q*R using Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper trapezoidal matrix R; the elements below
-* the diagonal, together with the array TAU, represent the
-* orthogonal matrix Q as a product of min(M,N) elementary
-* reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(J)=0,
-* the J-th column of A is a free column.
-* On exit, if JPVT(J)=K, then the J-th column of A*P was the
-* the K-th column of A.
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 3*N+1.
-* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real/complex scalar, and v is a real/complex vector
-* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
-* A(i+1:m,i), and tau in TAU(i).
-*
-* Based on contributions by
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* X. Sun, Computer Science Dept., Duke University, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeqpf"></A>
- <H2>sgeqpf</H2>
-
- <PRE>
-USAGE:
- tau, info, a, jpvt = NumRu::Lapack.sgeqpf( m, a, jpvt)
- or
- NumRu::Lapack.sgeqpf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine SGEQP3.
-*
-* SGEQPF computes a QR factorization with column pivoting of a
-* real M-by-N matrix A: A*P = Q*R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper triangular matrix R; the elements
-* below the diagonal, together with the array TAU,
-* represent the orthogonal matrix Q as a product of
-* min(m,n) elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(i) = 0,
-* the i-th column of A is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(n)
-*
-* Each H(i) has the form
-*
-* H = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
-*
-* The matrix P is represented in jpvt as follows: If
-* jpvt(j) = i
-* then the jth column of P is the ith canonical unit vector.
-*
-* Partial column norm updating strategy modified by
-* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
-* University of Zagreb, Croatia.
-* June 2010
-* For more details see LAPACK Working Note 176.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeqr2"></A>
- <H2>sgeqr2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.sgeqr2( m, a)
- or
- NumRu::Lapack.sgeqr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEQR2 computes a QR factorization of a real m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeqr2p"></A>
- <H2>sgeqr2p</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.sgeqr2p( m, a)
- or
- NumRu::Lapack.sgeqr2p # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEQR2P computes a QR factorization of a real m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeqrf"></A>
- <H2>sgeqrf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.sgeqrf( m, a, lwork)
- or
- NumRu::Lapack.sgeqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEQRF computes a QR factorization of a real M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL SGEQR2, SLARFB, SLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgeqrfp"></A>
- <H2>sgeqrfp</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.sgeqrfp( m, a, lwork)
- or
- NumRu::Lapack.sgeqrfp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGEQRFP computes a QR factorization of a real M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the orthogonal matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL SGEQR2P, SLARFB, SLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgerfs"></A>
- <H2>sgerfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.sgerfs( trans, a, af, ipiv, b, x)
- or
- NumRu::Lapack.sgerfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGERFS improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates for
-* the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) REAL array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by SGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from SGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgerfsx"></A>
- <H2>sgerfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.sgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.sgerfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGERFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) REAL array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by SGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from SGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed.
-* If R is accessed, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed.
-* If C is accessed, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgerq2"></A>
- <H2>sgerq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.sgerq2( a)
- or
- NumRu::Lapack.sgerq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGERQ2 computes an RQ factorization of a real m by n matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the m by n upper trapezoidal matrix R; the remaining
-* elements, with the array TAU, represent the orthogonal matrix
-* Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) REAL array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgerqf"></A>
- <H2>sgerqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.sgerqf( m, a, lwork)
- or
- NumRu::Lapack.sgerqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGERQF computes an RQ factorization of a real M-by-N matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R;
-* the remaining elements, with the array TAU, represent the
-* orthogonal matrix Q as a product of min(m,n) elementary
-* reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL SGERQ2, SLARFB, SLARFT, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgesc2"></A>
- <H2>sgesc2</H2>
-
- <PRE>
-USAGE:
- scale, rhs = NumRu::Lapack.sgesc2( a, rhs, ipiv, jpiv)
- or
- NumRu::Lapack.sgesc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
-
-* Purpose
-* =======
-*
-* SGESC2 solves a system of linear equations
-*
-* A * X = scale* RHS
-*
-* with a general N-by-N matrix A using the LU factorization with
-* complete pivoting computed by SGETC2.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* A (input) REAL array, dimension (LDA,N)
-* On entry, the LU part of the factorization of the n-by-n
-* matrix A computed by SGETC2: A = P * L * U * Q
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, N).
-*
-* RHS (input/output) REAL array, dimension (N).
-* On entry, the right hand side vector b.
-* On exit, the solution vector X.
-*
-* IPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* SCALE (output) REAL
-* On exit, SCALE contains the scale factor. SCALE is chosen
-* 0 <= SCALE <= 1 to prevent owerflow in the solution.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgesdd"></A>
- <H2>sgesdd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.sgesdd( jobz, m, a, lwork)
- or
- NumRu::Lapack.sgesdd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGESDD computes the singular value decomposition (SVD) of a real
-* M-by-N matrix A, optionally computing the left and right singular
-* vectors. If singular vectors are desired, it uses a
-* divide-and-conquer algorithm.
-*
-* The SVD is written
-*
-* A = U * SIGMA * transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
-* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns VT = V**T, not V.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U and all N rows of V**T are
-* returned in the arrays U and VT;
-* = 'S': the first min(M,N) columns of U and the first
-* min(M,N) rows of V**T are returned in the arrays U
-* and VT;
-* = 'O': If M >= N, the first N columns of U are overwritten
-* on the array A and all rows of V**T are returned in
-* the array VT;
-* otherwise, all columns of U are returned in the
-* array U and the first M rows of V**T are overwritten
-* in the array A;
-* = 'N': no columns of U or rows of V**T are computed.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBZ = 'O', A is overwritten with the first N columns
-* of U (the left singular vectors, stored
-* columnwise) if M >= N;
-* A is overwritten with the first M rows
-* of V**T (the right singular vectors, stored
-* rowwise) otherwise.
-* if JOBZ .ne. 'O', the contents of A are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) REAL array, dimension (LDU,UCOL)
-* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
-* UCOL = min(M,N) if JOBZ = 'S'.
-* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
-* orthogonal matrix U;
-* if JOBZ = 'S', U contains the first min(M,N) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
-*
-* VT (output) REAL array, dimension (LDVT,N)
-* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
-* N-by-N orthogonal matrix V**T;
-* if JOBZ = 'S', VT contains the first min(M,N) rows of
-* V**T (the right singular vectors, stored rowwise);
-* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
-* if JOBZ = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* If JOBZ = 'N',
-* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).
-* If JOBZ = 'O',
-* LWORK >= 3*min(M,N) +
-* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
-* If JOBZ = 'S' or 'A'
-* LWORK >= 3*min(M,N) +
-* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
-* For good performance, LWORK should generally be larger.
-* If LWORK = -1 but other input arguments are legal, WORK(1)
-* returns the optimal LWORK.
-*
-* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: SBDSDC did not converge, updating process failed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgesv"></A>
- <H2>sgesv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a, b = NumRu::Lapack.sgesv( a, b)
- or
- NumRu::Lapack.sgesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SGESV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as
-* A = P * L * U,
-* where P is a permutation matrix, L is unit lower triangular, and U is
-* upper triangular. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the N-by-N coefficient matrix A.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS matrix of right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL SGETRF, SGETRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgesvd"></A>
- <H2>sgesvd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.sgesvd( jobu, jobvt, m, a, lwork)
- or
- NumRu::Lapack.sgesvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGESVD computes the singular value decomposition (SVD) of a real
-* M-by-N matrix A, optionally computing the left and/or right singular
-* vectors. The SVD is written
-*
-* A = U * SIGMA * transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
-* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns V**T, not V.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U are returned in array U:
-* = 'S': the first min(m,n) columns of U (the left singular
-* vectors) are returned in the array U;
-* = 'O': the first min(m,n) columns of U (the left singular
-* vectors) are overwritten on the array A;
-* = 'N': no columns of U (no left singular vectors) are
-* computed.
-*
-* JOBVT (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix
-* V**T:
-* = 'A': all N rows of V**T are returned in the array VT;
-* = 'S': the first min(m,n) rows of V**T (the right singular
-* vectors) are returned in the array VT;
-* = 'O': the first min(m,n) rows of V**T (the right singular
-* vectors) are overwritten on the array A;
-* = 'N': no rows of V**T (no right singular vectors) are
-* computed.
-*
-* JOBVT and JOBU cannot both be 'O'.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBU = 'O', A is overwritten with the first min(m,n)
-* columns of U (the left singular vectors,
-* stored columnwise);
-* if JOBVT = 'O', A is overwritten with the first min(m,n)
-* rows of V**T (the right singular vectors,
-* stored rowwise);
-* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
-* are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) REAL array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) REAL array, dimension (LDU,UCOL)
-* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
-* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
-* if JOBU = 'S', U contains the first min(m,n) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBU = 'N' or 'O', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBU = 'S' or 'A', LDU >= M.
-*
-* VT (output) REAL array, dimension (LDVT,N)
-* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
-* V**T;
-* if JOBVT = 'S', VT contains the first min(m,n) rows of
-* V**T (the right singular vectors, stored rowwise);
-* if JOBVT = 'N' or 'O', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
-* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
-* superdiagonal elements of an upper bidiagonal matrix B
-* whose diagonal is in S (not necessarily sorted). B
-* satisfies A = U * B * VT, so it has the same singular values
-* as A, and singular vectors related by U and VT.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if SBDSQR did not converge, INFO specifies how many
-* superdiagonals of an intermediate bidiagonal form B
-* did not converge to zero. See the description of WORK
-* above for details.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgesvj"></A>
- <H2>sgesvj</H2>
-
- <PRE>
-USAGE:
- sva, info, a, v, work = NumRu::Lapack.sgesvj( joba, jobu, jobv, m, a, mv, v, work)
- or
- NumRu::Lapack.sgesvj # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGESVJ computes the singular value decomposition (SVD) of a real
-* M-by-N matrix A, where M >= N. The SVD of A is written as
-* [++] [xx] [x0] [xx]
-* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]
-* [++] [xx]
-* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal
-* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements
-* of SIGMA are the singular values of A. The columns of U and V are the
-* left and the right singular vectors of A, respectively.
-*
-* Further Details
-* ~~~~~~~~~~~~~~~
-* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane
-* rotations. The rotations are implemented as fast scaled rotations of
-* Anda and Park [1]. In the case of underflow of the Jacobi angle, a
-* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses
-* column interchanges of de Rijk [2]. The relative accuracy of the computed
-* singular values and the accuracy of the computed singular vectors (in
-* angle metric) is as guaranteed by the theory of Demmel and Veselic [3].
-* The condition number that determines the accuracy in the full rank case
-* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the
-* spectral condition number. The best performance of this Jacobi SVD
-* procedure is achieved if used in an accelerated version of Drmac and
-* Veselic [5,6], and it is the kernel routine in the SIGMA library [7].
-* Some tunning parameters (marked with [TP]) are available for the
-* implementer.
-* The computational range for the nonzero singular values is the machine
-* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even
-* denormalized singular values can be computed with the corresponding
-* gradual loss of accurate digits.
-*
-* Contributors
-* ~~~~~~~~~~~~
-* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
-*
-* References
-* ~~~~~~~~~~
-* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.
-* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.
-* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the
-* singular value decomposition on a vector computer.
-* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.
-* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.
-* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular
-* value computation in floating point arithmetic.
-* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.
-* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.
-* LAPACK Working note 169.
-* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.
-* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.
-* LAPACK Working note 170.
-* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,
-* QSVD, (H,K)-SVD computations.
-* Department of Mathematics, University of Zagreb, 2008.
-*
-* Bugs, Examples and Comments
-* ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Please report all bugs and send interesting test examples and comments to
-* drmac at math.hr. Thank you.
-*
-
-* Arguments
-* =========
-*
-* JOBA (input) CHARACTER* 1
-* Specifies the structure of A.
-* = 'L': The input matrix A is lower triangular;
-* = 'U': The input matrix A is upper triangular;
-* = 'G': The input matrix A is general M-by-N matrix, M >= N.
-*
-* JOBU (input) CHARACTER*1
-* Specifies whether to compute the left singular vectors
-* (columns of U):
-* = 'U': The left singular vectors corresponding to the nonzero
-* singular values are computed and returned in the leading
-* columns of A. See more details in the description of A.
-* The default numerical orthogonality threshold is set to
-* approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E').
-* = 'C': Analogous to JOBU='U', except that user can control the
-* level of numerical orthogonality of the computed left
-* singular vectors. TOL can be set to TOL = CTOL*EPS, where
-* CTOL is given on input in the array WORK.
-* No CTOL smaller than ONE is allowed. CTOL greater
-* than 1 / EPS is meaningless. The option 'C'
-* can be used if M*EPS is satisfactory orthogonality
-* of the computed left singular vectors, so CTOL=M could
-* save few sweeps of Jacobi rotations.
-* See the descriptions of A and WORK(1).
-* = 'N': The matrix U is not computed. However, see the
-* description of A.
-*
-* JOBV (input) CHARACTER*1
-* Specifies whether to compute the right singular vectors, that
-* is, the matrix V:
-* = 'V' : the matrix V is computed and returned in the array V
-* = 'A' : the Jacobi rotations are applied to the MV-by-N
-* array V. In other words, the right singular vector
-* matrix V is not computed explicitly; instead it is
-* applied to an MV-by-N matrix initially stored in the
-* first MV rows of V.
-* = 'N' : the matrix V is not computed and the array V is not
-* referenced
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A.
-* M >= N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':
-* If INFO .EQ. 0 :
-* RANKA orthonormal columns of U are returned in the
-* leading RANKA columns of the array A. Here RANKA <= N
-* is the number of computed singular values of A that are
-* above the underflow threshold SLAMCH('S'). The singular
-* vectors corresponding to underflowed or zero singular
-* values are not computed. The value of RANKA is returned
-* in the array WORK as RANKA=NINT(WORK(2)). Also see the
-* descriptions of SVA and WORK. The computed columns of U
-* are mutually numerically orthogonal up to approximately
-* TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),
-* see the description of JOBU.
-* If INFO .GT. 0,
-* the procedure SGESVJ did not converge in the given number
-* of iterations (sweeps). In that case, the computed
-* columns of U may not be orthogonal up to TOL. The output
-* U (stored in A), SIGMA (given by the computed singular
-* values in SVA(1:N)) and V is still a decomposition of the
-* input matrix A in the sense that the residual
-* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.
-* If JOBU .EQ. 'N':
-* If INFO .EQ. 0 :
-* Note that the left singular vectors are 'for free' in the
-* one-sided Jacobi SVD algorithm. However, if only the
-* singular values are needed, the level of numerical
-* orthogonality of U is not an issue and iterations are
-* stopped when the columns of the iterated matrix are
-* numerically orthogonal up to approximately M*EPS. Thus,
-* on exit, A contains the columns of U scaled with the
-* corresponding singular values.
-* If INFO .GT. 0 :
-* the procedure SGESVJ did not converge in the given number
-* of iterations (sweeps).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* SVA (workspace/output) REAL array, dimension (N)
-* On exit,
-* If INFO .EQ. 0 :
-* depending on the value SCALE = WORK(1), we have:
-* If SCALE .EQ. ONE:
-* SVA(1:N) contains the computed singular values of A.
-* During the computation SVA contains the Euclidean column
-* norms of the iterated matrices in the array A.
-* If SCALE .NE. ONE:
-* The singular values of A are SCALE*SVA(1:N), and this
-* factored representation is due to the fact that some of the
-* singular values of A might underflow or overflow.
-*
-* If INFO .GT. 0 :
-* the procedure SGESVJ did not converge in the given number of
-* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
-*
-* MV (input) INTEGER
-* If JOBV .EQ. 'A', then the product of Jacobi rotations in SGESVJ
-* is applied to the first MV rows of V. See the description of JOBV.
-*
-* V (input/output) REAL array, dimension (LDV,N)
-* If JOBV = 'V', then V contains on exit the N-by-N matrix of
-* the right singular vectors;
-* If JOBV = 'A', then V contains the product of the computed right
-* singular vector matrix and the initial matrix in
-* the array V.
-* If JOBV = 'N', then V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V, LDV .GE. 1.
-* If JOBV .EQ. 'V', then LDV .GE. max(1,N).
-* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .
-*
-* WORK (input/workspace/output) REAL array, dimension max(4,M+N).
-* On entry,
-* If JOBU .EQ. 'C' :
-* WORK(1) = CTOL, where CTOL defines the threshold for convergence.
-* The process stops if all columns of A are mutually
-* orthogonal up to CTOL*EPS, EPS=SLAMCH('E').
-* It is required that CTOL >= ONE, i.e. it is not
-* allowed to force the routine to obtain orthogonality
-* below EPSILON.
-* On exit,
-* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
-* are the computed singular vcalues of A.
-* (See description of SVA().)
-* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero
-* singular values.
-* WORK(3) = NINT(WORK(3)) is the number of the computed singular
-* values that are larger than the underflow threshold.
-* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi
-* rotations needed for numerical convergence.
-* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.
-* This is useful information in cases when SGESVJ did
-* not converge, as it can be used to estimate whether
-* the output is stil useful and for post festum analysis.
-* WORK(6) = the largest absolute value over all sines of the
-* Jacobi rotation angles in the last sweep. It can be
-* useful for a post festum analysis.
-*
-* LWORK length of WORK, WORK >= MAX(6,M+N)
-*
-* INFO (output) INTEGER
-* = 0 : successful exit.
-* < 0 : if INFO = -i, then the i-th argument had an illegal value
-* > 0 : SGESVJ did not converge in the maximal allowed number (30)
-* of sweeps. The output may still be useful. See the
-* description of WORK.
-
-* =====================================================================
-*
-* .. Local Parameters ..
- REAL ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
- + TWO = 2.0E0 )
- INTEGER NSWEEP
- PARAMETER ( NSWEEP = 30 )
-* ..
-* .. Local Scalars ..
- REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
- + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,
- + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
- + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,
- + THSIGN, TOL
- INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
- + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,
- + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,
- + SWBAND
- LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
- + RSVEC, UCTOL, UPPER
-* ..
-* .. Local Arrays ..
- REAL FASTR( 5 )
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT
-* ..
-* .. External Functions ..
-* from BLAS
- REAL SDOT, SNRM2
- EXTERNAL SDOT, SNRM2
- INTEGER ISAMAX
- EXTERNAL ISAMAX
-* from LAPACK
- REAL SLAMCH
- EXTERNAL SLAMCH
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
-* from BLAS
- EXTERNAL SAXPY, SCOPY, SROTM, SSCAL, SSWAP
-* from LAPACK
- EXTERNAL SLASCL, SLASET, SLASSQ, XERBLA
-*
- EXTERNAL SGSVJ0, SGSVJ1
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgesvx"></A>
- <H2>sgesvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.sgesvx( fact, trans, a, af, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.sgesvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGESVX uses the LU factorization to compute the solution to a real
-* system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = P * L * U,
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) REAL array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by SGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) REAL array, dimension (4*N)
-* On exit, WORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If WORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* WORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization has
-* been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgesvxx"></A>
- <H2>sgesvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.sgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.sgesvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGESVXX uses the LU factorization to compute the solution to a
-* real system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. SGESVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* SGESVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* SGESVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what SGESVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose = Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) REAL array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by SGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) REAL array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In SGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgetc2"></A>
- <H2>sgetc2</H2>
-
- <PRE>
-USAGE:
- ipiv, jpiv, info, a = NumRu::Lapack.sgetc2( a)
- or
- NumRu::Lapack.sgetc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )
-
-* Purpose
-* =======
-*
-* SGETC2 computes an LU factorization with complete pivoting of the
-* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
-* where P and Q are permutation matrices, L is lower triangular with
-* unit diagonal elements and U is upper triangular.
-*
-* This is the Level 2 BLAS algorithm.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the n-by-n matrix A to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U*Q; the unit diagonal elements of L are not stored.
-* If U(k, k) appears to be less than SMIN, U(k, k) is given the
-* value of SMIN, i.e., giving a nonsingular perturbed system.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension(N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (output) INTEGER array, dimension(N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* > 0: if INFO = k, U(k, k) is likely to produce owerflow if
-* we try to solve for x in Ax = b. So U is perturbed to
-* avoid the overflow.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgetf2"></A>
- <H2>sgetf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.sgetf2( m, a)
- or
- NumRu::Lapack.sgetf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* SGETF2 computes an LU factorization of a general m-by-n matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the m by n matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgetrf"></A>
- <H2>sgetrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.sgetrf( m, a)
- or
- NumRu::Lapack.sgetrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* SGETRF computes an LU factorization of a general M-by-N matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgetri"></A>
- <H2>sgetri</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sgetri( a, ipiv, lwork)
- or
- NumRu::Lapack.sgetri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGETRI computes the inverse of a matrix using the LU factorization
-* computed by SGETRF.
-*
-* This method inverts U and then computes inv(A) by solving the system
-* inv(A)*L = inv(U) for inv(A).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the factors L and U from the factorization
-* A = P*L*U as computed by SGETRF.
-* On exit, if INFO = 0, the inverse of the original matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from SGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimal performance LWORK >= N*NB, where NB is
-* the optimal blocksize returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
-* singular and its inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgetrs"></A>
- <H2>sgetrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.sgetrs( trans, a, ipiv, b)
- or
- NumRu::Lapack.sgetrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SGETRS solves a system of linear equations
-* A * X = B or A' * X = B
-* with a general N-by-N matrix A using the LU factorization computed
-* by SGETRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A'* X = B (Transpose)
-* = 'C': A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by SGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from SGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sgg.html b/doc/sgg.html
deleted file mode 100644
index f899040..0000000
--- a/doc/sgg.html
+++ /dev/null
@@ -1,2140 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</H1>
- <UL>
- <LI><A HREF="#sggbak">sggbak</A> : </LI>
- <LI><A HREF="#sggbal">sggbal</A> : </LI>
- <LI><A HREF="#sgges">sgges</A> : </LI>
- <LI><A HREF="#sggesx">sggesx</A> : </LI>
- <LI><A HREF="#sggev">sggev</A> : </LI>
- <LI><A HREF="#sggevx">sggevx</A> : </LI>
- <LI><A HREF="#sggglm">sggglm</A> : </LI>
- <LI><A HREF="#sgghrd">sgghrd</A> : </LI>
- <LI><A HREF="#sgglse">sgglse</A> : </LI>
- <LI><A HREF="#sggqrf">sggqrf</A> : </LI>
- <LI><A HREF="#sggrqf">sggrqf</A> : </LI>
- <LI><A HREF="#sggsvd">sggsvd</A> : </LI>
- <LI><A HREF="#sggsvp">sggsvp</A> : </LI>
- </UL>
-
- <A NAME="sggbak"></A>
- <H2>sggbak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.sggbak( job, side, ilo, ihi, lscale, rscale, v)
- or
- NumRu::Lapack.sggbak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* SGGBAK forms the right or left eigenvectors of a real generalized
-* eigenvalue problem A*x = lambda*B*x, by backward transformation on
-* the computed eigenvectors of the balanced pair of matrices output by
-* SGGBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N': do nothing, return immediately;
-* = 'P': do backward transformation for permutation only;
-* = 'S': do backward transformation for scaling only;
-* = 'B': do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to SGGBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by SGGBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* LSCALE (input) REAL array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the left side of A and B, as returned by SGGBAL.
-*
-* RSCALE (input) REAL array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the right side of A and B, as returned by SGGBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) REAL array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by STGEVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the matrix V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. Ward, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFTV, RIGHTV
- INTEGER I, K
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SSCAL, SSWAP, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggbal"></A>
- <H2>sggbal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.sggbal( job, a, b)
- or
- NumRu::Lapack.sggbal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGBAL balances a pair of general real matrices (A,B). This
-* involves, first, permuting A and B by similarity transformations to
-* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
-* elements on the diagonal; and second, applying a diagonal similarity
-* transformation to rows and columns ILO to IHI to make the rows
-* and columns as close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrices, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors in the
-* generalized eigenvalue problem A*x = lambda*B*x.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A and B:
-* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
-* and RSCALE(I) = 1.0 for i = 1,...,N.
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB,N)
-* On entry, the input matrix B.
-* On exit, B is overwritten by the balanced matrix.
-* If JOB = 'N', B is not referenced.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If P(j) is the index of the
-* row interchanged with row j, and D(j)
-* is the scaling factor applied to row j, then
-* LSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If P(j) is the index of the
-* column interchanged with column j, and D(j)
-* is the scaling factor applied to column j, then
-* LSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* WORK (workspace) REAL array, dimension (lwork)
-* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
-* at least 1 when JOB = 'N' or 'P'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. WARD, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgges"></A>
- <H2>sgges</H2>
-
- <PRE>
-USAGE:
- sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b,c| ... }
- or
- NumRu::Lapack.sgges # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
-* the generalized eigenvalues, the generalized real Schur form (S,T),
-* optionally, the left and/or right matrices of Schur vectors (VSL and
-* VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* quasi-triangular matrix S and the upper triangular matrix T.The
-* leading columns of VSL and VSR then form an orthonormal basis for the
-* corresponding left and right eigenspaces (deflating subspaces).
-*
-* (If only the generalized eigenvalues are needed, use the driver
-* SGGEV instead, which is faster.)
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0 or both being zero.
-*
-* A pair of matrices (S,T) is in generalized real Schur form if T is
-* upper triangular with non-negative diagonal and S is block upper
-* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
-* to real generalized eigenvalues, while 2-by-2 blocks of S will be
-* "standardized" by making the corresponding elements of T have the
-* form:
-* [ a 0 ]
-* [ 0 b ]
-*
-* and the pair of corresponding 2-by-2 blocks in S and T will have a
-* complex conjugate pair of generalized eigenvalues.
-*
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG);
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
-* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
-* one of a complex conjugate pair of eigenvalues is selected,
-* then both complex eigenvalues are selected.
-*
-* Note that in the ill-conditioned case, a selected complex
-* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
-* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
-* in this case.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true. (Complex conjugate pairs for which
-* SELCTG is true for either eigenvalue count as 2.)
-*
-* ALPHAR (output) REAL array, dimension (N)
-* ALPHAI (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
-* and BETA(j),j=1,...,N are the diagonals of the complex Schur
-* form (S,T) that would result if the 2-by-2 diagonal blocks of
-* the real Schur form of (A,B) were further reduced to
-* triangular form using 2-by-2 complex unitary transformations.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio.
-* However, ALPHAR and ALPHAI will be always less than and
-* usually comparable with norm(A) in magnitude, and BETA always
-* less than and usually comparable with norm(B).
-*
-* VSL (output) REAL array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) REAL array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).
-* For good performance , LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
-* be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in SHGEQZ.
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering failed in STGSEN.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggesx"></A>
- <H2>sggesx</H2>
-
- <PRE>
-USAGE:
- sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b,c| ... }
- or
- NumRu::Lapack.sggesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGESX computes for a pair of N-by-N real nonsymmetric matrices
-* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
-* optionally, the left and/or right matrices of Schur vectors (VSL and
-* VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* quasi-triangular matrix S and the upper triangular matrix T; computes
-* a reciprocal condition number for the average of the selected
-* eigenvalues (RCONDE); and computes a reciprocal condition number for
-* the right and left deflating subspaces corresponding to the selected
-* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
-* an orthonormal basis for the corresponding left and right eigenspaces
-* (deflating subspaces).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0 or for both being zero.
-*
-* A pair of matrices (S,T) is in generalized real Schur form if T is
-* upper triangular with non-negative diagonal and S is block upper
-* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
-* to real generalized eigenvalues, while 2-by-2 blocks of S will be
-* "standardized" by making the corresponding elements of T have the
-* form:
-* [ a 0 ]
-* [ 0 b ]
-*
-* and the pair of corresponding 2-by-2 blocks in S and T will have a
-* complex conjugate pair of generalized eigenvalues.
-*
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG).
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
-* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
-* one of a complex conjugate pair of eigenvalues is selected,
-* then both complex eigenvalues are selected.
-* Note that a selected complex eigenvalue may no longer satisfy
-* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
-* since ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned), in this
-* case INFO is set to N+3.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N' : None are computed;
-* = 'E' : Computed for average of selected eigenvalues only;
-* = 'V' : Computed for selected deflating subspaces only;
-* = 'B' : Computed for both.
-* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true. (Complex conjugate pairs for which
-* SELCTG is true for either eigenvalue count as 2.)
-*
-* ALPHAR (output) REAL array, dimension (N)
-* ALPHAI (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
-* and BETA(j),j=1,...,N are the diagonals of the complex Schur
-* form (S,T) that would result if the 2-by-2 diagonal blocks of
-* the real Schur form of (A,B) were further reduced to
-* triangular form using 2-by-2 complex unitary transformations.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio.
-* However, ALPHAR and ALPHAI will be always less than and
-* usually comparable with norm(A) in magnitude, and BETA always
-* less than and usually comparable with norm(B).
-*
-* VSL (output) REAL array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) REAL array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* RCONDE (output) REAL array, dimension ( 2 )
-* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
-* reciprocal condition numbers for the average of the selected
-* eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) REAL array, dimension ( 2 )
-* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
-* reciprocal condition numbers for the selected deflating
-* subspaces.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
-* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
-* LWORK >= max( 8*N, 6*N+16 ).
-* Note that 2*SDIM*(N-SDIM) <= N*N/2.
-* Note also that an error is only returned if
-* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
-* this may not be large enough.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the bound on the optimal size of the WORK
-* array and the minimum size of the IWORK array, returns these
-* values as the first entries of the WORK and IWORK arrays, and
-* no error message related to LWORK or LIWORK is issued by
-* XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
-* LIWORK >= N+6.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the bound on the optimal size of the
-* WORK array and the minimum size of the IWORK array, returns
-* these values as the first entries of the WORK and IWORK
-* arrays, and no error message related to LWORK or LIWORK is
-* issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
-* be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in SHGEQZ
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering failed in STGSEN.
-*
-
-* Further Details
-* ===============
-*
-* An approximate (asymptotic) bound on the average absolute error of
-* the selected eigenvalues is
-*
-* EPS * norm((A, B)) / RCONDE( 1 ).
-*
-* An approximate (asymptotic) bound on the maximum angular error in
-* the computed deflating subspaces is
-*
-* EPS * norm((A, B)) / RCONDV( 2 ).
-*
-* See LAPACK User's Guide, section 4.11 for more information.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggev"></A>
- <H2>sggev</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sggev( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.sggev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
-* the generalized eigenvalues, and optionally, the left and/or right
-* generalized eigenvectors.
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* A * v(j) = lambda(j) * B * v(j).
-*
-* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* u(j)**H * A = lambda(j) * u(j)**H * B .
-*
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) REAL array, dimension (N)
-* ALPHAI (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. If ALPHAI(j) is zero, then
-* the j-th eigenvalue is real; if positive, then the j-th and
-* (j+1)-st eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio
-* alpha/beta. However, ALPHAR and ALPHAI will be always less
-* than and usually comparable with norm(A) in magnitude, and
-* BETA always less than and usually comparable with norm(B).
-*
-* VL (output) REAL array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* u(j) = VL(:,j), the j-th column of VL. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
-* Each eigenvector is scaled so the largest component has
-* abs(real part)+abs(imag. part)=1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) REAL array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* v(j) = VR(:,j), the j-th column of VR. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
-* Each eigenvector is scaled so the largest component has
-* abs(real part)+abs(imag. part)=1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,8*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
-* should be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in SHGEQZ.
-* =N+2: error return from STGEVC.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggevx"></A>
- <H2>sggevx</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggevx( balanc, jobvl, jobvr, sense, a, b, lwork)
- or
- NumRu::Lapack.sggevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
-* the generalized eigenvalues, and optionally, the left and/or right
-* generalized eigenvectors.
-*
-* Optionally also, it computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
-* the eigenvalues (RCONDE), and reciprocal condition numbers for the
-* right eigenvectors (RCONDV).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* A * v(j) = lambda(j) * B * v(j) .
-*
-* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-*
-* u(j)**H * A = lambda(j) * u(j)**H * B.
-*
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Specifies the balance option to be performed.
-* = 'N': do not diagonally scale or permute;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-* Computed reciprocal condition numbers will be for the
-* matrices after permuting and/or balancing. Permuting does
-* not change condition numbers (in exact arithmetic), but
-* balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': none are computed;
-* = 'E': computed for eigenvalues only;
-* = 'V': computed for eigenvectors only;
-* = 'B': computed for eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then A contains the first part of the real Schur
-* form of the "balanced" versions of the input A and B.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then B contains the second part of the real Schur
-* form of the "balanced" versions of the input A and B.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHAR (output) REAL array, dimension (N)
-* ALPHAI (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. If ALPHAI(j) is zero, then
-* the j-th eigenvalue is real; if positive, then the j-th and
-* (j+1)-st eigenvalues are a complex conjugate pair, with
-* ALPHAI(j+1) negative.
-*
-* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
-* may easily over- or underflow, and BETA(j) may even be zero.
-* Thus, the user should avoid naively computing the ratio
-* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
-* than and usually comparable with norm(A) in magnitude, and
-* BETA always less than and usually comparable with norm(B).
-*
-* VL (output) REAL array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* u(j) = VL(:,j), the j-th column of VL. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
-* Each eigenvector will be scaled so the largest component have
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) REAL array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order as
-* their eigenvalues. If the j-th eigenvalue is real, then
-* v(j) = VR(:,j), the j-th column of VR. If the j-th and
-* (j+1)-th eigenvalues form a complex conjugate pair, then
-* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
-* Each eigenvector will be scaled so the largest component have
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If PL(j) is the index of the
-* row interchanged with row j, and DL(j) is the scaling
-* factor applied to row j, then
-* LSCALE(j) = PL(j) for j = 1,...,ILO-1
-* = DL(j) for j = ILO,...,IHI
-* = PL(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) REAL array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If PR(j) is the index of the
-* column interchanged with column j, and DR(j) is the scaling
-* factor applied to column j, then
-* RSCALE(j) = PR(j) for j = 1,...,ILO-1
-* = DR(j) for j = ILO,...,IHI
-* = PR(j) for j = IHI+1,...,N
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) REAL
-* The one-norm of the balanced matrix A.
-*
-* BBNRM (output) REAL
-* The one-norm of the balanced matrix B.
-*
-* RCONDE (output) REAL array, dimension (N)
-* If SENSE = 'E' or 'B', the reciprocal condition numbers of
-* the eigenvalues, stored in consecutive elements of the array.
-* For a complex conjugate pair of eigenvalues two consecutive
-* elements of RCONDE are set to the same value. Thus RCONDE(j),
-* RCONDV(j), and the j-th columns of VL and VR all correspond
-* to the j-th eigenpair.
-* If SENSE = 'N' or 'V', RCONDE is not referenced.
-*
-* RCONDV (output) REAL array, dimension (N)
-* If SENSE = 'V' or 'B', the estimated reciprocal condition
-* numbers of the eigenvectors, stored in consecutive elements
-* of the array. For a complex eigenvector two consecutive
-* elements of RCONDV are set to the same value. If the
-* eigenvalues cannot be reordered to compute RCONDV(j),
-* RCONDV(j) is set to 0; this can only occur when the true
-* value would be very small anyway.
-* If SENSE = 'N' or 'E', RCONDV is not referenced.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
-* LWORK >= max(1,6*N).
-* If SENSE = 'E', LWORK >= max(1,10*N).
-* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (N+6)
-* If SENSE = 'E', IWORK is not referenced.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* If SENSE = 'N', BWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
-* should be correct for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in SHGEQZ.
-* =N+2: error return from STGEVC.
-*
-
-* Further Details
-* ===============
-*
-* Balancing a matrix pair (A,B) includes, first, permuting rows and
-* columns to isolate eigenvalues, second, applying diagonal similarity
-* transformation to the rows and columns to make the rows and columns
-* as close in norm as possible. The computed reciprocal condition
-* numbers correspond to the balanced matrix. Permuting rows and columns
-* will not change the condition numbers (in exact arithmetic) but
-* diagonal scaling will. For further explanation of balancing, see
-* section 4.11.1.2 of LAPACK Users' Guide.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
-*
-* An approximate error bound for the angle between the i-th computed
-* eigenvector VL(i) or VR(i) is given by
-*
-* EPS * norm(ABNRM, BBNRM) / DIF(i).
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see section 4.11 of LAPACK User's Guide.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggglm"></A>
- <H2>sggglm</H2>
-
- <PRE>
-USAGE:
- x, y, work, info, a, b, d = NumRu::Lapack.sggglm( a, b, d, lwork)
- or
- NumRu::Lapack.sggglm # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGGLM solves a general Gauss-Markov linear model (GLM) problem:
-*
-* minimize || y ||_2 subject to d = A*x + B*y
-* x
-*
-* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
-* given N-vector. It is assumed that M <= N <= M+P, and
-*
-* rank(A) = M and rank( A B ) = N.
-*
-* Under these assumptions, the constrained equation is always
-* consistent, and there is a unique solution x and a minimal 2-norm
-* solution y, which is obtained using a generalized QR factorization
-* of the matrices (A, B) given by
-*
-* A = Q*(R), B = Q*T*Z.
-* (0)
-*
-* In particular, if matrix B is square nonsingular, then the problem
-* GLM is equivalent to the following weighted linear least squares
-* problem
-*
-* minimize || inv(B)*(d-A*x) ||_2
-* x
-*
-* where inv(B) denotes the inverse of B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. 0 <= M <= N.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= N-M.
-*
-* A (input/output) REAL array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the upper triangular part of the array A contains
-* the M-by-M upper triangular matrix R.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, D is the left hand side of the GLM equation.
-* On exit, D is destroyed.
-*
-* X (output) REAL array, dimension (M)
-* Y (output) REAL array, dimension (P)
-* On exit, X and Y are the solutions of the GLM problem.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N+M+P).
-* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* SGEQRF, SGERQF, SORMQR and SORMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with A in the
-* generalized QR factorization of the pair (A, B) is
-* singular, so that rank(A) < M; the least squares
-* solution could not be computed.
-* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
-* factor T associated with B in the generalized QR
-* factorization of the pair (A, B) is singular, so that
-* rank( A B ) < N; the least squares solution could not
-* be computed.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgghrd"></A>
- <H2>sgghrd</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.sgghrd( compq, compz, ilo, ihi, a, b, q, z)
- or
- NumRu::Lapack.sgghrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )
-
-* Purpose
-* =======
-*
-* SGGHRD reduces a pair of real matrices (A,B) to generalized upper
-* Hessenberg form using orthogonal transformations, where A is a
-* general matrix and B is upper triangular. The form of the
-* generalized eigenvalue problem is
-* A*x = lambda*B*x,
-* and B is typically made upper triangular by computing its QR
-* factorization and moving the orthogonal matrix Q to the left side
-* of the equation.
-*
-* This subroutine simultaneously reduces A to a Hessenberg matrix H:
-* Q**T*A*Z = H
-* and transforms B to another upper triangular matrix T:
-* Q**T*B*Z = T
-* in order to reduce the problem to its standard form
-* H*y = lambda*T*y
-* where y = Z**T*x.
-*
-* The orthogonal matrices Q and Z are determined as products of Givens
-* rotations. They may either be formed explicitly, or they may be
-* postmultiplied into input matrices Q1 and Z1, so that
-*
-* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
-*
-* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
-*
-* If Q1 is the orthogonal matrix from the QR factorization of B in the
-* original equation A*x = lambda*B*x, then SGGHRD reduces the original
-* problem to generalized Hessenberg form.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': do not compute Q;
-* = 'I': Q is initialized to the unit matrix, and the
-* orthogonal matrix Q is returned;
-* = 'V': Q must contain an orthogonal matrix Q1 on entry,
-* and the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': do not compute Z;
-* = 'I': Z is initialized to the unit matrix, and the
-* orthogonal matrix Z is returned;
-* = 'V': Z must contain an orthogonal matrix Z1 on entry,
-* and the product Z1*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of A which are to be
-* reduced. It is assumed that A is already upper triangular
-* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
-* normally set by a previous call to SGGBAL; otherwise they
-* should be set to 1 and N respectively.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* rest is set to zero.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the N-by-N upper triangular matrix B.
-* On exit, the upper triangular matrix T = Q**T B Z. The
-* elements below the diagonal are set to zero.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) REAL array, dimension (LDQ, N)
-* On entry, if COMPQ = 'V', the orthogonal matrix Q1,
-* typically from the QR factorization of B.
-* On exit, if COMPQ='I', the orthogonal matrix Q, and if
-* COMPQ = 'V', the product Q1*Q.
-* Not referenced if COMPQ='N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
-*
-* Z (input/output) REAL array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix Z1.
-* On exit, if COMPZ='I', the orthogonal matrix Z, and if
-* COMPZ = 'V', the product Z1*Z.
-* Not referenced if COMPZ='N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z.
-* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* This routine reduces A to Hessenberg and B to triangular form by
-* an unblocked reduction, as described in _Matrix_Computations_,
-* by Golub and Van Loan (Johns Hopkins Press.)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgglse"></A>
- <H2>sgglse</H2>
-
- <PRE>
-USAGE:
- x, work, info, a, b, c, d = NumRu::Lapack.sgglse( a, b, c, d, lwork)
- or
- NumRu::Lapack.sgglse # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGLSE solves the linear equality-constrained least squares (LSE)
-* problem:
-*
-* minimize || c - A*x ||_2 subject to B*x = d
-*
-* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
-* M-vector, and d is a given P-vector. It is assumed that
-* P <= N <= M+P, and
-*
-* rank(B) = P and rank( (A) ) = N.
-* ( (B) )
-*
-* These conditions ensure that the LSE problem has a unique solution,
-* which is obtained using a generalized RQ factorization of the
-* matrices (B, A) given by
-*
-* B = (0 R)*Q, A = Z*T*Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. 0 <= P <= N <= M+P.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
-* contains the P-by-P upper triangular matrix R.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* C (input/output) REAL array, dimension (M)
-* On entry, C contains the right hand side vector for the
-* least squares part of the LSE problem.
-* On exit, the residual sum of squares for the solution
-* is given by the sum of squares of elements N-P+1 to M of
-* vector C.
-*
-* D (input/output) REAL array, dimension (P)
-* On entry, D contains the right hand side vector for the
-* constrained equation.
-* On exit, D is destroyed.
-*
-* X (output) REAL array, dimension (N)
-* On exit, X is the solution of the LSE problem.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M+N+P).
-* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* SGEQRF, SGERQF, SORMQR and SORMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with B in the
-* generalized RQ factorization of the pair (B, A) is
-* singular, so that rank(B) < P; the least squares
-* solution could not be computed.
-* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
-* T associated with A in the generalized RQ factorization
-* of the pair (B, A) is singular, so that
-* rank( (A) ) < N; the least squares solution could not
-* ( (B) )
-* be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggqrf"></A>
- <H2>sggqrf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.sggqrf( n, a, b, lwork)
- or
- NumRu::Lapack.sggqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGQRF computes a generalized QR factorization of an N-by-M matrix A
-* and an N-by-P matrix B:
-*
-* A = Q*R, B = Q*T*Z,
-*
-* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
-* matrix, and R and T assume one of the forms:
-*
-* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
-* ( 0 ) N-M N M-N
-* M
-*
-* where R11 is upper triangular, and
-*
-* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
-* P-N N ( T21 ) P
-* P
-*
-* where T12 or T21 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GQR factorization
-* of A and B implicitly gives the QR factorization of inv(B)*A:
-*
-* inv(B)*A = Z'*(inv(T)*R)
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* transpose of the matrix Z.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
-* upper triangular if N >= M); the elements below the diagonal,
-* with the array TAUA, represent the orthogonal matrix Q as a
-* product of min(N,M) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAUA (output) REAL array, dimension (min(N,M))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q (see Further Details).
-*
-* B (input/output) REAL array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)-th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T; the remaining
-* elements, with the array TAUB, represent the orthogonal
-* matrix Z as a product of elementary reflectors (see Further
-* Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* TAUB (output) REAL array, dimension (min(N,P))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Z (see Further Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the QR factorization
-* of an N-by-M matrix, NB2 is the optimal blocksize for the
-* RQ factorization of an N-by-P matrix, and NB3 is the optimal
-* blocksize for a call of SORMQR.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(n,m).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
-* and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine SORGQR.
-* To use Q to update another matrix, use LAPACK subroutine SORMQR.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(n,p).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a real scalar, and v is a real vector with
-* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
-* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine SORGRQ.
-* To use Z to update another matrix, use LAPACK subroutine SORMRQ.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL SGEQRF, SGERQF, SORMQR, XERBLA
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggrqf"></A>
- <H2>sggrqf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.sggrqf( m, p, a, b, lwork)
- or
- NumRu::Lapack.sggrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGRQF computes a generalized RQ factorization of an M-by-N matrix A
-* and a P-by-N matrix B:
-*
-* A = R*Q, B = Z*T*Q,
-*
-* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
-* matrix, and R and T assume one of the forms:
-*
-* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
-* N-M M ( R21 ) N
-* N
-*
-* where R12 or R21 is upper triangular, and
-*
-* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
-* ( 0 ) P-N P N-P
-* N
-*
-* where T11 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GRQ factorization
-* of A and B implicitly gives the RQ factorization of A*inv(B):
-*
-* A*inv(B) = (R*inv(T))*Z'
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* transpose of the matrix Z.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, if M <= N, the upper triangle of the subarray
-* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
-* if M > N, the elements on and above the (M-N)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R; the remaining
-* elements, with the array TAUA, represent the orthogonal
-* matrix Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAUA (output) REAL array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Q (see Further Details).
-*
-* B (input/output) REAL array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
-* upper triangular if P >= N); the elements below the diagonal,
-* with the array TAUB, represent the orthogonal matrix Z as a
-* product of elementary reflectors (see Further Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TAUB (output) REAL array, dimension (min(P,N))
-* The scalar factors of the elementary reflectors which
-* represent the orthogonal matrix Z (see Further Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the RQ factorization
-* of an M-by-N matrix, NB2 is the optimal blocksize for the
-* QR factorization of a P-by-N matrix, and NB3 is the optimal
-* blocksize for a call of SORMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INF0= -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a real scalar, and v is a real vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine SORGRQ.
-* To use Q to update another matrix, use LAPACK subroutine SORMRQ.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(p,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a real scalar, and v is a real vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
-* and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine SORGQR.
-* To use Z to update another matrix, use LAPACK subroutine SORMQR.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL SGEQRF, SGERQF, SORMRQ, XERBLA
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggsvd"></A>
- <H2>sggsvd</H2>
-
- <PRE>
-USAGE:
- k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.sggsvd( jobu, jobv, jobq, a, b)
- or
- NumRu::Lapack.sggsvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGSVD computes the generalized singular value decomposition (GSVD)
-* of an M-by-N real matrix A and P-by-N real matrix B:
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
-*
-* where U, V and Q are orthogonal matrices, and Z' is the transpose
-* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',
-* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
-* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
-* following structures, respectively:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 )
-* L ( 0 0 R22 )
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The routine computes C, S, R, and optionally the orthogonal
-* transformation matrices U, V and Q.
-*
-* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
-* A and B implicitly gives the SVD of A*inv(B):
-* A*inv(B) = U*(D1*inv(D2))*V'.
-* If ( A',B')' has orthonormal columns, then the GSVD of A and B is
-* also equal to the CS decomposition of A and B. Furthermore, the GSVD
-* can be used to derive the solution of the eigenvalue problem:
-* A'*A x = lambda* B'*B x.
-* In some literature, the GSVD of A and B is presented in the form
-* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
-* where U and V are orthogonal and X is nonsingular, D1 and D2 are
-* ``diagonal''. The former GSVD form can be converted to the latter
-* form by taking the nonsingular matrix X as
-*
-* X = Q*( I 0 )
-* ( 0 inv(R) ).
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Orthogonal matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Orthogonal matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Orthogonal matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in the Purpose section.
-* K + L = effective numerical rank of (A',B')'.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular matrix R, or part of R.
-* See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains the triangular matrix R if M-K-L < 0.
-* See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* ALPHA (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = C,
-* BETA(K+1:K+L) = S,
-* or if M-K-L < 0,
-* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
-* BETA(K+1:M) =S, BETA(M+1:K+L) =1
-* and
-* ALPHA(K+L+1:N) = 0
-* BETA(K+L+1:N) = 0
-*
-* U (output) REAL array, dimension (LDU,M)
-* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) REAL array, dimension (LDV,P)
-* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) REAL array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) REAL array,
-* dimension (max(3*N,M,P)+N)
-*
-* IWORK (workspace/output) INTEGER array, dimension (N)
-* On exit, IWORK stores the sorting information. More
-* precisely, the following loop will sort ALPHA
-* for I = K+1, min(M,K+L)
-* swap ALPHA(I) and ALPHA(IWORK(I))
-* endfor
-* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = 1, the Jacobi-type procedure failed to
-* converge. For further details, see subroutine STGSJA.
-*
-* Internal Parameters
-* ===================
-*
-* TOLA REAL
-* TOLB REAL
-* TOLA and TOLB are the thresholds to determine the effective
-* rank of (A',B')'. Generally, they are set to
-* TOLA = MAX(M,N)*norm(A)*MACHEPS,
-* TOLB = MAX(P,N)*norm(B)*MACHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-
-* Further Details
-* ===============
-*
-* 2-96 Based on modifications by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL WANTQ, WANTU, WANTV
- INTEGER I, IBND, ISUB, J, NCYCLE
- REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- REAL SLAMCH, SLANGE
- EXTERNAL LSAME, SLAMCH, SLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL SCOPY, SGGSVP, STGSJA, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sggsvp"></A>
- <H2>sggsvp</H2>
-
- <PRE>
-USAGE:
- k, l, u, v, q, info, a, b = NumRu::Lapack.sggsvp( jobu, jobv, jobq, a, b, tola, tolb)
- or
- NumRu::Lapack.sggsvp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SGGSVP computes orthogonal matrices U, V and Q such that
-*
-* N-K-L K L
-* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* V'*B*Q = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
-* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
-* transpose of Z.
-*
-* This decomposition is the preprocessing step for computing the
-* Generalized Singular Value Decomposition (GSVD), see subroutine
-* SGGSVD.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Orthogonal matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Orthogonal matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Orthogonal matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular (or trapezoidal) matrix
-* described in the Purpose section.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains the triangular matrix described in
-* the Purpose section.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) REAL
-* TOLB (input) REAL
-* TOLA and TOLB are the thresholds to determine the effective
-* numerical rank of matrix B and a subblock of A. Generally,
-* they are set to
-* TOLA = MAX(M,N)*norm(A)*MACHEPS,
-* TOLB = MAX(P,N)*norm(B)*MACHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in Purpose.
-* K + L = effective numerical rank of (A',B')'.
-*
-* U (output) REAL array, dimension (LDU,M)
-* If JOBU = 'U', U contains the orthogonal matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) REAL array, dimension (LDV,P)
-* If JOBV = 'V', V contains the orthogonal matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) REAL array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the orthogonal matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* TAU (workspace) REAL array, dimension (N)
-*
-* WORK (workspace) REAL array, dimension (max(3*N,M,P))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-*
-
-* Further Details
-* ===============
-*
-* The subroutine uses LAPACK subroutine SGEQPF for the QR factorization
-* with column pivoting to detect the effective numerical rank of the
-* a matrix. It may be replaced by a better rank determination strategy.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sgt.html b/doc/sgt.html
deleted file mode 100644
index 1eaddbe..0000000
--- a/doc/sgt.html
+++ /dev/null
@@ -1,733 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for general tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for general tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#sgtcon">sgtcon</A> : </LI>
- <LI><A HREF="#sgtrfs">sgtrfs</A> : </LI>
- <LI><A HREF="#sgtsv">sgtsv</A> : </LI>
- <LI><A HREF="#sgtsvx">sgtsvx</A> : </LI>
- <LI><A HREF="#sgttrf">sgttrf</A> : </LI>
- <LI><A HREF="#sgttrs">sgttrs</A> : </LI>
- <LI><A HREF="#sgtts2">sgtts2</A> : </LI>
- </UL>
-
- <A NAME="sgtcon"></A>
- <H2>sgtcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.sgtcon( norm, dl, d, du, du2, ipiv, anorm)
- or
- NumRu::Lapack.sgtcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGTCON estimates the reciprocal of the condition number of a real
-* tridiagonal matrix A using the LU factorization as computed by
-* SGTTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* DL (input) REAL array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by SGTTRF.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) REAL array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) REAL array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* ANORM (input) REAL
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) REAL array, dimension (2*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgtrfs"></A>
- <H2>sgtrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.sgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)
- or
- NumRu::Lapack.sgtrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is tridiagonal, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) REAL array, dimension (N)
-* The diagonal elements of A.
-*
-* DU (input) REAL array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input) REAL array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by SGTTRF.
-*
-* DF (input) REAL array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DUF (input) REAL array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) REAL array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgtsv"></A>
- <H2>sgtsv</H2>
-
- <PRE>
-USAGE:
- info, dl, d, du, b = NumRu::Lapack.sgtsv( dl, d, du, b)
- or
- NumRu::Lapack.sgtsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SGTSV solves the equation
-*
-* A*X = B,
-*
-* where A is an n by n tridiagonal matrix, by Gaussian elimination with
-* partial pivoting.
-*
-* Note that the equation A'*X = B may be solved by interchanging the
-* order of the arguments DU and DL.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input/output) REAL array, dimension (N-1)
-* On entry, DL must contain the (n-1) sub-diagonal elements of
-* A.
-*
-* On exit, DL is overwritten by the (n-2) elements of the
-* second super-diagonal of the upper triangular matrix U from
-* the LU factorization of A, in DL(1), ..., DL(n-2).
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-*
-* On exit, D is overwritten by the n diagonal elements of U.
-*
-* DU (input/output) REAL array, dimension (N-1)
-* On entry, DU must contain the (n-1) super-diagonal elements
-* of A.
-*
-* On exit, DU is overwritten by the (n-1) elements of the first
-* super-diagonal of U.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N by NRHS matrix of right hand side matrix B.
-* On exit, if INFO = 0, the N by NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
-* has not been computed. The factorization has not been
-* completed unless i = N.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgtsvx"></A>
- <H2>sgtsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.sgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)
- or
- NumRu::Lapack.sgtsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SGTSVX uses the LU factorization to compute the solution to a real
-* system of linear equations A * X = B or A**T * X = B,
-* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
-* as A = L * U, where L is a product of permutation and unit lower
-* bidiagonal matrices and U is upper triangular with nonzeros in
-* only the main diagonal and first two superdiagonals.
-*
-* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
-* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
-* will not be modified.
-* = 'N': The matrix will be copied to DLF, DF, and DUF
-* and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of A.
-*
-* DU (input) REAL array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input or output) REAL array, dimension (N-1)
-* If FACT = 'F', then DLF is an input argument and on entry
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A as computed by SGTTRF.
-*
-* If FACT = 'N', then DLF is an output argument and on exit
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A.
-*
-* DF (input or output) REAL array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* DUF (input or output) REAL array, dimension (N-1)
-* If FACT = 'F', then DUF is an input argument and on entry
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* If FACT = 'N', then DUF is an output argument and on exit
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input or output) REAL array, dimension (N-2)
-* If FACT = 'F', then DU2 is an input argument and on entry
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* If FACT = 'N', then DU2 is an output argument and on exit
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the LU factorization of A as
-* computed by SGTTRF.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the LU factorization of A;
-* row i of the matrix was interchanged with row IPIV(i).
-* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
-* a row interchange was not required.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has not been completed unless i = N, but the
-* factor U is exactly singular, so the solution
-* and error bounds could not be computed.
-* RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgttrf"></A>
- <H2>sgttrf</H2>
-
- <PRE>
-USAGE:
- du2, ipiv, info, dl, d, du = NumRu::Lapack.sgttrf( dl, d, du)
- or
- NumRu::Lapack.sgttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* SGTTRF computes an LU factorization of a real tridiagonal matrix A
-* using elimination with partial pivoting and row interchanges.
-*
-* The factorization has the form
-* A = L * U
-* where L is a product of permutation and unit lower bidiagonal
-* matrices and U is upper triangular with nonzeros in only the main
-* diagonal and first two superdiagonals.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* DL (input/output) REAL array, dimension (N-1)
-* On entry, DL must contain the (n-1) sub-diagonal elements of
-* A.
-*
-* On exit, DL is overwritten by the (n-1) multipliers that
-* define the matrix L from the LU factorization of A.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-*
-* On exit, D is overwritten by the n diagonal elements of the
-* upper triangular matrix U from the LU factorization of A.
-*
-* DU (input/output) REAL array, dimension (N-1)
-* On entry, DU must contain the (n-1) super-diagonal elements
-* of A.
-*
-* On exit, DU is overwritten by the (n-1) elements of the first
-* super-diagonal of U.
-*
-* DU2 (output) REAL array, dimension (N-2)
-* On exit, DU2 is overwritten by the (n-2) elements of the
-* second super-diagonal of U.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgttrs"></A>
- <H2>sgttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.sgttrs( trans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.sgttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SGTTRS solves one of the systems of equations
-* A*X = B or A'*X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by SGTTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A'* X = B (Transpose)
-* = 'C': A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) REAL array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) REAL array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) REAL array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL NOTRAN
- INTEGER ITRANS, J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL SGTTS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sgtts2"></A>
- <H2>sgtts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.sgtts2( itrans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.sgtts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
-
-* Purpose
-* =======
-*
-* SGTTS2 solves one of the systems of equations
-* A*X = B or A'*X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by SGTTRF.
-*
-
-* Arguments
-* =========
-*
-* ITRANS (input) INTEGER
-* Specifies the form of the system of equations.
-* = 0: A * X = B (No transpose)
-* = 1: A'* X = B (Transpose)
-* = 2: A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) REAL array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) REAL array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) REAL array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, IP, J
- REAL TEMP
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/shg.html b/doc/shg.html
deleted file mode 100644
index a77a1f9..0000000
--- a/doc/shg.html
+++ /dev/null
@@ -1,227 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</H1>
- <UL>
- <LI><A HREF="#shgeqz">shgeqz</A> : </LI>
- </UL>
-
- <A NAME="shgeqz"></A>
- <H2>shgeqz</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.shgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)
- or
- NumRu::Lapack.shgeqz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SHGEQZ computes the eigenvalues of a real matrix pair (H,T),
-* where H is an upper Hessenberg matrix and T is upper triangular,
-* using the double-shift QZ method.
-* Matrix pairs of this type are produced by the reduction to
-* generalized upper Hessenberg form of a real matrix pair (A,B):
-*
-* A = Q1*H*Z1**T, B = Q1*T*Z1**T,
-*
-* as computed by SGGHRD.
-*
-* If JOB='S', then the Hessenberg-triangular pair (H,T) is
-* also reduced to generalized Schur form,
-*
-* H = Q*S*Z**T, T = Q*P*Z**T,
-*
-* where Q and Z are orthogonal matrices, P is an upper triangular
-* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
-* diagonal blocks.
-*
-* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
-* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
-* eigenvalues.
-*
-* Additionally, the 2-by-2 upper triangular diagonal blocks of P
-* corresponding to 2-by-2 blocks of S are reduced to positive diagonal
-* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
-* P(j,j) > 0, and P(j+1,j+1) > 0.
-*
-* Optionally, the orthogonal matrix Q from the generalized Schur
-* factorization may be postmultiplied into an input matrix Q1, and the
-* orthogonal matrix Z may be postmultiplied into an input matrix Z1.
-* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced
-* the matrix pair (A,B) to generalized upper Hessenberg form, then the
-* output matrices Q1*Q and Z1*Z are the orthogonal factors from the
-* generalized Schur factorization of (A,B):
-*
-* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.
-*
-* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
-* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
-* complex and beta real.
-* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
-* generalized nonsymmetric eigenvalue problem (GNEP)
-* A*x = lambda*B*x
-* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
-* alternate form of the GNEP
-* mu*A*y = B*y.
-* Real eigenvalues can be read directly from the generalized Schur
-* form:
-* alpha = S(i,i), beta = P(i,i).
-*
-* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
-* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
-* pp. 241--256.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': Compute eigenvalues only;
-* = 'S': Compute eigenvalues and the Schur form.
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': Left Schur vectors (Q) are not computed;
-* = 'I': Q is initialized to the unit matrix and the matrix Q
-* of left Schur vectors of (H,T) is returned;
-* = 'V': Q must contain an orthogonal matrix Q1 on entry and
-* the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Right Schur vectors (Z) are not computed;
-* = 'I': Z is initialized to the unit matrix and the matrix Z
-* of right Schur vectors of (H,T) is returned;
-* = 'V': Z must contain an orthogonal matrix Z1 on entry and
-* the product Z1*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrices H, T, Q, and Z. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of H which are in
-* Hessenberg form. It is assumed that A is already upper
-* triangular in rows and columns 1:ILO-1 and IHI+1:N.
-* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
-*
-* H (input/output) REAL array, dimension (LDH, N)
-* On entry, the N-by-N upper Hessenberg matrix H.
-* On exit, if JOB = 'S', H contains the upper quasi-triangular
-* matrix S from the generalized Schur factorization;
-* 2-by-2 diagonal blocks (corresponding to complex conjugate
-* pairs of eigenvalues) are returned in standard form, with
-* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.
-* If JOB = 'E', the diagonal blocks of H match those of S, but
-* the rest of H is unspecified.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max( 1, N ).
-*
-* T (input/output) REAL array, dimension (LDT, N)
-* On entry, the N-by-N upper triangular matrix T.
-* On exit, if JOB = 'S', T contains the upper triangular
-* matrix P from the generalized Schur factorization;
-* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
-* are reduced to positive diagonal form, i.e., if H(j+1,j) is
-* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
-* T(j+1,j+1) > 0.
-* If JOB = 'E', the diagonal blocks of T match those of P, but
-* the rest of T is unspecified.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max( 1, N ).
-*
-* ALPHAR (output) REAL array, dimension (N)
-* The real parts of each scalar alpha defining an eigenvalue
-* of GNEP.
-*
-* ALPHAI (output) REAL array, dimension (N)
-* The imaginary parts of each scalar alpha defining an
-* eigenvalue of GNEP.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
-*
-* BETA (output) REAL array, dimension (N)
-* The scalars beta that define the eigenvalues of GNEP.
-* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
-* beta = BETA(j) represent the j-th eigenvalue of the matrix
-* pair (A,B), in one of the forms lambda = alpha/beta or
-* mu = beta/alpha. Since either lambda or mu may overflow,
-* they should not, in general, be computed.
-*
-* Q (input/output) REAL array, dimension (LDQ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in
-* the reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur
-* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix
-* of left Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If COMPQ='V' or 'I', then LDQ >= N.
-*
-* Z (input/output) REAL array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
-* the reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the orthogonal matrix of
-* right Schur vectors of (H,T), and if COMPZ = 'V', the
-* orthogonal matrix of right Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If COMPZ='V' or 'I', then LDZ >= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1,...,N: the QZ iteration did not converge. (H,T) is not
-* in Schur form, but ALPHAR(i), ALPHAI(i), and
-* BETA(i), i=INFO+1,...,N should be correct.
-* = N+1,...,2*N: the shift calculation failed. (H,T) is not
-* in Schur form, but ALPHAR(i), ALPHAI(i), and
-* BETA(i), i=INFO-N+1,...,N should be correct.
-*
-
-* Further Details
-* ===============
-*
-* Iteration counters:
-*
-* JITER -- counts iterations.
-* IITER -- counts iterations run since ILAST was last
-* changed. This is therefore reset only when a 1-by-1 or
-* 2-by-2 block deflates off the bottom.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/shs.html b/doc/shs.html
deleted file mode 100644
index 37c6144..0000000
--- a/doc/shs.html
+++ /dev/null
@@ -1,419 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for upper Hessenberg matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for upper Hessenberg matrix</H1>
- <UL>
- <LI><A HREF="#shsein">shsein</A> : </LI>
- <LI><A HREF="#shseqr">shseqr</A> : </LI>
- </UL>
-
- <A NAME="shsein"></A>
- <H2>shsein</H2>
-
- <PRE>
-USAGE:
- m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.shsein( side, eigsrc, initv, select, h, wr, wi, vl, vr)
- or
- NumRu::Lapack.shsein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )
-
-* Purpose
-* =======
-*
-* SHSEIN uses inverse iteration to find specified right and/or left
-* eigenvectors of a real upper Hessenberg matrix H.
-*
-* The right eigenvector x and the left eigenvector y of the matrix H
-* corresponding to an eigenvalue w are defined by:
-*
-* H * x = w * x, y**h * H = w * y**h
-*
-* where y**h denotes the conjugate transpose of the vector y.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* EIGSRC (input) CHARACTER*1
-* Specifies the source of eigenvalues supplied in (WR,WI):
-* = 'Q': the eigenvalues were found using SHSEQR; thus, if
-* H has zero subdiagonal elements, and so is
-* block-triangular, then the j-th eigenvalue can be
-* assumed to be an eigenvalue of the block containing
-* the j-th row/column. This property allows SHSEIN to
-* perform inverse iteration on just one diagonal block.
-* = 'N': no assumptions are made on the correspondence
-* between eigenvalues and diagonal blocks. In this
-* case, SHSEIN must always perform inverse iteration
-* using the whole matrix H.
-*
-* INITV (input) CHARACTER*1
-* = 'N': no initial vectors are supplied;
-* = 'U': user-supplied initial vectors are stored in the arrays
-* VL and/or VR.
-*
-* SELECT (input/output) LOGICAL array, dimension (N)
-* Specifies the eigenvectors to be computed. To select the
-* real eigenvector corresponding to a real eigenvalue WR(j),
-* SELECT(j) must be set to .TRUE.. To select the complex
-* eigenvector corresponding to a complex eigenvalue
-* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
-* either SELECT(j) or SELECT(j+1) or both must be set to
-* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
-* .FALSE..
-*
-* N (input) INTEGER
-* The order of the matrix H. N >= 0.
-*
-* H (input) REAL array, dimension (LDH,N)
-* The upper Hessenberg matrix H.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max(1,N).
-*
-* WR (input/output) REAL array, dimension (N)
-* WI (input) REAL array, dimension (N)
-* On entry, the real and imaginary parts of the eigenvalues of
-* H; a complex conjugate pair of eigenvalues must be stored in
-* consecutive elements of WR and WI.
-* On exit, WR may have been altered since close eigenvalues
-* are perturbed slightly in searching for independent
-* eigenvectors.
-*
-* VL (input/output) REAL array, dimension (LDVL,MM)
-* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
-* contain starting vectors for the inverse iteration for the
-* left eigenvectors; the starting vector for each eigenvector
-* must be in the same column(s) in which the eigenvector will
-* be stored.
-* On exit, if SIDE = 'L' or 'B', the left eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VL, in the same order as their eigenvalues. A
-* complex eigenvector corresponding to a complex eigenvalue is
-* stored in two consecutive columns, the first holding the real
-* part and the second the imaginary part.
-* If SIDE = 'R', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
-*
-* VR (input/output) REAL array, dimension (LDVR,MM)
-* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
-* contain starting vectors for the inverse iteration for the
-* right eigenvectors; the starting vector for each eigenvector
-* must be in the same column(s) in which the eigenvector will
-* be stored.
-* On exit, if SIDE = 'R' or 'B', the right eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VR, in the same order as their eigenvalues. A
-* complex eigenvector corresponding to a complex eigenvalue is
-* stored in two consecutive columns, the first holding the real
-* part and the second the imaginary part.
-* If SIDE = 'L', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR required to
-* store the eigenvectors; each selected real eigenvector
-* occupies one column and each selected complex eigenvector
-* occupies two columns.
-*
-* WORK (workspace) REAL array, dimension ((N+2)*N)
-*
-* IFAILL (output) INTEGER array, dimension (MM)
-* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
-* eigenvector in the i-th column of VL (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
-* eigenvector converged satisfactorily. If the i-th and (i+1)th
-* columns of VL hold a complex eigenvector, then IFAILL(i) and
-* IFAILL(i+1) are set to the same value.
-* If SIDE = 'R', IFAILL is not referenced.
-*
-* IFAILR (output) INTEGER array, dimension (MM)
-* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
-* eigenvector in the i-th column of VR (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
-* eigenvector converged satisfactorily. If the i-th and (i+1)th
-* columns of VR hold a complex eigenvector, then IFAILR(i) and
-* IFAILR(i+1) are set to the same value.
-* If SIDE = 'L', IFAILR is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, i is the number of eigenvectors which
-* failed to converge; see IFAILL and IFAILR for further
-* details.
-*
-
-* Further Details
-* ===============
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x|+|y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="shseqr"></A>
- <H2>shseqr</H2>
-
- <PRE>
-USAGE:
- wr, wi, work, info, h, z = NumRu::Lapack.shseqr( job, compz, ilo, ihi, h, z, ldz, lwork)
- or
- NumRu::Lapack.shseqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SHSEQR computes the eigenvalues of a Hessenberg matrix H
-* and, optionally, the matrices T and Z from the Schur decomposition
-* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
-* Schur form), and Z is the orthogonal matrix of Schur vectors.
-*
-* Optionally Z may be postmultiplied into an input orthogonal
-* matrix Q so that this routine can give the Schur factorization
-* of a matrix A which has been reduced to the Hessenberg form H
-* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': compute eigenvalues only;
-* = 'S': compute eigenvalues and the Schur form T.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': no Schur vectors are computed;
-* = 'I': Z is initialized to the unit matrix and the matrix Z
-* of Schur vectors of H is returned;
-* = 'V': Z must contain an orthogonal matrix Q on entry, and
-* the product Q*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrix H. N .GE. 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that H is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to SGEBAL, and then passed to SGEHRD
-* when the matrix output by SGEBAL is reduced to Hessenberg
-* form. Otherwise ILO and IHI should be set to 1 and N
-* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
-* If N = 0, then ILO = 1 and IHI = 0.
-*
-* H (input/output) REAL array, dimension (LDH,N)
-* On entry, the upper Hessenberg matrix H.
-* On exit, if INFO = 0 and JOB = 'S', then H contains the
-* upper quasi-triangular matrix T from the Schur decomposition
-* (the Schur form); 2-by-2 diagonal blocks (corresponding to
-* complex conjugate pairs of eigenvalues) are returned in
-* standard form, with H(i,i) = H(i+1,i+1) and
-* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
-* contents of H are unspecified on exit. (The output value of
-* H when INFO.GT.0 is given under the description of INFO
-* below.)
-*
-* Unlike earlier versions of SHSEQR, this subroutine may
-* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
-* or j = IHI+1, IHI+2, ... N.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH .GE. max(1,N).
-*
-* WR (output) REAL array, dimension (N)
-* WI (output) REAL array, dimension (N)
-* The real and imaginary parts, respectively, of the computed
-* eigenvalues. If two eigenvalues are computed as a complex
-* conjugate pair, they are stored in consecutive elements of
-* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
-* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
-* the same order as on the diagonal of the Schur form returned
-* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
-* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
-* WI(i+1) = -WI(i).
-*
-* Z (input/output) REAL array, dimension (LDZ,N)
-* If COMPZ = 'N', Z is not referenced.
-* If COMPZ = 'I', on entry Z need not be set and on exit,
-* if INFO = 0, Z contains the orthogonal matrix Z of the Schur
-* vectors of H. If COMPZ = 'V', on entry Z must contain an
-* N-by-N matrix Q, which is assumed to be equal to the unit
-* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
-* if INFO = 0, Z contains Q*Z.
-* Normally Q is the orthogonal matrix generated by SORGHR
-* after the call to SGEHRD which formed the Hessenberg matrix
-* H. (The output value of Z when INFO.GT.0 is given under
-* the description of INFO below.)
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. if COMPZ = 'I' or
-* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
-*
-* WORK (workspace/output) REAL array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns an estimate of
-* the optimal value for LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK .GE. max(1,N)
-* is sufficient and delivers very good and sometimes
-* optimal performance. However, LWORK as large as 11*N
-* may be required for optimal performance. A workspace
-* query is recommended to determine the optimal workspace
-* size.
-*
-* If LWORK = -1, then SHSEQR does a workspace query.
-* In this case, SHSEQR checks the input parameters and
-* estimates the optimal workspace size for the given
-* values of N, ILO and IHI. The estimate is returned
-* in WORK(1). No error message related to LWORK is
-* issued by XERBLA. Neither H nor Z are accessed.
-*
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* .LT. 0: if INFO = -i, the i-th argument had an illegal
-* value
-* .GT. 0: if INFO = i, SHSEQR failed to compute all of
-* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
-* and WI contain those eigenvalues which have been
-* successfully computed. (Failures are rare.)
-*
-* If INFO .GT. 0 and JOB = 'E', then on exit, the
-* remaining unconverged eigenvalues are the eigen-
-* values of the upper Hessenberg matrix rows and
-* columns ILO through INFO of the final, output
-* value of H.
-*
-* If INFO .GT. 0 and JOB = 'S', then on exit
-*
-* (*) (initial value of H)*U = U*(final value of H)
-*
-* where U is an orthogonal matrix. The final
-* value of H is upper Hessenberg and quasi-triangular
-* in rows and columns INFO+1 through IHI.
-*
-* If INFO .GT. 0 and COMPZ = 'V', then on exit
-*
-* (final value of Z) = (initial value of Z)*U
-*
-* where U is the orthogonal matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'I', then on exit
-* (final value of Z) = U
-* where U is the orthogonal matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'N', then Z is not
-* accessed.
-*
-
-* ================================================================
-* Default values supplied by
-* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
-* It is suggested that these defaults be adjusted in order
-* to attain best performance in each particular
-* computational environment.
-*
-* ISPEC=12: The SLAHQR vs SLAQR0 crossover point.
-* Default: 75. (Must be at least 11.)
-*
-* ISPEC=13: Recommended deflation window size.
-* This depends on ILO, IHI and NS. NS is the
-* number of simultaneous shifts returned
-* by ILAENV(ISPEC=15). (See ISPEC=15 below.)
-* The default for (IHI-ILO+1).LE.500 is NS.
-* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
-*
-* ISPEC=14: Nibble crossover point. (See IPARMQ for
-* details.) Default: 14% of deflation window
-* size.
-*
-* ISPEC=15: Number of simultaneous shifts in a multishift
-* QR iteration.
-*
-* If IHI-ILO+1 is ...
-*
-* greater than ...but less ... the
-* or equal to ... than default is
-*
-* 1 30 NS = 2(+)
-* 30 60 NS = 4(+)
-* 60 150 NS = 10(+)
-* 150 590 NS = **
-* 590 3000 NS = 64
-* 3000 6000 NS = 128
-* 6000 infinity NS = 256
-*
-* (+) By default some or all matrices of this order
-* are passed to the implicit double shift routine
-* SLAHQR and this parameter is ignored. See
-* ISPEC=12 above and comments in IPARMQ for
-* details.
-*
-* (**) The asterisks (**) indicate an ad-hoc
-* function of N increasing from 10 to 64.
-*
-* ISPEC=16: Select structured matrix multiply.
-* If the number of simultaneous shifts (specified
-* by ISPEC=15) is less than 14, then the default
-* for ISPEC=16 is 0. Otherwise the default for
-* ISPEC=16 is 2.
-*
-* ================================================================
-* Based on contributions by
-* Karen Braman and Ralph Byers, Department of Mathematics,
-* University of Kansas, USA
-*
-* ================================================================
-* References:
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
-* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
-* 929--947, 2002.
-*
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
-* of Matrix Analysis, volume 23, pages 948--973, 2002.
-*
-* ================================================================
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sop.html b/doc/sop.html
deleted file mode 100644
index ecbde50..0000000
--- a/doc/sop.html
+++ /dev/null
@@ -1,171 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for (real) orthogonal, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for (real) orthogonal, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#sopgtr">sopgtr</A> : </LI>
- <LI><A HREF="#sopmtr">sopmtr</A> : </LI>
- </UL>
-
- <A NAME="sopgtr"></A>
- <H2>sopgtr</H2>
-
- <PRE>
-USAGE:
- q, info = NumRu::Lapack.sopgtr( uplo, ap, tau)
- or
- NumRu::Lapack.sopgtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SOPGTR generates a real orthogonal matrix Q which is defined as the
-* product of n-1 elementary reflectors H(i) of order n, as returned by
-* SSPTRD using packed storage:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to SSPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to SSPTRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The vectors which define the elementary reflectors, as
-* returned by SSPTRD.
-*
-* TAU (input) REAL array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SSPTRD.
-*
-* Q (output) REAL array, dimension (LDQ,N)
-* The N-by-N orthogonal matrix Q.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (N-1)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sopmtr"></A>
- <H2>sopmtr</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.sopmtr( side, uplo, trans, m, ap, tau, c)
- or
- NumRu::Lapack.sopmtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SOPMTR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by SSPTRD using packed
-* storage:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to SSPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to SSPTRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* AP (input) REAL array, dimension
-* (M*(M+1)/2) if SIDE = 'L'
-* (N*(N+1)/2) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by SSPTRD. AP is modified by the routine but
-* restored on exit.
-*
-* TAU (input) REAL array, dimension (M-1) if SIDE = 'L'
-* or (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SSPTRD.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) REAL array, dimension
-* (N) if SIDE = 'L'
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sor.html b/doc/sor.html
deleted file mode 100644
index 4c8d25f..0000000
--- a/doc/sor.html
+++ /dev/null
@@ -1,2617 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for (real) orthogonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for (real) orthogonal matrix</H1>
- <UL>
- <LI><A HREF="#sorbdb">sorbdb</A> : </LI>
- <LI><A HREF="#sorcsd">sorcsd</A> : </LI>
- <LI><A HREF="#sorg2l">sorg2l</A> : </LI>
- <LI><A HREF="#sorg2r">sorg2r</A> : </LI>
- <LI><A HREF="#sorgbr">sorgbr</A> : </LI>
- <LI><A HREF="#sorghr">sorghr</A> : </LI>
- <LI><A HREF="#sorgl2">sorgl2</A> : </LI>
- <LI><A HREF="#sorglq">sorglq</A> : </LI>
- <LI><A HREF="#sorgql">sorgql</A> : </LI>
- <LI><A HREF="#sorgqr">sorgqr</A> : </LI>
- <LI><A HREF="#sorgr2">sorgr2</A> : </LI>
- <LI><A HREF="#sorgrq">sorgrq</A> : </LI>
- <LI><A HREF="#sorgtr">sorgtr</A> : </LI>
- <LI><A HREF="#sorm2l">sorm2l</A> : </LI>
- <LI><A HREF="#sorm2r">sorm2r</A> : </LI>
- <LI><A HREF="#sormbr">sormbr</A> : </LI>
- <LI><A HREF="#sormhr">sormhr</A> : </LI>
- <LI><A HREF="#sorml2">sorml2</A> : </LI>
- <LI><A HREF="#sormlq">sormlq</A> : </LI>
- <LI><A HREF="#sormql">sormql</A> : </LI>
- <LI><A HREF="#sormqr">sormqr</A> : </LI>
- <LI><A HREF="#sormr2">sormr2</A> : </LI>
- <LI><A HREF="#sormr3">sormr3</A> : </LI>
- <LI><A HREF="#sormrq">sormrq</A> : </LI>
- <LI><A HREF="#sormrz">sormrz</A> : </LI>
- <LI><A HREF="#sormtr">sormtr</A> : </LI>
- </UL>
-
- <A NAME="sorbdb"></A>
- <H2>sorbdb</H2>
-
- <PRE>
-USAGE:
- theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.sorbdb( trans, signs, m, x11, x12, x21, x22, lwork)
- or
- NumRu::Lapack.sorbdb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORBDB simultaneously bidiagonalizes the blocks of an M-by-M
-* partitioned orthogonal matrix X:
-*
-* [ B11 | B12 0 0 ]
-* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T
-* X = [-----------] = [---------] [----------------] [---------] .
-* [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]
-* [ 0 | 0 0 I ]
-*
-* X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is
-* not the case, then X must be transposed and/or permuted. This can be
-* done in constant time using the TRANS and SIGNS options. See SORCSD
-* for details.)
-*
-* The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-
-* (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are
-* represented implicitly by Householder vectors.
-*
-* B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented
-* implicitly by angles THETA, PHI.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <=
-* MIN(P,M-P,M-Q).
-*
-* X11 (input/output) REAL array, dimension (LDX11,Q)
-* On entry, the top-left block of the orthogonal matrix to be
-* reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X11) specify reflectors for P1,
-* the rows of triu(X11,1) specify reflectors for Q1;
-* else TRANS = 'T', and
-* the rows of triu(X11) specify reflectors for P1,
-* the columns of tril(X11,-1) specify reflectors for Q1.
-*
-* LDX11 (input) INTEGER
-* The leading dimension of X11. If TRANS = 'N', then LDX11 >=
-* P; else LDX11 >= Q.
-*
-* X12 (input/output) REAL array, dimension (LDX12,M-Q)
-* On entry, the top-right block of the orthogonal matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X12) specify the first P reflectors for
-* Q2;
-* else TRANS = 'T', and
-* the columns of tril(X12) specify the first P reflectors
-* for Q2.
-*
-* LDX12 (input) INTEGER
-* The leading dimension of X12. If TRANS = 'N', then LDX12 >=
-* P; else LDX11 >= M-Q.
-*
-* X21 (input/output) REAL array, dimension (LDX21,Q)
-* On entry, the bottom-left block of the orthogonal matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X21) specify reflectors for P2;
-* else TRANS = 'T', and
-* the rows of triu(X21) specify reflectors for P2.
-*
-* LDX21 (input) INTEGER
-* The leading dimension of X21. If TRANS = 'N', then LDX21 >=
-* M-P; else LDX21 >= Q.
-*
-* X22 (input/output) REAL array, dimension (LDX22,M-Q)
-* On entry, the bottom-right block of the orthogonal matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last
-* M-P-Q reflectors for Q2,
-* else TRANS = 'T', and
-* the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last
-* M-P-Q reflectors for P2.
-*
-* LDX22 (input) INTEGER
-* The leading dimension of X22. If TRANS = 'N', then LDX22 >=
-* M-P; else LDX22 >= M-Q.
-*
-* THETA (output) REAL array, dimension (Q)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* PHI (output) REAL array, dimension (Q-1)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* TAUP1 (output) REAL array, dimension (P)
-* The scalar factors of the elementary reflectors that define
-* P1.
-*
-* TAUP2 (output) REAL array, dimension (M-P)
-* The scalar factors of the elementary reflectors that define
-* P2.
-*
-* TAUQ1 (output) REAL array, dimension (Q)
-* The scalar factors of the elementary reflectors that define
-* Q1.
-*
-* TAUQ2 (output) REAL array, dimension (M-Q)
-* The scalar factors of the elementary reflectors that define
-* Q2.
-*
-* WORK (workspace) REAL array, dimension (LWORK)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= M-Q.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The bidiagonal blocks B11, B12, B21, and B22 are represented
-* implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,
-* PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are
-* lower bidiagonal. Every entry in each bidiagonal band is a product
-* of a sine or cosine of a THETA with a sine or cosine of a PHI. See
-* [1] or SORCSD for details.
-*
-* P1, P2, Q1, and Q2 are represented as products of elementary
-* reflectors. See SORCSD for details on generating P1, P2, Q1, and Q2
-* using SORGQR and SORGLQ.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorcsd"></A>
- <H2>sorcsd</H2>
-
- <PRE>
-USAGE:
- theta, u1, u2, v1t, v2t, info = NumRu::Lapack.sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, ldu1, ldu2, ldv1t, ldv2t, lwork)
- or
- NumRu::Lapack.sorcsd # print help
-
-
-FORTRAN MANUAL
- RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORCSD computes the CS decomposition of an M-by-M partitioned
-* orthogonal matrix X:
-*
-* [ I 0 0 | 0 0 0 ]
-* [ 0 C 0 | 0 -S 0 ]
-* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T
-* X = [-----------] = [---------] [---------------------] [---------] .
-* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]
-* [ 0 S 0 | 0 C 0 ]
-* [ 0 0 I | 0 0 0 ]
-*
-* X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,
-* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
-* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
-* which R = MIN(P,M-P,Q,M-Q).
-*
-
-* Arguments
-* =========
-*
-* JOBU1 (input) CHARACTER
-* = 'Y': U1 is computed;
-* otherwise: U1 is not computed.
-*
-* JOBU2 (input) CHARACTER
-* = 'Y': U2 is computed;
-* otherwise: U2 is not computed.
-*
-* JOBV1T (input) CHARACTER
-* = 'Y': V1T is computed;
-* otherwise: V1T is not computed.
-*
-* JOBV2T (input) CHARACTER
-* = 'Y': V2T is computed;
-* otherwise: V2T is not computed.
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <= M.
-*
-* X (input/workspace) REAL array, dimension (LDX,M)
-* On entry, the orthogonal matrix whose CSD is desired.
-*
-* LDX (input) INTEGER
-* The leading dimension of X. LDX >= MAX(1,M).
-*
-* THETA (output) REAL array, dimension (R), in which R =
-* MIN(P,M-P,Q,M-Q).
-* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
-* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
-*
-* U1 (output) REAL array, dimension (P)
-* If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
-*
-* LDU1 (input) INTEGER
-* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
-* MAX(1,P).
-*
-* U2 (output) REAL array, dimension (M-P)
-* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
-* matrix U2.
-*
-* LDU2 (input) INTEGER
-* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
-* MAX(1,M-P).
-*
-* V1T (output) REAL array, dimension (Q)
-* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
-* matrix V1**T.
-*
-* LDV1T (input) INTEGER
-* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
-* MAX(1,Q).
-*
-* V2T (output) REAL array, dimension (M-Q)
-* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal
-* matrix V2**T.
-*
-* LDV2T (input) INTEGER
-* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=
-* MAX(1,M-Q).
-*
-* WORK (workspace) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-* If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
-* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
-* define the matrix in intermediate bidiagonal-block form
-* remaining after nonconvergence. INFO specifies the number
-* of nonzero PHI's.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the work array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M-Q)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: SBBCSD did not converge. See the description of WORK
-* above for details.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorg2l"></A>
- <H2>sorg2l</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.sorg2l( m, a, tau)
- or
- NumRu::Lapack.sorg2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORG2L generates an m by n real matrix Q with orthonormal columns,
-* which is defined as the last n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by SGEQLF in the last k columns of its array
-* argument A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQLF.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorg2r"></A>
- <H2>sorg2r</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.sorg2r( m, a, tau)
- or
- NumRu::Lapack.sorg2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORG2R generates an m by n real matrix Q with orthonormal columns,
-* which is defined as the first n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by SGEQRF in the first k columns of its array
-* argument A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQRF.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorgbr"></A>
- <H2>sorgbr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sorgbr( vect, m, k, a, tau, lwork)
- or
- NumRu::Lapack.sorgbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGBR generates one of the real orthogonal matrices Q or P**T
-* determined by SGEBRD when reducing a real matrix A to bidiagonal
-* form: A = Q * B * P**T. Q and P**T are defined as products of
-* elementary reflectors H(i) or G(i) respectively.
-*
-* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
-* is of order M:
-* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n
-* columns of Q, where m >= n >= k;
-* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an
-* M-by-M matrix.
-*
-* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
-* is of order N:
-* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m
-* rows of P**T, where n >= m >= k;
-* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as
-* an N-by-N matrix.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether the matrix Q or the matrix P**T is
-* required, as defined in the transformation applied by SGEBRD:
-* = 'Q': generate Q;
-* = 'P': generate P**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q or P**T to be returned.
-* M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q or P**T to be returned.
-* N >= 0.
-* If VECT = 'Q', M >= N >= min(M,K);
-* if VECT = 'P', N >= M >= min(N,K).
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original M-by-K
-* matrix reduced by SGEBRD.
-* If VECT = 'P', the number of rows in the original K-by-N
-* matrix reduced by SGEBRD.
-* K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by SGEBRD.
-* On exit, the M-by-N matrix Q or P**T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension
-* (min(M,K)) if VECT = 'Q'
-* (min(N,K)) if VECT = 'P'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i), which determines Q or P**T, as
-* returned by SGEBRD in its array argument TAUQ or TAUP.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,min(M,N)).
-* For optimum performance LWORK >= min(M,N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorghr"></A>
- <H2>sorghr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sorghr( ilo, ihi, a, tau, lwork)
- or
- NumRu::Lapack.sorghr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGHR generates a real orthogonal matrix Q which is defined as the
-* product of IHI-ILO elementary reflectors of order N, as returned by
-* SGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of SGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by SGEHRD.
-* On exit, the N-by-N orthogonal matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (input) REAL array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEHRD.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= IHI-ILO.
-* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorgl2"></A>
- <H2>sorgl2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.sorgl2( a, tau)
- or
- NumRu::Lapack.sorgl2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGL2 generates an m by n real matrix Q with orthonormal rows,
-* which is defined as the first m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by SGELQF in the first k rows of its array argument A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGELQF.
-*
-* WORK (workspace) REAL array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorglq"></A>
- <H2>sorglq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sorglq( m, a, tau, lwork)
- or
- NumRu::Lapack.sorglq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGLQ generates an M-by-N real matrix Q with orthonormal rows,
-* which is defined as the first M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by SGELQF in the first k rows of its array argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGELQF.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorgql"></A>
- <H2>sorgql</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sorgql( m, a, tau, lwork)
- or
- NumRu::Lapack.sorgql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGQL generates an M-by-N real matrix Q with orthonormal columns,
-* which is defined as the last N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by SGEQLF in the last k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQLF.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorgqr"></A>
- <H2>sorgqr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sorgqr( m, a, tau, lwork)
- or
- NumRu::Lapack.sorgqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGQR generates an M-by-N real matrix Q with orthonormal columns,
-* which is defined as the first N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by SGEQRF in the first k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQRF.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorgr2"></A>
- <H2>sorgr2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.sorgr2( a, tau)
- or
- NumRu::Lapack.sorgr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGR2 generates an m by n real matrix Q with orthonormal rows,
-* which is defined as the last m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by SGERQF in the last k rows of its array argument
-* A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGERQF.
-*
-* WORK (workspace) REAL array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorgrq"></A>
- <H2>sorgrq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sorgrq( m, a, tau, lwork)
- or
- NumRu::Lapack.sorgrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGRQ generates an M-by-N real matrix Q with orthonormal rows,
-* which is defined as the last M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by SGERQF in the last k rows of its array argument
-* A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGERQF.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorgtr"></A>
- <H2>sorgtr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.sorgtr( uplo, a, tau, lwork)
- or
- NumRu::Lapack.sorgtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORGTR generates a real orthogonal matrix Q which is defined as the
-* product of n-1 elementary reflectors of order N, as returned by
-* SSYTRD:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from SSYTRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from SSYTRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by SSYTRD.
-* On exit, the N-by-N orthogonal matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (input) REAL array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SSYTRD.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N-1).
-* For optimum performance LWORK >= (N-1)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorm2l"></A>
- <H2>sorm2l</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.sorm2l( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.sorm2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORM2L overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQLF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) REAL array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorm2r"></A>
- <H2>sorm2r</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.sorm2r( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.sorm2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORM2R overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQRF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) REAL array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormbr"></A>
- <H2>sormbr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormbr( vect, side, trans, m, k, a, tau, c, lwork)
- or
- NumRu::Lapack.sormbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': P * C C * P
-* TRANS = 'T': P**T * C C * P**T
-*
-* Here Q and P**T are the orthogonal matrices determined by SGEBRD when
-* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
-* P**T are defined as products of elementary reflectors H(i) and G(i)
-* respectively.
-*
-* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
-* order of the orthogonal matrix Q or P**T that is applied.
-*
-* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
-* if nq >= k, Q = H(1) H(2) . . . H(k);
-* if nq < k, Q = H(1) H(2) . . . H(nq-1).
-*
-* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
-* if k < nq, P = G(1) G(2) . . . G(k);
-* if k >= nq, P = G(1) G(2) . . . G(nq-1).
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'Q': apply Q or Q**T;
-* = 'P': apply P or P**T.
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q, Q**T, P or P**T from the Left;
-* = 'R': apply Q, Q**T, P or P**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q or P;
-* = 'T': Transpose, apply Q**T or P**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original
-* matrix reduced by SGEBRD.
-* If VECT = 'P', the number of rows in the original
-* matrix reduced by SGEBRD.
-* K >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,min(nq,K)) if VECT = 'Q'
-* (LDA,nq) if VECT = 'P'
-* The vectors which define the elementary reflectors H(i) and
-* G(i), whose products determine the matrices Q and P, as
-* returned by SGEBRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If VECT = 'Q', LDA >= max(1,nq);
-* if VECT = 'P', LDA >= max(1,min(nq,K)).
-*
-* TAU (input) REAL array, dimension (min(nq,K))
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i) which determines Q or P, as returned
-* by SGEBRD in the array argument TAUQ or TAUP.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
-* or P*C or P**T*C or C*P or C*P**T.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
- CHARACTER TRANST
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SORMLQ, SORMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormhr"></A>
- <H2>sormhr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormhr( side, trans, ilo, ihi, a, tau, c, lwork)
- or
- NumRu::Lapack.sormhr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMHR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* IHI-ILO elementary reflectors, as returned by SGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of SGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
-* ILO = 1 and IHI = 0, if M = 0;
-* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
-* ILO = 1 and IHI = 0, if N = 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by SGEHRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) REAL array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEHRD.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SORMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sorml2"></A>
- <H2>sorml2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.sorml2( side, trans, a, tau, c)
- or
- NumRu::Lapack.sorml2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORML2 overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGELQF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) REAL array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormlq"></A>
- <H2>sormlq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormlq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.sormlq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMLQ overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGELQF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormql"></A>
- <H2>sormql</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormql( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.sormql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMQL overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQLF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormqr"></A>
- <H2>sormqr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormqr( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.sormqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMQR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGEQRF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormr2"></A>
- <H2>sormr2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.sormr2( side, trans, a, tau, c)
- or
- NumRu::Lapack.sormr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMR2 overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGERQF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the m by n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) REAL array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormr3"></A>
- <H2>sormr3</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.sormr3( side, trans, l, a, tau, c)
- or
- NumRu::Lapack.sormr3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMR3 overwrites the general real m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'T', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'T',
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by STZRZF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'T': apply Q' (Transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* STZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by STZRZF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) REAL array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, NOTRAN
- INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SLARZ, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormrq"></A>
- <H2>sormrq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormrq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.sormrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMRQ overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by SGERQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* SGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SGERQF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormrz"></A>
- <H2>sormrz</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormrz( side, trans, l, a, tau, c, lwork)
- or
- NumRu::Lapack.sormrz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMRZ overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* STZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) REAL array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by STZRZF.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sormtr"></A>
- <H2>sormtr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.sormtr( side, uplo, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.sormtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SORMTR overwrites the general real M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'T': Q**T * C C * Q**T
-*
-* where Q is a real orthogonal matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by SSYTRD:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**T from the Left;
-* = 'R': apply Q or Q**T from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from SSYTRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from SSYTRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'T': Transpose, apply Q**T.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* A (input) REAL array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by SSYTRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) REAL array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by SSYTRD.
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, UPPER
- INTEGER I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SORMQL, SORMQR, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/spb.html b/doc/spb.html
deleted file mode 100644
index 21f6c07..0000000
--- a/doc/spb.html
+++ /dev/null
@@ -1,1018 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for symmetric or Hermitian positive definite band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for symmetric or Hermitian positive definite band matrix</H1>
- <UL>
- <LI><A HREF="#spbcon">spbcon</A> : </LI>
- <LI><A HREF="#spbequ">spbequ</A> : </LI>
- <LI><A HREF="#spbrfs">spbrfs</A> : </LI>
- <LI><A HREF="#spbstf">spbstf</A> : </LI>
- <LI><A HREF="#spbsv">spbsv</A> : </LI>
- <LI><A HREF="#spbsvx">spbsvx</A> : </LI>
- <LI><A HREF="#spbtf2">spbtf2</A> : </LI>
- <LI><A HREF="#spbtrf">spbtrf</A> : </LI>
- <LI><A HREF="#spbtrs">spbtrs</A> : </LI>
- </UL>
-
- <A NAME="spbcon"></A>
- <H2>spbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.spbcon( uplo, kd, ab, anorm)
- or
- NumRu::Lapack.spbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPBCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite band matrix using the
-* Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* ANORM (input) REAL
-* The 1-norm (or infinity-norm) of the symmetric band matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbequ"></A>
- <H2>spbequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.spbequ( uplo, kd, ab)
- or
- NumRu::Lapack.spbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SPBEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite band matrix A and reduce its condition
-* number (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular of A is stored;
-* = 'L': Lower triangular of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The upper or lower triangle of the symmetric band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbrfs"></A>
- <H2>spbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.spbrfs( uplo, kd, ab, afb, b, x)
- or
- NumRu::Lapack.spbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite
-* and banded, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The upper or lower triangle of the symmetric band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* AFB (input) REAL array, dimension (LDAFB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T of the band matrix A as computed by
-* SPBTRF, in the same storage format as A (see AB).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SPBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbstf"></A>
- <H2>spbstf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.spbstf( uplo, kd, ab)
- or
- NumRu::Lapack.spbstf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* SPBSTF computes a split Cholesky factorization of a real
-* symmetric positive definite band matrix A.
-*
-* This routine is designed to be used in conjunction with SSBGST.
-*
-* The factorization has the form A = S**T*S where S is a band matrix
-* of the same bandwidth as A and the following structure:
-*
-* S = ( U )
-* ( M L )
-*
-* where U is upper triangular of order m = (n+kd)/2, and L is lower
-* triangular of order n-m.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first kd+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the factor S from the split Cholesky
-* factorization A = S**T*S. See Further Details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the factorization could not be completed,
-* because the updated element a(i,i) was negative; the
-* matrix A is not positive definite.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 7, KD = 2:
-*
-* S = ( s11 s12 s13 )
-* ( s22 s23 s24 )
-* ( s33 s34 )
-* ( s44 )
-* ( s53 s54 s55 )
-* ( s64 s65 s66 )
-* ( s75 s76 s77 )
-*
-* If UPLO = 'U', the array AB holds:
-*
-* on entry: on exit:
-*
-* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75
-* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-*
-* If UPLO = 'L', the array AB holds:
-*
-* on entry: on exit:
-*
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *
-* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbsv"></A>
- <H2>spbsv</H2>
-
- <PRE>
-USAGE:
- info, ab, b = NumRu::Lapack.spbsv( uplo, kd, ab, b)
- or
- NumRu::Lapack.spbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPBSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix, with the same number of superdiagonals or
-* subdiagonals as A. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**T*U or A = L*L**T of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SPBTRF, SPBTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbsvx"></A>
- <H2>spbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.spbsvx( fact, uplo, kd, ab, afb, equed, s, b)
- or
- NumRu::Lapack.spbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
-* compute the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AB and AFB will not
-* be modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right-hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array, except
-* if FACT = 'F' and EQUED = 'Y', then A must contain the
-* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
-* is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* AFB (input or output) REAL array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the band matrix
-* A, in the same storage format as A (see AB). If EQUED = 'Y',
-* then AFB is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13
-* a22 a23 a24
-* a33 a34 a35
-* a44 a45 a46
-* a55 a56
-* (aij=conjg(aji)) a66
-*
-* Band storage of the upper triangle of A:
-*
-* * * a13 a24 a35 a46
-* * a12 a23 a34 a45 a56
-* a11 a22 a33 a44 a55 a66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* a11 a22 a33 a44 a55 a66
-* a21 a32 a43 a54 a65 *
-* a31 a42 a53 a64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbtf2"></A>
- <H2>spbtf2</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.spbtf2( uplo, kd, ab)
- or
- NumRu::Lapack.spbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* SPBTF2 computes the Cholesky factorization of a real symmetric
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix, U' is the transpose of U, and
-* L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of super-diagonals of the matrix A if UPLO = 'U',
-* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U'*U or A = L*L' of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbtrf"></A>
- <H2>spbtrf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.spbtrf( uplo, kd, ab)
- or
- NumRu::Lapack.spbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* SPBTRF computes the Cholesky factorization of a real symmetric
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**T*U or A = L*L**T of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* Contributed by
-* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spbtrs"></A>
- <H2>spbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.spbtrs( uplo, kd, ab, b)
- or
- NumRu::Lapack.spbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPBTRS solves a system of linear equations A*X = B with a symmetric
-* positive definite band matrix A using the Cholesky factorization
-* A = U**T*U or A = L*L**T computed by SPBTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL STBSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/spo.html b/doc/spo.html
deleted file mode 100644
index 66f8d31..0000000
--- a/doc/spo.html
+++ /dev/null
@@ -1,1555 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for symmetric or Hermitian positive definite matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for symmetric or Hermitian positive definite matrix</H1>
- <UL>
- <LI><A HREF="#spocon">spocon</A> : </LI>
- <LI><A HREF="#spoequ">spoequ</A> : </LI>
- <LI><A HREF="#spoequb">spoequb</A> : </LI>
- <LI><A HREF="#sporfs">sporfs</A> : </LI>
- <LI><A HREF="#sporfsx">sporfsx</A> : </LI>
- <LI><A HREF="#sposv">sposv</A> : </LI>
- <LI><A HREF="#sposvx">sposvx</A> : </LI>
- <LI><A HREF="#sposvxx">sposvxx</A> : </LI>
- <LI><A HREF="#spotf2">spotf2</A> : </LI>
- <LI><A HREF="#spotrf">spotrf</A> : </LI>
- <LI><A HREF="#spotri">spotri</A> : </LI>
- <LI><A HREF="#spotrs">spotrs</A> : </LI>
- </UL>
-
- <A NAME="spocon"></A>
- <H2>spocon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.spocon( uplo, a, anorm)
- or
- NumRu::Lapack.spocon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPOCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite matrix using the
-* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by SPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) REAL
-* The 1-norm (or infinity-norm) of the symmetric matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spoequ"></A>
- <H2>spoequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.spoequ( a)
- or
- NumRu::Lapack.spoequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SPOEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The N-by-N symmetric positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spoequb"></A>
- <H2>spoequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.spoequb( a)
- or
- NumRu::Lapack.spoequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SPOEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The N-by-N symmetric positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sporfs"></A>
- <H2>sporfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.sporfs( uplo, a, af, b, x)
- or
- NumRu::Lapack.sporfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPORFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite,
-* and provides error bounds and backward error estimates for the
-* solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) REAL array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by SPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SPOTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sporfsx"></A>
- <H2>sporfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.sporfsx( uplo, equed, a, af, s, b, x, params)
- or
- NumRu::Lapack.sporfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPORFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive
-* definite, and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) REAL array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by SPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* S (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sposv"></A>
- <H2>sposv</H2>
-
- <PRE>
-USAGE:
- info, a, b = NumRu::Lapack.sposv( uplo, a, b)
- or
- NumRu::Lapack.sposv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPOSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SPOTRF, SPOTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sposvx"></A>
- <H2>sposvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.sposvx( fact, uplo, a, af, equed, s, b)
- or
- NumRu::Lapack.sposvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
-* compute the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. A and AF will not
-* be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A, except if FACT = 'F' and
-* EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) REAL array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored form
-* of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sposvxx"></A>
- <H2>sposvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.sposvxx( fact, uplo, a, af, equed, s, b, params)
- or
- NumRu::Lapack.sposvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T
-* to compute the solution to a real system of linear equations
-* A * X = B, where A is an N-by-N symmetric positive definite matrix
-* and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. SPOSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* SPOSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* SPOSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what SPOSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A (see argument RCOND). If the reciprocal of the condition number
-* is less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A and AF are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =
-* 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper
-* triangular part of A contains the upper triangular part of the
-* matrix A, and the strictly lower triangular part of A is not
-* referenced. If UPLO = 'L', the leading N-by-N lower triangular
-* part of A contains the lower triangular part of the matrix A, and
-* the strictly upper triangular part of A is not referenced. A is
-* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =
-* 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) REAL array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored
-* form of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spotf2"></A>
- <H2>spotf2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.spotf2( uplo, a)
- or
- NumRu::Lapack.spotf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* SPOTF2 computes the Cholesky factorization of a real symmetric
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L'.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spotrf"></A>
- <H2>spotrf</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.spotrf( uplo, a)
- or
- NumRu::Lapack.spotrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* SPOTRF computes the Cholesky factorization of a real symmetric
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the block version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spotri"></A>
- <H2>spotri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.spotri( uplo, a)
- or
- NumRu::Lapack.spotri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* SPOTRI computes the inverse of a real symmetric positive definite
-* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
-* computed by SPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, as computed by
-* SPOTRF.
-* On exit, the upper or lower triangle of the (symmetric)
-* inverse of A, overwriting the input factor U or L.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SLAUUM, STRTRI, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spotrs"></A>
- <H2>spotrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.spotrs( uplo, a, b)
- or
- NumRu::Lapack.spotrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPOTRS solves a system of linear equations A*X = B with a symmetric
-* positive definite matrix A using the Cholesky factorization
-* A = U**T*U or A = L*L**T computed by SPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by SPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/spp.html b/doc/spp.html
deleted file mode 100644
index 7e033e6..0000000
--- a/doc/spp.html
+++ /dev/null
@@ -1,793 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for symmetric or Hermitian positive definite, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for symmetric or Hermitian positive definite, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#sppcon">sppcon</A> : </LI>
- <LI><A HREF="#sppequ">sppequ</A> : </LI>
- <LI><A HREF="#spprfs">spprfs</A> : </LI>
- <LI><A HREF="#sppsv">sppsv</A> : </LI>
- <LI><A HREF="#sppsvx">sppsvx</A> : </LI>
- <LI><A HREF="#spptrf">spptrf</A> : </LI>
- <LI><A HREF="#spptri">spptri</A> : </LI>
- <LI><A HREF="#spptrs">spptrs</A> : </LI>
- </UL>
-
- <A NAME="sppcon"></A>
- <H2>sppcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.sppcon( uplo, ap, anorm)
- or
- NumRu::Lapack.sppcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite packed matrix using
-* the Cholesky factorization A = U**T*U or A = L*L**T computed by
-* SPPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* ANORM (input) REAL
-* The 1-norm (or infinity-norm) of the symmetric matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sppequ"></A>
- <H2>sppequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.sppequ( uplo, ap)
- or
- NumRu::Lapack.sppequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* SPPEQU computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A in packed storage and reduce
-* its condition number (with respect to the two-norm). S contains the
-* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
-* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
-* This choice of S puts the condition number of B within a factor N of
-* the smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spprfs"></A>
- <H2>spprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.spprfs( uplo, ap, afp, b, x)
- or
- NumRu::Lapack.spprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) REAL array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,
-* packed columnwise in a linear array in the same format as A
-* (see AP).
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SPPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sppsv"></A>
- <H2>sppsv</H2>
-
- <PRE>
-USAGE:
- info, ap, b = NumRu::Lapack.sppsv( uplo, n, ap, b)
- or
- NumRu::Lapack.sppsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPPSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SPPTRF, SPPTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sppsvx"></A>
- <H2>sppsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.sppsvx( fact, uplo, ap, afp, equed, s, b)
- or
- NumRu::Lapack.sppsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
-* compute the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFP contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AP and AFP will not
-* be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array, except if FACT = 'F'
-* and EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). The j-th column of A is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* AFP (input or output) REAL array, dimension
-* (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L', in the same storage
-* format as A. If EQUED .ne. 'N', then AFP is the factored
-* form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L' of the original matrix A.
-*
-* If FACT = 'E', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L' of the equilibrated
-* matrix A (see the description of AP for the form of the
-* equilibrated matrix).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spptrf"></A>
- <H2>spptrf</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.spptrf( uplo, n, ap)
- or
- NumRu::Lapack.spptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPTRF( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* SPPTRF computes the Cholesky factorization of a real symmetric
-* positive definite matrix A stored in packed format.
-*
-* The factorization has the form
-* A = U**T * U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**T*U or A = L*L**T, in the same
-* storage format as A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ======= =======
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spptri"></A>
- <H2>spptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.spptri( uplo, n, ap)
- or
- NumRu::Lapack.spptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPTRI( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* SPPTRI computes the inverse of a real symmetric positive definite
-* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
-* computed by SPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor is stored in AP;
-* = 'L': Lower triangular factor is stored in AP.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, packed columnwise as
-* a linear array. The j-th column of U or L is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* On exit, the upper or lower triangle of the (symmetric)
-* inverse of A, overwriting the input factor U or L.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spptrs"></A>
- <H2>spptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.spptrs( uplo, n, ap, b)
- or
- NumRu::Lapack.spptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPPTRS solves a system of linear equations A*X = B with a symmetric
-* positive definite matrix A in packed storage using the Cholesky
-* factorization A = U**T*U or A = L*L**T computed by SPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL STPSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/spt.html b/doc/spt.html
deleted file mode 100644
index 6a4abb4..0000000
--- a/doc/spt.html
+++ /dev/null
@@ -1,698 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for symmetric or Hermitian positive definite tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for symmetric or Hermitian positive definite tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#sptcon">sptcon</A> : </LI>
- <LI><A HREF="#spteqr">spteqr</A> : </LI>
- <LI><A HREF="#sptrfs">sptrfs</A> : </LI>
- <LI><A HREF="#sptsv">sptsv</A> : </LI>
- <LI><A HREF="#sptsvx">sptsvx</A> : </LI>
- <LI><A HREF="#spttrf">spttrf</A> : </LI>
- <LI><A HREF="#spttrs">spttrs</A> : </LI>
- <LI><A HREF="#sptts2">sptts2</A> : </LI>
- </UL>
-
- <A NAME="sptcon"></A>
- <H2>sptcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.sptcon( d, e, anorm)
- or
- NumRu::Lapack.sptcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SPTCON computes the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric positive definite tridiagonal matrix
-* using the factorization A = L*D*L**T or A = U**T*D*U computed by
-* SPTTRF.
-*
-* Norm(inv(A)) is computed by a direct method, and the reciprocal of
-* the condition number is computed as
-* RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization of A, as computed by SPTTRF.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) off-diagonal elements of the unit bidiagonal factor
-* U or L from the factorization of A, as computed by SPTTRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
-* 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The method used is described in Nicholas J. Higham, "Efficient
-* Algorithms for Computing the Condition Number of a Tridiagonal
-* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spteqr"></A>
- <H2>spteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.spteqr( compz, d, e, z)
- or
- NumRu::Lapack.spteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric positive definite tridiagonal matrix by first factoring the
-* matrix using SPTTRF, and then calling SBDSQR to compute the singular
-* values of the bidiagonal factor.
-*
-* This routine computes the eigenvalues of the positive definite
-* tridiagonal matrix to high relative accuracy. This means that if the
-* eigenvalues range over many orders of magnitude in size, then the
-* small eigenvalues and corresponding eigenvectors will be computed
-* more accurately than, for example, with the standard QR method.
-*
-* The eigenvectors of a full or band symmetric positive definite matrix
-* can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
-* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
-* form, however, may preclude the possibility of obtaining high
-* relative accuracy in the small eigenvalues of the original matrix, if
-* these eigenvalues range over many orders of magnitude.)
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvectors of original symmetric
-* matrix also. Array Z contains the orthogonal
-* matrix used to reduce the original matrix to
-* tridiagonal form.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal
-* matrix.
-* On normal exit, D contains the eigenvalues, in descending
-* order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) REAL array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the orthogonal matrix used in the
-* reduction to tridiagonal form.
-* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
-* original symmetric matrix;
-* if COMPZ = 'I', the orthonormal eigenvectors of the
-* tridiagonal matrix.
-* If INFO > 0 on exit, Z contains the eigenvectors associated
-* with only the stored eigenvalues.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* COMPZ = 'V' or 'I', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is:
-* <= N the Cholesky factorization of the matrix could
-* not be performed because the i-th principal minor
-* was not positive definite.
-* > N the SVD algorithm failed to converge;
-* if INFO = N+i, i off-diagonal elements of the
-* bidiagonal factor did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sptrfs"></A>
- <H2>sptrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.sptrfs( d, e, df, ef, b, x)
- or
- NumRu::Lapack.sptrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SPTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive definite
-* and tridiagonal, and provides error bounds and backward error
-* estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix A.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix A.
-*
-* DF (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization computed by SPTTRF.
-*
-* EF (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of the unit bidiagonal factor
-* L from the factorization computed by SPTTRF.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SPTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sptsv"></A>
- <H2>sptsv</H2>
-
- <PRE>
-USAGE:
- info, d, e, b = NumRu::Lapack.sptsv( d, e, b)
- or
- NumRu::Lapack.sptsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPTSV computes the solution to a real system of linear equations
-* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
-* matrix, and X and B are N-by-NRHS matrices.
-*
-* A is factored as A = L*D*L**T, and the factored form of A is then
-* used to solve the system of equations.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the factorization A = L*D*L**T.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L**T factorization of
-* A. (E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U**T*D*U factorization of A.)
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the solution has not been
-* computed. The factorization has not been completed
-* unless i = N.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL SPTTRF, SPTTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sptsvx"></A>
- <H2>sptsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.sptsvx( fact, d, e, df, ef, b)
- or
- NumRu::Lapack.sptsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SPTSVX uses the factorization A = L*D*L**T to compute the solution
-* to a real system of linear equations A*X = B, where A is an N-by-N
-* symmetric positive definite tridiagonal matrix and X and B are
-* N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
-* is a unit lower bidiagonal matrix and D is diagonal. The
-* factorization can also be regarded as having the form
-* A = U**T*D*U.
-*
-* 2. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, DF and EF contain the factored form of A.
-* D, E, DF, and EF will not be modified.
-* = 'N': The matrix A will be copied to DF and EF and
-* factored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix A.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix A.
-*
-* DF (input or output) REAL array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**T factorization of A.
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**T factorization of A.
-*
-* EF (input or output) REAL array, dimension (N-1)
-* If FACT = 'F', then EF is an input argument and on entry
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**T factorization of A.
-* If FACT = 'N', then EF is an output argument and on exit
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**T factorization of A.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The reciprocal condition number of the matrix A. If RCOND
-* is less than the machine precision (in particular, if
-* RCOND = 0), the matrix is singular to working precision.
-* This condition is indicated by a return code of INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in any
-* element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spttrf"></A>
- <H2>spttrf</H2>
-
- <PRE>
-USAGE:
- info, d, e = NumRu::Lapack.spttrf( d, e)
- or
- NumRu::Lapack.spttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTTRF( N, D, E, INFO )
-
-* Purpose
-* =======
-*
-* SPTTRF computes the L*D*L' factorization of a real symmetric
-* positive definite tridiagonal matrix A. The factorization may also
-* be regarded as having the form A = U'*D*U.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the L*D*L' factorization of A.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L' factorization of A.
-* E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U'*D*U factorization of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite; if k < N, the factorization could not
-* be completed, while if k = N, the factorization was
-* completed, but D(N) <= 0.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="spttrs"></A>
- <H2>spttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.spttrs( d, e, b)
- or
- NumRu::Lapack.spttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SPTTRS solves a tridiagonal system of the form
-* A * X = B
-* using the L*D*L' factorization of A computed by SPTTRF. D is a
-* diagonal matrix specified in the vector D, L is a unit bidiagonal
-* matrix whose subdiagonal is specified in the vector E, and X and B
-* are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* L*D*L' factorization of A.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of the unit bidiagonal factor
-* L from the L*D*L' factorization of A. E can also be regarded
-* as the superdiagonal of the unit bidiagonal factor U from the
-* factorization A = U'*D*U.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL SPTTS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sptts2"></A>
- <H2>sptts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.sptts2( d, e, b)
- or
- NumRu::Lapack.sptts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )
-
-* Purpose
-* =======
-*
-* SPTTS2 solves a tridiagonal system of the form
-* A * X = B
-* using the L*D*L' factorization of A computed by SPTTRF. D is a
-* diagonal matrix specified in the vector D, L is a unit bidiagonal
-* matrix whose subdiagonal is specified in the vector E, and X and B
-* are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* L*D*L' factorization of A.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of the unit bidiagonal factor
-* L from the L*D*L' factorization of A. E can also be regarded
-* as the superdiagonal of the unit bidiagonal factor U from the
-* factorization A = U'*D*U.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, J
-* ..
-* .. External Subroutines ..
- EXTERNAL SSCAL
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ssb.html b/doc/ssb.html
deleted file mode 100644
index 2b50b95..0000000
--- a/doc/ssb.html
+++ /dev/null
@@ -1,1018 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for (real) symmetric band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for (real) symmetric band matrix</H1>
- <UL>
- <LI><A HREF="#ssbev">ssbev</A> : </LI>
- <LI><A HREF="#ssbevd">ssbevd</A> : </LI>
- <LI><A HREF="#ssbevx">ssbevx</A> : </LI>
- <LI><A HREF="#ssbgst">ssbgst</A> : </LI>
- <LI><A HREF="#ssbgv">ssbgv</A> : </LI>
- <LI><A HREF="#ssbgvd">ssbgvd</A> : </LI>
- <LI><A HREF="#ssbgvx">ssbgvx</A> : </LI>
- <LI><A HREF="#ssbtrd">ssbtrd</A> : </LI>
- </UL>
-
- <A NAME="ssbev"></A>
- <H2>ssbev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab = NumRu::Lapack.ssbev( jobz, uplo, kd, ab)
- or
- NumRu::Lapack.ssbev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSBEV computes all the eigenvalues and, optionally, eigenvectors of
-* a real symmetric band matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (max(1,3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssbevd"></A>
- <H2>ssbevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ab = NumRu::Lapack.ssbevd( jobz, uplo, kd, ab, lwork, liwork)
- or
- NumRu::Lapack.ssbevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSBEVD computes all the eigenvalues and, optionally, eigenvectors of
-* a real symmetric band matrix A. If eigenvectors are desired, it uses
-* a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* IF N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.
-* If JOBZ = 'V' and N > 2, LWORK must be at least
-* ( 1 + 5*N + 2*N**2 ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array LIWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssbevx"></A>
- <H2>ssbevx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, ifail, info, ab = NumRu::Lapack.ssbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.ssbevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSBEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric band matrix A. Eigenvalues and eigenvectors can
-* be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* Q (output) REAL array, dimension (LDQ, N)
-* If JOBZ = 'V', the N-by-N orthogonal matrix used in the
-* reduction to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'V', then
-* LDQ >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AB to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssbgst"></A>
- <H2>ssbgst</H2>
-
- <PRE>
-USAGE:
- x, info, ab = NumRu::Lapack.ssbgst( vect, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.ssbgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSBGST reduces a real symmetric-definite banded generalized
-* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
-* such that C has the same bandwidth as A.
-*
-* B must have been previously factorized as S**T*S by SPBSTF, using a
-* split Cholesky factorization. A is overwritten by C = X**T*A*X, where
-* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
-* bandwidth of A.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form the transformation matrix X;
-* = 'V': form X.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the transformed matrix X**T*A*X, stored in the same
-* format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input) REAL array, dimension (LDBB,N)
-* The banded factor S from the split Cholesky factorization of
-* B, as returned by SPBSTF, stored in the first KB+1 rows of
-* the array.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* X (output) REAL array, dimension (LDX,N)
-* If VECT = 'V', the n-by-n matrix X.
-* If VECT = 'N', the array X is not referenced.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X.
-* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
-*
-* WORK (workspace) REAL array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssbgv"></A>
- <H2>ssbgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab, bb = NumRu::Lapack.ssbgv( jobz, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.ssbgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSBGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
-* and banded, and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) REAL array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**T*S, as returned by SPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**T*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER VECT
- INTEGER IINFO, INDE, INDWRK
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssbgvd"></A>
- <H2>ssbgvd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ab, bb = NumRu::Lapack.ssbgvd( jobz, uplo, ka, kb, ab, bb, lwork, liwork)
- or
- NumRu::Lapack.ssbgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSBGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite banded eigenproblem, of the
-* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
-* banded, and B is also positive definite. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) REAL array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**T*S, as returned by SPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so Z**T*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= 3*N.
-* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssbgvx"></A>
- <H2>ssbgvx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.ssbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.ssbgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSBGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a real generalized symmetric-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
-* and banded, and B is also positive definite. Eigenvalues and
-* eigenvectors can be selected by specifying either all eigenvalues,
-* a range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) REAL array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**T*S, as returned by SPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* Q (output) REAL array, dimension (LDQ, N)
-* If JOBZ = 'V', the n-by-n matrix used in the reduction of
-* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
-* and consequently C to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'N',
-* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so Z**T*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (7N)
-*
-* IWORK (workspace/output) INTEGER array, dimension (5N)
-*
-* IFAIL (output) INTEGER array, dimension (M)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvalues that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0 : successful exit
-* < 0 : if INFO = -i, the i-th argument had an illegal value
-* <= N: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in IFAIL.
-* > N : SPBSTF returned an error code; i.e.,
-* if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssbtrd"></A>
- <H2>ssbtrd</H2>
-
- <PRE>
-USAGE:
- d, e, info, ab, q = NumRu::Lapack.ssbtrd( vect, uplo, kd, ab, q)
- or
- NumRu::Lapack.ssbtrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSBTRD reduces a real symmetric band matrix A to symmetric
-* tridiagonal form T by an orthogonal similarity transformation:
-* Q**T * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form Q;
-* = 'V': form Q;
-* = 'U': update a matrix X, by forming X*Q.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the symmetric band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* On exit, the diagonal elements of AB are overwritten by the
-* diagonal elements of the tridiagonal matrix T; if KD > 0, the
-* elements on the first superdiagonal (if UPLO = 'U') or the
-* first subdiagonal (if UPLO = 'L') are overwritten by the
-* off-diagonal elements of T; the rest of AB is overwritten by
-* values generated during the reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T.
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
-*
-* Q (input/output) REAL array, dimension (LDQ,N)
-* On entry, if VECT = 'U', then Q must contain an N-by-N
-* matrix X; if VECT = 'N' or 'V', then Q need not be set.
-*
-* On exit:
-* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
-* if VECT = 'U', Q contains the product X*Q;
-* if VECT = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Modified by Linda Kaufman, Bell Labs.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ssp.html b/doc/ssp.html
deleted file mode 100644
index 3585cee..0000000
--- a/doc/ssp.html
+++ /dev/null
@@ -1,1691 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for symmetric, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for symmetric, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#sspcon">sspcon</A> : </LI>
- <LI><A HREF="#sspev">sspev</A> : </LI>
- <LI><A HREF="#sspevd">sspevd</A> : </LI>
- <LI><A HREF="#sspevx">sspevx</A> : </LI>
- <LI><A HREF="#sspgst">sspgst</A> : </LI>
- <LI><A HREF="#sspgv">sspgv</A> : </LI>
- <LI><A HREF="#sspgvd">sspgvd</A> : </LI>
- <LI><A HREF="#sspgvx">sspgvx</A> : </LI>
- <LI><A HREF="#ssprfs">ssprfs</A> : </LI>
- <LI><A HREF="#sspsv">sspsv</A> : </LI>
- <LI><A HREF="#sspsvx">sspsvx</A> : </LI>
- <LI><A HREF="#ssptrd">ssptrd</A> : </LI>
- <LI><A HREF="#ssptrf">ssptrf</A> : </LI>
- <LI><A HREF="#ssptri">ssptri</A> : </LI>
- <LI><A HREF="#ssptrs">ssptrs</A> : </LI>
- </UL>
-
- <A NAME="sspcon"></A>
- <H2>sspcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.sspcon( uplo, ap, ipiv, anorm)
- or
- NumRu::Lapack.sspcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric packed matrix A using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by SSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSPTRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) REAL array, dimension (2*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspev"></A>
- <H2>sspev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap = NumRu::Lapack.sspev( jobz, uplo, ap)
- or
- NumRu::Lapack.sspev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPEV computes all the eigenvalues and, optionally, eigenvectors of a
-* real symmetric matrix A in packed storage.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspevd"></A>
- <H2>sspevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ap = NumRu::Lapack.sspevd( jobz, uplo, ap, lwork, liwork)
- or
- NumRu::Lapack.sspevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPEVD computes all the eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A in packed storage. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
-* If JOBZ = 'V' and N > 1, LWORK must be at least
-* 1 + 6*N + N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspevx"></A>
- <H2>sspevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap = NumRu::Lapack.sspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.sspevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSPEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A in packed storage. Eigenvalues/vectors
-* can be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the selected eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (8*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspgst"></A>
- <H2>sspgst</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.sspgst( itype, uplo, n, ap, bp)
- or
- NumRu::Lapack.sspgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
-
-* Purpose
-* =======
-*
-* SSPGST reduces a real symmetric-definite generalized eigenproblem
-* to standard form, using packed storage.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
-*
-* B must have been previously factorized as U**T*U or L*L**T by SPPTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
-* = 2 or 3: compute U*A*U**T or L**T*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**T*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**T.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* BP (input) REAL array, dimension (N*(N+1)/2)
-* The triangular factor from the Cholesky factorization of B,
-* stored in the same format as A, as returned by SPPTRF.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspgv"></A>
- <H2>sspgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap, bp = NumRu::Lapack.sspgv( itype, jobz, uplo, ap, bp)
- or
- NumRu::Lapack.sspgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPGV computes all the eigenvalues and, optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be symmetric, stored in packed format,
-* and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) REAL array, dimension
-* (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T, in the same storage
-* format as B.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: SPPTRF or SSPEV returned an error code:
-* <= N: if INFO = i, SSPEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero.
-* > N: if INFO = n + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER TRANS
- INTEGER J, NEIG
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SPPTRF, SSPEV, SSPGST, STPMV, STPSV, XERBLA
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspgvd"></A>
- <H2>sspgvd</H2>
-
- <PRE>
-USAGE:
- w, z, work, iwork, info, ap, bp = NumRu::Lapack.sspgvd( itype, jobz, uplo, ap, bp, lwork, liwork)
- or
- NumRu::Lapack.sspgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be symmetric, stored in packed format, and B is also
-* positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T, in the same storage
-* format as B.
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= 2*N.
-* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: SPPTRF or SSPEVD returned an error code:
-* <= N: if INFO = i, SSPEVD failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspgvx"></A>
- <H2>sspgvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap, bp = NumRu::Lapack.sspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)
- or
- NumRu::Lapack.sspgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSPGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
-* and B are assumed to be symmetric, stored in packed storage, and B
-* is also positive definite. Eigenvalues and eigenvectors can be
-* selected by specifying either a range of values or a range of indices
-* for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A and B are stored;
-* = 'L': Lower triangle of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrix pencil (A,B). N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T, in the same storage
-* format as B.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M))
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (8*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: SPPTRF or SSPEVX returned an error code:
-* <= N: if INFO = i, SSPEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
- CHARACTER TRANS
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssprfs"></A>
- <H2>ssprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.ssprfs( uplo, ap, afp, ipiv, b, x)
- or
- NumRu::Lapack.ssprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) REAL array, dimension (N*(N+1)/2)
-* The factored form of the matrix A. AFP contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by SSPTRF, stored as a packed
-* triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSPTRF.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SSPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspsv"></A>
- <H2>sspsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap, b = NumRu::Lapack.sspsv( uplo, ap, b)
- or
- NumRu::Lapack.sspsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SSPSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix stored in packed format and X
-* and B are N-by-NRHS matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, D is symmetric and block diagonal with 1-by-1
-* and 2-by-2 diagonal blocks. The factored form of A is then used to
-* solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by SSPTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be
-* computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SSPTRF, SSPTRS, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sspsvx"></A>
- <H2>sspsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.sspsvx( fact, uplo, ap, afp, ipiv, b)
- or
- NumRu::Lapack.sspsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
-* A = L*D*L**T to compute the solution to a real system of linear
-* equations A * X = B, where A is an N-by-N symmetric matrix stored
-* in packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AFP and IPIV contain the factored form of
-* A. AP, AFP and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* AFP (input or output) REAL array, dimension
-* (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by SSPTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by SSPTRF.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssptrd"></A>
- <H2>ssptrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, ap = NumRu::Lapack.ssptrd( uplo, ap)
- or
- NumRu::Lapack.ssptrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* SSPTRD reduces a real symmetric matrix A stored in packed form to
-* symmetric tridiagonal form T by an orthogonal similarity
-* transformation: Q**T * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the orthogonal
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the orthogonal matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) REAL array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
-* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
-* overwriting A(i+2:n,i), and tau is stored in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssptrf"></A>
- <H2>ssptrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap = NumRu::Lapack.ssptrf( uplo, ap)
- or
- NumRu::Lapack.ssptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* SSPTRF computes the factorization of a real symmetric matrix A stored
-* in packed format using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L, stored as a packed triangular
-* matrix overwriting A (see below for further details).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssptri"></A>
- <H2>ssptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.ssptri( uplo, ap, ipiv)
- or
- NumRu::Lapack.ssptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSPTRI computes the inverse of a real symmetric indefinite matrix
-* A in packed storage using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by SSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by SSPTRF,
-* stored as a packed triangular matrix.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix, stored as a packed triangular matrix. The j-th column
-* of inv(A) is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
-* if UPLO = 'L',
-* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSPTRF.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssptrs"></A>
- <H2>ssptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ssptrs( uplo, ap, ipiv, b)
- or
- NumRu::Lapack.ssptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SSPTRS solves a system of linear equations A*X = B with a real
-* symmetric matrix A stored in packed format using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by SSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSPTRF.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/sst.html b/doc/sst.html
deleted file mode 100644
index ef35b2f..0000000
--- a/doc/sst.html
+++ /dev/null
@@ -1,1455 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for (real) symmetric tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for (real) symmetric tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#sstebz">sstebz</A> : </LI>
- <LI><A HREF="#sstedc">sstedc</A> : </LI>
- <LI><A HREF="#sstegr">sstegr</A> : </LI>
- <LI><A HREF="#sstein">sstein</A> : </LI>
- <LI><A HREF="#sstemr">sstemr</A> : </LI>
- <LI><A HREF="#ssteqr">ssteqr</A> : </LI>
- <LI><A HREF="#ssterf">ssterf</A> : </LI>
- <LI><A HREF="#sstev">sstev</A> : </LI>
- <LI><A HREF="#sstevd">sstevd</A> : </LI>
- <LI><A HREF="#sstevr">sstevr</A> : </LI>
- <LI><A HREF="#sstevx">sstevx</A> : </LI>
- </UL>
-
- <A NAME="sstebz"></A>
- <H2>sstebz</H2>
-
- <PRE>
-USAGE:
- m, nsplit, w, iblock, isplit, info = NumRu::Lapack.sstebz( range, order, vl, vu, il, iu, abstol, d, e)
- or
- NumRu::Lapack.sstebz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEBZ computes the eigenvalues of a symmetric tridiagonal
-* matrix T. The user may ask for all eigenvalues, all eigenvalues
-* in the half-open interval (VL, VU], or the IL-th through IU-th
-* eigenvalues.
-*
-* To avoid overflow, the matrix must be scaled so that its
-* largest element is no greater than overflow**(1/2) *
-* underflow**(1/4) in absolute value, and for greatest
-* accuracy, it should not be much smaller than that.
-*
-* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
-* Matrix", Report CS41, Computer Science Dept., Stanford
-* University, July 21, 1966.
-*
-
-* Arguments
-* =========
-*
-* RANGE (input) CHARACTER*1
-* = 'A': ("All") all eigenvalues will be found.
-* = 'V': ("Value") all eigenvalues in the half-open interval
-* (VL, VU] will be found.
-* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
-* entire matrix) will be found.
-*
-* ORDER (input) CHARACTER*1
-* = 'B': ("By Block") the eigenvalues will be grouped by
-* split-off block (see IBLOCK, ISPLIT) and
-* ordered from smallest to largest within
-* the block.
-* = 'E': ("Entire matrix")
-* the eigenvalues for the entire matrix
-* will be ordered from smallest to
-* largest.
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix T. N >= 0.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. Eigenvalues less than or equal
-* to VL, or greater than VU, will not be returned. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute tolerance for the eigenvalues. An eigenvalue
-* (or cluster) is considered to be located if it has been
-* determined to lie in an interval whose width is ABSTOL or
-* less. If ABSTOL is less than or equal to zero, then ULP*|T|
-* will be used, where |T| means the 1-norm of T.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix T.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) off-diagonal elements of the tridiagonal matrix T.
-*
-* M (output) INTEGER
-* The actual number of eigenvalues found. 0 <= M <= N.
-* (See also the description of INFO=2,3.)
-*
-* NSPLIT (output) INTEGER
-* The number of diagonal blocks in the matrix T.
-* 1 <= NSPLIT <= N.
-*
-* W (output) REAL array, dimension (N)
-* On exit, the first M elements of W will contain the
-* eigenvalues. (SSTEBZ may use the remaining N-M elements as
-* workspace.)
-*
-* IBLOCK (output) INTEGER array, dimension (N)
-* At each row/column j where E(j) is zero or small, the
-* matrix T is considered to split into a block diagonal
-* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
-* block (from 1 to the number of blocks) the eigenvalue W(i)
-* belongs. (SSTEBZ may use the remaining N-M elements as
-* workspace.)
-*
-* ISPLIT (output) INTEGER array, dimension (N)
-* The splitting points, at which T breaks up into submatrices.
-* The first submatrix consists of rows/columns 1 to ISPLIT(1),
-* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
-* etc., and the NSPLIT-th consists of rows/columns
-* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
-* (Only the first NSPLIT elements will actually be used, but
-* since the user cannot know a priori what value NSPLIT will
-* have, N words must be reserved for ISPLIT.)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: some or all of the eigenvalues failed to converge or
-* were not computed:
-* =1 or 3: Bisection failed to converge for some
-* eigenvalues; these eigenvalues are flagged by a
-* negative block number. The effect is that the
-* eigenvalues may not be as accurate as the
-* absolute and relative tolerances. This is
-* generally caused by unexpectedly inaccurate
-* arithmetic.
-* =2 or 3: RANGE='I' only: Not all of the eigenvalues
-* IL:IU were found.
-* Effect: M < IU+1-IL
-* Cause: non-monotonic arithmetic, causing the
-* Sturm sequence to be non-monotonic.
-* Cure: recalculate, using RANGE='A', and pick
-* out eigenvalues IL:IU. In some cases,
-* increasing the PARAMETER "FUDGE" may
-* make things work.
-* = 4: RANGE='I', and the Gershgorin interval
-* initially used was too small. No eigenvalues
-* were computed.
-* Probable cause: your machine has sloppy
-* floating-point arithmetic.
-* Cure: Increase the PARAMETER "FUDGE",
-* recompile, and try again.
-*
-* Internal Parameters
-* ===================
-*
-* RELFAC REAL, default = 2.0e0
-* The relative tolerance. An interval (a,b] lies within
-* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
-* where "ulp" is the machine precision (distance from 1 to
-* the next larger floating point number.)
-*
-* FUDGE REAL, default = 2
-* A "fudge factor" to widen the Gershgorin intervals. Ideally,
-* a value of 1 should work, but on machines with sloppy
-* arithmetic, this needs to be larger. The default for
-* publicly released versions should be large enough to handle
-* the worst machine around. Note that this has no effect
-* on accuracy of the solution.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstedc"></A>
- <H2>sstedc</H2>
-
- <PRE>
-USAGE:
- work, iwork, info, d, e, z = NumRu::Lapack.sstedc( compz, d, e, z, lwork, liwork)
- or
- NumRu::Lapack.sstedc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the divide and conquer method.
-* The eigenvectors of a full or band real symmetric matrix can also be
-* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
-* matrix to tridiagonal form.
-*
-* This code makes very mild assumptions about floating point
-* arithmetic. It will work on machines with a guard digit in
-* add/subtract, or on those binary machines without guard digits
-* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
-* It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none. See SLAED3 for details.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-* = 'V': Compute eigenvectors of original dense symmetric
-* matrix also. On entry, Z contains the orthogonal
-* matrix used to reduce the original matrix to
-* tridiagonal form.
-*
-* N (input) INTEGER
-* The dimension of the symmetric tridiagonal matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the subdiagonal elements of the tridiagonal matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) REAL array, dimension (LDZ,N)
-* On entry, if COMPZ = 'V', then Z contains the orthogonal
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original symmetric matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
-* If COMPZ = 'V' and N > 1 then LWORK must be at least
-* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
-* where lg( N ) = smallest integer k such
-* that 2**k >= N.
-* If COMPZ = 'I' and N > 1 then LWORK must be at least
-* ( 1 + 4*N + N**2 ).
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LWORK need
-* only be max(1,2*(N-1)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
-* If COMPZ = 'V' and N > 1 then LIWORK must be at least
-* ( 6 + 6*N + 5*N*lg N ).
-* If COMPZ = 'I' and N > 1 then LIWORK must be at least
-* ( 3 + 5*N ).
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LIWORK
-* need only be 1.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The algorithm failed to compute an eigenvalue while
-* working on the submatrix lying in rows and columns
-* INFO/(N+1) through mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-* Modified by Francoise Tisseur, University of Tennessee.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstegr"></A>
- <H2>sstegr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.sstegr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEGR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* SSTEGR is a compatability wrapper around the improved SSTEMR routine.
-* See SSTEMR for further details.
-*
-* One important change is that the ABSTOL parameter no longer provides any
-* benefit and hence is no longer used.
-*
-* Note : SSTEGR and SSTEMR work only on machines which follow
-* IEEE-754 floating-point standard in their handling of infinities and
-* NaNs. Normal execution may create these exceptiona values and hence
-* may abort due to a floating point exception in environments which
-* do not conform to the IEEE-754 standard.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) REAL array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* Unused. Was the absolute error tolerance for the
-* eigenvalues/eigenvectors in previous versions.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-* Supplying N columns is always safe.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* WORK (workspace/output) REAL array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in SLARRE,
-* if INFO = 2X, internal error in SLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by SLARRE or
-* SLARRV, respectively.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL TRYRAC
-* ..
-* .. External Subroutines ..
- EXTERNAL SSTEMR
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstein"></A>
- <H2>sstein</H2>
-
- <PRE>
-USAGE:
- z, ifail, info = NumRu::Lapack.sstein( d, e, w, iblock, isplit)
- or
- NumRu::Lapack.sstein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSTEIN computes the eigenvectors of a real symmetric tridiagonal
-* matrix T corresponding to specified eigenvalues, using inverse
-* iteration.
-*
-* The maximum number of iterations allowed for each eigenvector is
-* specified by an internal parameter MAXITS (currently set to 5).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input) REAL array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix T.
-*
-* E (input) REAL array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix
-* T, in elements 1 to N-1.
-*
-* M (input) INTEGER
-* The number of eigenvectors to be found. 0 <= M <= N.
-*
-* W (input) REAL array, dimension (N)
-* The first M elements of W contain the eigenvalues for
-* which eigenvectors are to be computed. The eigenvalues
-* should be grouped by split-off block and ordered from
-* smallest to largest within the block. ( The output array
-* W from SSTEBZ with ORDER = 'B' is expected here. )
-*
-* IBLOCK (input) INTEGER array, dimension (N)
-* The submatrix indices associated with the corresponding
-* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
-* the first submatrix from the top, =2 if W(i) belongs to
-* the second submatrix, etc. ( The output array IBLOCK
-* from SSTEBZ is expected here. )
-*
-* ISPLIT (input) INTEGER array, dimension (N)
-* The splitting points, at which T breaks up into submatrices.
-* The first submatrix consists of rows/columns 1 to
-* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
-* through ISPLIT( 2 ), etc.
-* ( The output array ISPLIT from SSTEBZ is expected here. )
-*
-* Z (output) REAL array, dimension (LDZ, M)
-* The computed eigenvectors. The eigenvector associated
-* with the eigenvalue W(i) is stored in the i-th column of
-* Z. Any vector which fails to converge is set to its current
-* iterate after MAXITS iterations.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (5*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* IFAIL (output) INTEGER array, dimension (M)
-* On normal exit, all elements of IFAIL are zero.
-* If one or more eigenvectors fail to converge after
-* MAXITS iterations, then their indices are stored in
-* array IFAIL.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge
-* in MAXITS iterations. Their indices are stored in
-* array IFAIL.
-*
-* Internal Parameters
-* ===================
-*
-* MAXITS INTEGER, default = 5
-* The maximum number of iterations performed.
-*
-* EXTRA INTEGER, default = 2
-* The number of iterations performed after norm growth
-* criterion is satisfied, should be at least 1.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstemr"></A>
- <H2>sstemr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.sstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)
- or
- NumRu::Lapack.sstemr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEMR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* Depending on the number of desired eigenvalues, these are computed either
-* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
-* computed by the use of various suitable L D L^T factorizations near clusters
-* of close eigenvalues (referred to as RRRs, Relatively Robust
-* Representations). An informal sketch of the algorithm follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* For more details, see:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-* Further Details
-* 1.SSTEMR works only on machines which follow IEEE-754
-* floating-point standard in their handling of infinities and NaNs.
-* This permits the use of efficient inner loops avoiding a check for
-* zero divisors.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) REAL array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and can be computed with a workspace
-* query by setting NZC = -1, see below.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* NZC (input) INTEGER
-* The number of eigenvectors to be held in the array Z.
-* If RANGE = 'A', then NZC >= max(1,N).
-* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
-* If RANGE = 'I', then NZC >= IU-IL+1.
-* If NZC = -1, then a workspace query is assumed; the
-* routine calculates the number of columns of the array Z that
-* are needed to hold the eigenvectors.
-* This value is returned as the first entry of the Z array, and
-* no error message related to NZC is issued by XERBLA.
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* TRYRAC (input/output) LOGICAL
-* If TRYRAC.EQ..TRUE., indicates that the code should check whether
-* the tridiagonal matrix defines its eigenvalues to high relative
-* accuracy. If so, the code uses relative-accuracy preserving
-* algorithms that might be (a bit) slower depending on the matrix.
-* If the matrix does not define its eigenvalues to high relative
-* accuracy, the code can uses possibly faster algorithms.
-* If TRYRAC.EQ..FALSE., the code is not required to guarantee
-* relatively accurate eigenvalues and can use the fastest possible
-* techniques.
-* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
-* does not define its eigenvalues to high relative accuracy.
-*
-* WORK (workspace/output) REAL array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in SLARRE,
-* if INFO = 2X, internal error in SLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by SLARRE or
-* SLARRV, respectively.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Beresford Parlett, University of California, Berkeley, USA
-* Jim Demmel, University of California, Berkeley, USA
-* Inderjit Dhillon, University of Texas, Austin, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, University of California, Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssteqr"></A>
- <H2>ssteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.ssteqr( compz, d, e, z)
- or
- NumRu::Lapack.ssteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the implicit QL or QR method.
-* The eigenvectors of a full or band symmetric matrix can also be found
-* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to
-* tridiagonal form.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvalues and eigenvectors of the original
-* symmetric matrix. On entry, Z must contain the
-* orthogonal matrix used to reduce the original matrix
-* to tridiagonal form.
-* = 'I': Compute eigenvalues and eigenvectors of the
-* tridiagonal matrix. Z is initialized to the identity
-* matrix.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) REAL array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', then Z contains the orthogonal
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original symmetric matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (max(1,2*N-2))
-* If COMPZ = 'N', then WORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm has failed to find all the eigenvalues in
-* a total of 30*N iterations; if INFO = i, then i
-* elements of E have not converged to zero; on exit, D
-* and E contain the elements of a symmetric tridiagonal
-* matrix which is orthogonally similar to the original
-* matrix.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssterf"></A>
- <H2>ssterf</H2>
-
- <PRE>
-USAGE:
- info, d, e = NumRu::Lapack.ssterf( d, e)
- or
- NumRu::Lapack.ssterf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTERF( N, D, E, INFO )
-
-* Purpose
-* =======
-*
-* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
-* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm failed to find all of the eigenvalues in
-* a total of 30*N iterations; if INFO = i, then i
-* elements of E have not converged to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstev"></A>
- <H2>sstev</H2>
-
- <PRE>
-USAGE:
- z, info, d, e = NumRu::Lapack.sstev( jobz, d, e)
- or
- NumRu::Lapack.sstev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEV computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric tridiagonal matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A, stored in elements 1 to N-1 of E.
-* On exit, the contents of E are destroyed.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with D(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (max(1,2*N-2))
-* If JOBZ = 'N', WORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of E did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstevd"></A>
- <H2>sstevd</H2>
-
- <PRE>
-USAGE:
- z, work, iwork, info, d, e = NumRu::Lapack.sstevd( jobz, d, e, lwork, liwork)
- or
- NumRu::Lapack.sstevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEVD computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric tridiagonal matrix. If eigenvectors are desired, it
-* uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) REAL array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A, stored in elements 1 to N-1 of E.
-* On exit, the contents of E are destroyed.
-*
-* Z (output) REAL array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with D(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.
-* If JOBZ = 'V' and N > 1 then LWORK must be at least
-* ( 1 + 4*N + N**2 ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of E did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstevr"></A>
- <H2>sstevr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstevr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.sstevr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSTEVR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Eigenvalues and
-* eigenvectors can be selected by specifying either a range of values
-* or a range of indices for the desired eigenvalues.
-*
-* Whenever possible, SSTEVR calls SSTEMR to compute the
-* eigenspectrum using Relatively Robust Representations. SSTEMR
-* computes eigenvalues by the dqds algorithm, while orthogonal
-* eigenvectors are computed from various "good" L D L^T representations
-* (also known as Relatively Robust Representations). Gram-Schmidt
-* orthogonalization is avoided as far as possible. More specifically,
-* the various steps of the algorithm are as follows. For the i-th
-* unreduced block of T,
-* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
-* is a relatively robust representation,
-* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
-* relative accuracy by the dqds algorithm,
-* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
-* close to the cluster, and go to step (a),
-* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
-* compute the corresponding eigenvector by forming a
-* rank-revealing twisted factorization.
-* The desired accuracy of the output can be specified by the input
-* parameter ABSTOL.
-*
-* For more details, see "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
-* Computer Science Division Technical Report No. UCB//CSD-97-971,
-* UC Berkeley, May 1997.
-*
-*
-* Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested
-* on machines which conform to the ieee-754 floating point standard.
-* SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and
-* when partial spectrum requests are made.
-*
-* Normal execution of SSTEMR may create NaNs and infinities and
-* hence may abort due to a floating point exception in environments
-* which do not handle NaNs and infinities in the ieee standard default
-* manner.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
-********** SSTEIN are called
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, D may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* E (input/output) REAL array, dimension (max(1,N-1))
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A in elements 1 to N-1 of E.
-* On exit, E may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* If high relative accuracy is important, set ABSTOL to
-* SLAMCH( 'Safe minimum' ). Doing so will guarantee that
-* eigenvalues are computed to high relative accuracy when
-* possible in future releases. The current code does not
-* make any guarantees about high relative accuracy, but
-* future releases will. See J. Barlow and J. Demmel,
-* "Computing Accurate Eigensystems of Scaled Diagonally
-* Dominant Matrices", LAPACK Working Note #7, for a discussion
-* of which matrices define their eigenvalues to high relative
-* accuracy.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ).
-********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal (and
-* minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 20*N.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal (and
-* minimal) LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= 10*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: Internal error
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Ken Stanley, Computer Science Division, University of
-* California at Berkeley, USA
-* Jason Riedy, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="sstevx"></A>
- <H2>sstevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, d, e = NumRu::Lapack.sstevx( jobz, range, d, e, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.sstevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSTEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix A. Eigenvalues and
-* eigenvectors can be selected by specifying either a range of values
-* or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) REAL array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A.
-* On exit, D may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* E (input/output) REAL array, dimension (max(1,N-1))
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A in elements 1 to N-1 of E.
-* On exit, E may be multiplied by a constant factor chosen
-* to avoid over/underflow in computing the eigenvalues.
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less
-* than or equal to zero, then EPS*|T| will be used in
-* its place, where |T| is the 1-norm of the tridiagonal
-* matrix.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge (INFO > 0), then that
-* column of Z contains the latest approximation to the
-* eigenvector, and the index of the eigenvector is returned
-* in IFAIL. If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (5*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ssy.html b/doc/ssy.html
deleted file mode 100644
index fe9144d..0000000
--- a/doc/ssy.html
+++ /dev/null
@@ -1,3518 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for symmetric matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for symmetric matrix</H1>
- <UL>
- <LI><A HREF="#ssycon">ssycon</A> : </LI>
- <LI><A HREF="#ssyconv">ssyconv</A> : </LI>
- <LI><A HREF="#ssyequb">ssyequb</A> : </LI>
- <LI><A HREF="#ssyev">ssyev</A> : </LI>
- <LI><A HREF="#ssyevd">ssyevd</A> : </LI>
- <LI><A HREF="#ssyevr">ssyevr</A> : </LI>
- <LI><A HREF="#ssyevx">ssyevx</A> : </LI>
- <LI><A HREF="#ssygs2">ssygs2</A> : </LI>
- <LI><A HREF="#ssygst">ssygst</A> : </LI>
- <LI><A HREF="#ssygv">ssygv</A> : </LI>
- <LI><A HREF="#ssygvd">ssygvd</A> : </LI>
- <LI><A HREF="#ssygvx">ssygvx</A> : </LI>
- <LI><A HREF="#ssyrfs">ssyrfs</A> : </LI>
- <LI><A HREF="#ssyrfsx">ssyrfsx</A> : </LI>
- <LI><A HREF="#ssysv">ssysv</A> : </LI>
- <LI><A HREF="#ssysvx">ssysvx</A> : </LI>
- <LI><A HREF="#ssysvxx">ssysvxx</A> : </LI>
- <LI><A HREF="#ssyswapr">ssyswapr</A> : </LI>
- <LI><A HREF="#ssytd2">ssytd2</A> : </LI>
- <LI><A HREF="#ssytf2">ssytf2</A> : </LI>
- <LI><A HREF="#ssytrd">ssytrd</A> : </LI>
- <LI><A HREF="#ssytrf">ssytrf</A> : </LI>
- <LI><A HREF="#ssytri">ssytri</A> : </LI>
- <LI><A HREF="#ssytri2">ssytri2</A> : </LI>
- <LI><A HREF="#ssytri2x">ssytri2x</A> : </LI>
- <LI><A HREF="#ssytrs">ssytrs</A> : </LI>
- <LI><A HREF="#ssytrs2">ssytrs2</A> : </LI>
- </UL>
-
- <A NAME="ssycon"></A>
- <H2>ssycon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.ssycon( uplo, a, ipiv, anorm)
- or
- NumRu::Lapack.ssycon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a real symmetric matrix A using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by SSYTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by SSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* ANORM (input) REAL
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) REAL array, dimension (2*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyconv"></A>
- <H2>ssyconv</H2>
-
- <PRE>
-USAGE:
- info = NumRu::Lapack.ssyconv( uplo, way, a, ipiv)
- or
- NumRu::Lapack.ssyconv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYCONV convert A given by TRF into L and D and vice-versa.
-* Get Non-diag elements of D (returned in workspace) and
-* apply or reverse permutation done in TRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* WAY (input) CHARACTER*1
-* = 'C': Convert
-* = 'R': Revert
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by SSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1.
-* LWORK = N
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyequb"></A>
- <H2>ssyequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.ssyequb( uplo, a)
- or
- NumRu::Lapack.ssyequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYEQUB computes row and column scalings intended to equilibrate a
-* symmetric matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The N-by-N symmetric matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) REAL array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) REAL
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) REAL
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* Further Details
-* ======= =======
-*
-* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization",
-* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.
-* DOI 10.1023/B:NUMA.0000016606.32820.69
-* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyev"></A>
- <H2>ssyev</H2>
-
- <PRE>
-USAGE:
- w, work, info, a = NumRu::Lapack.ssyev( jobz, uplo, a, lwork)
- or
- NumRu::Lapack.ssyev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYEV computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,3*N-1).
-* For optimal efficiency, LWORK >= (NB+2)*N,
-* where NB is the blocksize for SSYTRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyevd"></A>
- <H2>ssyevd</H2>
-
- <PRE>
-USAGE:
- w, work, iwork, info, a = NumRu::Lapack.ssyevd( jobz, uplo, a, lwork, liwork)
- or
- NumRu::Lapack.ssyevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYEVD computes all eigenvalues and, optionally, eigenvectors of a
-* real symmetric matrix A. If eigenvectors are desired, it uses a
-* divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-* Because of large use of BLAS of level 3, SSYEVD needs N**2 more
-* workspace than SSYEVX.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) REAL array,
-* dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
-* If JOBZ = 'V' and N > 1, LWORK must be at least
-* 1 + 6*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
-* to converge; i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* if INFO = i and JOBZ = 'V', then the algorithm failed
-* to compute an eigenvalue while working on the submatrix
-* lying in rows and columns INFO/(N+1) through
-* mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-* Modified by Francoise Tisseur, University of Tennessee.
-*
-* Modified description of INFO. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyevr"></A>
- <H2>ssyevr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.ssyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.ssyevr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYEVR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
-* selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-* SSYEVR first reduces the matrix A to tridiagonal form T with a call
-* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute
-* the eigenspectrum using Relatively Robust Representations. SSTEMR
-* computes eigenvalues by the dqds algorithm, while orthogonal
-* eigenvectors are computed from various "good" L D L^T representations
-* (also known as Relatively Robust Representations). Gram-Schmidt
-* orthogonalization is avoided as far as possible. More specifically,
-* the various steps of the algorithm are as follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* The desired accuracy of the output can be specified by the input
-* parameter ABSTOL.
-*
-* For more details, see SSTEMR's documentation and:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-*
-* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested
-* on machines which conform to the ieee-754 floating point standard.
-* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and
-* when partial spectrum requests are made.
-*
-* Normal execution of SSTEMR may create NaNs and infinities and
-* hence may abort due to a floating point exception in environments
-* which do not handle NaNs and infinities in the ieee standard default
-* manner.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
-********** SSTEIN are called
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* If high relative accuracy is important, set ABSTOL to
-* SLAMCH( 'Safe minimum' ). Doing so will guarantee that
-* eigenvalues are computed to high relative accuracy when
-* possible in future releases. The current code does not
-* make any guarantees about high relative accuracy, but
-* future releases will. See J. Barlow and J. Demmel,
-* "Computing Accurate Eigensystems of Scaled Diagonally
-* Dominant Matrices", LAPACK Working Note #7, for a discussion
-* of which matrices define their eigenvalues to high relative
-* accuracy.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-* Supplying N columns is always safe.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ).
-********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,26*N).
-* For optimal efficiency, LWORK >= (NB+6)*N,
-* where NB is the max of the blocksize for SSYTRD and SORMTR
-* returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: Internal error
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Ken Stanley, Computer Science Division, University of
-* California at Berkeley, USA
-* Jason Riedy, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyevx"></A>
- <H2>ssyevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a = NumRu::Lapack.ssyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)
- or
- NumRu::Lapack.ssyevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSYEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
-* selected by specifying either a range of values or a range of indices
-* for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= 1, when N <= 1;
-* otherwise 8*N.
-* For optimal efficiency, LWORK >= (NB+3)*N,
-* where NB is the max of the blocksize for SSYTRD and SORMTR
-* returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssygs2"></A>
- <H2>ssygs2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ssygs2( itype, uplo, a, b)
- or
- NumRu::Lapack.ssygs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SSYGS2 reduces a real symmetric-definite generalized eigenproblem
-* to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
-*
-* B must have been previously factorized as U'*U or L*L' by SPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
-* = 2 or 3: compute U*A*U' or L'*A*L.
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored, and how B has been factorized.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) REAL array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by SPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssygst"></A>
- <H2>ssygst</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ssygst( itype, uplo, a, b)
- or
- NumRu::Lapack.ssygst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SSYGST reduces a real symmetric-definite generalized eigenproblem
-* to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
-*
-* B must have been previously factorized as U**T*U or L*L**T by SPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
-* = 2 or 3: compute U*A*U**T or L**T*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**T*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**T.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) REAL array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by SPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssygv"></A>
- <H2>ssygv</H2>
-
- <PRE>
-USAGE:
- w, work, info, a, b = NumRu::Lapack.ssygv( itype, jobz, uplo, a, b, lwork)
- or
- NumRu::Lapack.ssygv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be symmetric and B is also
-* positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the symmetric positive definite matrix B.
-* If UPLO = 'U', the leading N-by-N upper triangular part of B
-* contains the upper triangular part of the matrix B.
-* If UPLO = 'L', the leading N-by-N lower triangular part of B
-* contains the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,3*N-1).
-* For optimal efficiency, LWORK >= (NB+2)*N,
-* where NB is the blocksize for SSYTRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: SPOTRF or SSYEV returned an error code:
-* <= N: if INFO = i, SSYEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssygvd"></A>
- <H2>ssygvd</H2>
-
- <PRE>
-USAGE:
- w, work, iwork, info, a, b = NumRu::Lapack.ssygvd( itype, jobz, uplo, a, b, lwork, liwork)
- or
- NumRu::Lapack.ssygvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be symmetric and B is also positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB, N)
-* On entry, the symmetric matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) REAL array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
-* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK and IWORK
-* arrays, returns these values as the first entries of the WORK
-* and IWORK arrays, and no error message related to LWORK or
-* LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK >= 1.
-* If JOBZ = 'N' and N > 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK and IWORK arrays, and no error message related to
-* LWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: SPOTRF or SSYEVD returned an error code:
-* <= N: if INFO = i and JOBZ = 'N', then the algorithm
-* failed to converge; i off-diagonal elements of an
-* intermediate tridiagonal form did not converge to
-* zero;
-* if INFO = i and JOBZ = 'V', then the algorithm
-* failed to compute an eigenvalue while working on
-* the submatrix lying in rows and columns INFO/(N+1)
-* through mod(INFO,N+1);
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* Modified so that no backsubstitution is performed if SSYEVD fails to
-* converge (NEIG in old code could be greater than N causing out of
-* bounds reference to A - reported by Ralf Meyer). Also corrected the
-* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssygvx"></A>
- <H2>ssygvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a, b = NumRu::Lapack.ssygvx( itype, jobz, range, uplo, a, b, ldb, vl, vu, il, iu, abstol, ldz, lwork)
- or
- NumRu::Lapack.ssygvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* SSYGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a real generalized symmetric-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
-* and B are assumed to be symmetric and B is also positive definite.
-* Eigenvalues and eigenvectors can be selected by specifying either a
-* range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A and B are stored;
-* = 'L': Lower triangle of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrix pencil (A,B). N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDA, N)
-* On entry, the symmetric matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**T*U or B = L*L**T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) REAL
-* VU (input) REAL
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) REAL
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*SLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) REAL array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) REAL array, dimension (LDZ, max(1,M))
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,8*N).
-* For optimal efficiency, LWORK >= (NB+3)*N,
-* where NB is the blocksize for SSYTRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: SPOTRF or SSYEVX returned an error code:
-* <= N: if INFO = i, SSYEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyrfs"></A>
- <H2>ssyrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.ssyrfs( uplo, a, af, ipiv, b, x)
- or
- NumRu::Lapack.ssyrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) REAL array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by SSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SSYTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyrfsx"></A>
- <H2>ssyrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.ssyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)
- or
- NumRu::Lapack.ssyrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYRFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the
-* solution. In addition to normwise error bound, the code provides
-* maximum componentwise error bound if possible. See comments for
-* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) REAL array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or A =
-* L*D*L**T as computed by SSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) REAL array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by SGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssysv"></A>
- <H2>ssysv</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a, b = NumRu::Lapack.ssysv( uplo, a, b, lwork)
- or
- NumRu::Lapack.ssysv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYSV computes the solution to a real system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
-* used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the block diagonal matrix D and the
-* multipliers used to obtain the factor U or L from the
-* factorization A = U*D*U**T or A = L*D*L**T as computed by
-* SSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by SSYTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= 1, and for best performance
-* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
-* SSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LWKOPT, NB
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL ILAENV, LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SSYTRF, SSYTRS2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssysvx"></A>
- <H2>ssysvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.ssysvx( fact, uplo, a, af, ipiv, b, lwork)
- or
- NumRu::Lapack.ssysvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYSVX uses the diagonal pivoting factorization to compute the
-* solution to a real system of linear equations A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
-* The form of the factorization is
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AF and IPIV contain the factored form of
-* A. AF and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) REAL array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by SSYTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by SSYTRF.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= max(1,3*N), and for best
-* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
-* NB is the optimal blocksize for SSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssysvxx"></A>
- <H2>ssysvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.ssysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)
- or
- NumRu::Lapack.ssysvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYSVXX uses the diagonal pivoting factorization to compute the
-* solution to a real system of linear equations A * X = B, where A
-* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. SSYSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* SSYSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* SSYSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what SSYSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 3. If some D(i,i)=0, so that D is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is
-* less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(R) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) REAL array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T as computed by SSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block
-* structure of D, as determined by SSYTRF. If IPIV(k) > 0,
-* then rows and columns k and IPIV(k) were interchanged and
-* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and
-* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and
-* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2
-* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,
-* then rows and columns k+1 and -IPIV(k) were interchanged
-* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block
-* structure of D, as determined by SSYTRF.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) REAL array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) REAL array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) REAL
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) REAL
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * slamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * slamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * slamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) REAL array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) REAL array, dimension (4*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssyswapr"></A>
- <H2>ssyswapr</H2>
-
- <PRE>
-USAGE:
- a = NumRu::Lapack.ssyswapr( uplo, a, i1, i2)
- or
- NumRu::Lapack.ssyswapr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYSWAPR( UPLO, N, A, I1, I2)
-
-* Purpose
-* =======
-*
-* SSYSWAPR applies an elementary permutation on the rows and the columns of
-* a symmetric matrix.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by SSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* I1 (input) INTEGER
-* Index of the first row to swap
-*
-* I2 (input) INTEGER
-* Index of the second row to swap
-*
-
-* =====================================================================
-*
-* ..
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
- REAL TMP
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL SSWAP
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytd2"></A>
- <H2>ssytd2</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, a = NumRu::Lapack.ssytd2( uplo, a)
- or
- NumRu::Lapack.ssytd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
-* form T by an orthogonal similarity transformation: Q' * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the orthogonal
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the orthogonal matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) REAL array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytf2"></A>
- <H2>ssytf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.ssytf2( uplo, a)
- or
- NumRu::Lapack.ssytf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* SSYTF2 computes the factorization of a real symmetric matrix A using
-* the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U' or A = L*D*L'
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, U' is the transpose of U, and D is symmetric and
-* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 09-29-06 - patch from
-* Bobby Cheng, MathWorks
-*
-* Replace l.204 and l.372
-* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
-* by
-* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
-*
-* 01-01-96 - Based on modifications by
-* J. Lewis, Boeing Computer Services Company
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytrd"></A>
- <H2>ssytrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, work, info, a = NumRu::Lapack.ssytrd( uplo, a, lwork)
- or
- NumRu::Lapack.ssytrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYTRD reduces a real symmetric matrix A to real symmetric
-* tridiagonal form T by an orthogonal similarity transformation:
-* Q**T * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the orthogonal
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the orthogonal matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) REAL array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) REAL array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) REAL array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real scalar, and v is a real vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytrf"></A>
- <H2>ssytrf</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a = NumRu::Lapack.ssytrf( uplo, a, lwork)
- or
- NumRu::Lapack.ssytrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYTRF computes the factorization of a real symmetric matrix A using
-* the Bunch-Kaufman diagonal pivoting method. The form of the
-* factorization is
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1. For best performance
-* LWORK >= N*NB, where NB is the block size returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER
- INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL SLASYF, SSYTF2, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytri"></A>
- <H2>ssytri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ssytri( uplo, a, ipiv)
- or
- NumRu::Lapack.ssytri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYTRI computes the inverse of a real symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* SSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by SSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytri2"></A>
- <H2>ssytri2</H2>
-
- <PRE>
-USAGE:
- info, a, work = NumRu::Lapack.ssytri2( uplo, a, ipiv, work)
- or
- NumRu::Lapack.ssytri2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYTRI2 computes the inverse of a real symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* SSYTRF. SSYTRI2 sets the LEADING DIMENSION of the workspace
-* before calling SSYTRI2X that actually computes the inverse.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by SSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NB structure of D
-* as determined by SSYTRF.
-*
-* WORK (workspace) REAL array, dimension (N+NB+1)*(NB+3)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* WORK is size >= (N+NB+1)*(NB+3)
-* If LDWORK = -1, then a workspace query is assumed; the routine
-* calculates:
-* - the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array,
-* - and no error message related to LDWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, LQUERY
- INTEGER MINSIZE, NBMAX
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL SSYTRI2X
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytri2x"></A>
- <H2>ssytri2x</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ssytri2x( uplo, a, ipiv, nb)
- or
- NumRu::Lapack.ssytri2x # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )
-
-* Purpose
-* =======
-*
-* SSYTRI2X computes the inverse of a real symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* SSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the NNB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by SSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NNB structure of D
-* as determined by SSYTRF.
-*
-* WORK (workspace) REAL array, dimension (N+NNB+1,NNB+3)
-*
-* NB (input) INTEGER
-* Block size
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytrs"></A>
- <H2>ssytrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ssytrs( uplo, a, ipiv, b)
- or
- NumRu::Lapack.ssytrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* SSYTRS solves a system of linear equations A*X = B with a real
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by SSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by SSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ssytrs2"></A>
- <H2>ssytrs2</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ssytrs2( uplo, a, ipiv, b)
- or
- NumRu::Lapack.ssytrs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )
-
-* Purpose
-* =======
-*
-* SSYTRS2 solves a system of linear equations A*X = B with a real
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by SSYTRF and converted by SSYCONV.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by SSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by SSYTRF.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/stb.html b/doc/stb.html
deleted file mode 100644
index a537c59..0000000
--- a/doc/stb.html
+++ /dev/null
@@ -1,292 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for triangular band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for triangular band matrix</H1>
- <UL>
- <LI><A HREF="#stbcon">stbcon</A> : </LI>
- <LI><A HREF="#stbrfs">stbrfs</A> : </LI>
- <LI><A HREF="#stbtrs">stbtrs</A> : </LI>
- </UL>
-
- <A NAME="stbcon"></A>
- <H2>stbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.stbcon( norm, uplo, diag, kd, ab)
- or
- NumRu::Lapack.stbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STBCON estimates the reciprocal of the condition number of a
-* triangular band matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stbrfs"></A>
- <H2>stbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.stbrfs( uplo, trans, diag, kd, ab, b, x)
- or
- NumRu::Lapack.stbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STBRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular band
-* coefficient matrix.
-*
-* The solution matrix X must be computed by STBTRS or some other
-* means before entering this routine. STBRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) REAL array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stbtrs"></A>
- <H2>stbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.stbtrs( uplo, trans, diag, kd, ab, b)
- or
- NumRu::Lapack.stbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* STBTRS solves a triangular system of the form
-*
-* A * X = B or A**T * X = B,
-*
-* where A is a triangular band matrix of order N, and B is an
-* N-by NRHS matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of AB. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/stg.html b/doc/stg.html
deleted file mode 100644
index 264dcf7..0000000
--- a/doc/stg.html
+++ /dev/null
@@ -1,1752 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</H1>
- <UL>
- <LI><A HREF="#stgevc">stgevc</A> : </LI>
- <LI><A HREF="#stgex2">stgex2</A> : </LI>
- <LI><A HREF="#stgexc">stgexc</A> : </LI>
- <LI><A HREF="#stgsen">stgsen</A> : </LI>
- <LI><A HREF="#stgsja">stgsja</A> : </LI>
- <LI><A HREF="#stgsna">stgsna</A> : </LI>
- <LI><A HREF="#stgsy2">stgsy2</A> : </LI>
- <LI><A HREF="#stgsyl">stgsyl</A> : </LI>
- </UL>
-
- <A NAME="stgevc"></A>
- <H2>stgevc</H2>
-
- <PRE>
-USAGE:
- m, info, vl, vr = NumRu::Lapack.stgevc( side, howmny, select, s, p, vl, vr)
- or
- NumRu::Lapack.stgevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )
-
-* Purpose
-* =======
-*
-* STGEVC computes some or all of the right and/or left eigenvectors of
-* a pair of real matrices (S,P), where S is a quasi-triangular matrix
-* and P is upper triangular. Matrix pairs of this type are produced by
-* the generalized Schur factorization of a matrix pair (A,B):
-*
-* A = Q*S*Z**T, B = Q*P*Z**T
-*
-* as computed by SGGHRD + SHGEQZ.
-*
-* The right eigenvector x and the left eigenvector y of (S,P)
-* corresponding to an eigenvalue w are defined by:
-*
-* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
-*
-* where y**H denotes the conjugate tranpose of y.
-* The eigenvalues are not input to this routine, but are computed
-* directly from the diagonal blocks of S and P.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
-* where Z and Q are input matrices.
-* If Q and Z are the orthogonal factors from the generalized Schur
-* factorization of a matrix pair (A,B), then Z*X and Q*Y
-* are the matrices of right and left eigenvectors of (A,B).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed by the matrices in VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* specified by the logical array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY='S', SELECT specifies the eigenvectors to be
-* computed. If w(j) is a real eigenvalue, the corresponding
-* real eigenvector is computed if SELECT(j) is .TRUE..
-* If w(j) and w(j+1) are the real and imaginary parts of a
-* complex eigenvalue, the corresponding complex eigenvector
-* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
-* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
-* set to .FALSE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrices S and P. N >= 0.
-*
-* S (input) REAL array, dimension (LDS,N)
-* The upper quasi-triangular matrix S from a generalized Schur
-* factorization, as computed by SHGEQZ.
-*
-* LDS (input) INTEGER
-* The leading dimension of array S. LDS >= max(1,N).
-*
-* P (input) REAL array, dimension (LDP,N)
-* The upper triangular matrix P from a generalized Schur
-* factorization, as computed by SHGEQZ.
-* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
-* of S must be in positive diagonal form.
-*
-* LDP (input) INTEGER
-* The leading dimension of array P. LDP >= max(1,N).
-*
-* VL (input/output) REAL array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the orthogonal matrix Q
-* of left Schur vectors returned by SHGEQZ).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
-* SELECT, stored consecutively in the columns of
-* VL, in the same order as their eigenvalues.
-*
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part, and the second the imaginary part.
-*
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'B', LDVL >= N.
-*
-* VR (input/output) REAL array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Z (usually the orthogonal matrix Z
-* of right Schur vectors returned by SHGEQZ).
-*
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
-* if HOWMNY = 'B' or 'b', the matrix Z*X;
-* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
-* specified by SELECT, stored consecutively in the
-* columns of VR, in the same order as their
-* eigenvalues.
-*
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part and the second the imaginary part.
-*
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B', LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
-* is set to N. Each selected real eigenvector occupies one
-* column and each selected complex eigenvector occupies two
-* columns.
-*
-* WORK (workspace) REAL array, dimension (6*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
-* eigenvalue.
-*
-
-* Further Details
-* ===============
-*
-* Allocation of workspace:
-* ---------- -- ---------
-*
-* WORK( j ) = 1-norm of j-th column of A, above the diagonal
-* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
-* WORK( 2*N+1:3*N ) = real part of eigenvector
-* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
-* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
-* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
-*
-* Rowwise vs. columnwise solution methods:
-* ------- -- ---------- -------- -------
-*
-* Finding a generalized eigenvector consists basically of solving the
-* singular triangular system
-*
-* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
-*
-* Consider finding the i-th right eigenvector (assume all eigenvalues
-* are real). The equation to be solved is:
-* n i
-* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
-* k=j k=j
-*
-* where C = (A - w B) (The components v(i+1:n) are 0.)
-*
-* The "rowwise" method is:
-*
-* (1) v(i) := 1
-* for j = i-1,. . .,1:
-* i
-* (2) compute s = - sum C(j,k) v(k) and
-* k=j+1
-*
-* (3) v(j) := s / C(j,j)
-*
-* Step 2 is sometimes called the "dot product" step, since it is an
-* inner product between the j-th row and the portion of the eigenvector
-* that has been computed so far.
-*
-* The "columnwise" method consists basically in doing the sums
-* for all the rows in parallel. As each v(j) is computed, the
-* contribution of v(j) times the j-th column of C is added to the
-* partial sums. Since FORTRAN arrays are stored columnwise, this has
-* the advantage that at each step, the elements of C that are accessed
-* are adjacent to one another, whereas with the rowwise method, the
-* elements accessed at a step are spaced LDS (and LDP) words apart.
-*
-* When finding left eigenvectors, the matrix in question is the
-* transpose of the one in storage, so the rowwise method then
-* actually accesses columns of A and B at each step, and so is the
-* preferred method.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stgex2"></A>
- <H2>stgex2</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2)
- or
- NumRu::Lapack.stgex2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
-* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
-* (A, B) by an orthogonal equivalence transformation.
-*
-* (A, B) must be in generalized real Schur canonical form (as returned
-* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
-* diagonal blocks. B is upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL arrays, dimensions (LDA,N)
-* On entry, the matrix A in the pair (A, B).
-* On exit, the updated matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL arrays, dimensions (LDB,N)
-* On entry, the matrix B in the pair (A, B).
-* On exit, the updated matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) REAL array, dimension (LDZ,N)
-* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
-* On exit, the updated matrix Q.
-* Not referenced if WANTQ = .FALSE..
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) REAL array, dimension (LDZ,N)
-* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
-* On exit, the updated matrix Z.
-* Not referenced if WANTZ = .FALSE..
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* J1 (input) INTEGER
-* The index to the first block (A11, B11). 1 <= J1 <= N.
-*
-* N1 (input) INTEGER
-* The order of the first block (A11, B11). N1 = 0, 1 or 2.
-*
-* N2 (input) INTEGER
-* The order of the second block (A22, B22). N2 = 0, 1 or 2.
-*
-* WORK (workspace) REAL array, dimension (MAX(1,LWORK)).
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
-*
-* INFO (output) INTEGER
-* =0: Successful exit
-* >0: If INFO = 1, the transformed matrix (A, B) would be
-* too far from generalized Schur form; the blocks are
-* not swapped and (A, B) and (Q, Z) are unchanged.
-* The problem of swapping is too ill-conditioned.
-* <0: If INFO = -16: LWORK is too small. Appropriate value
-* for LWORK is returned in WORK(1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* In the current code both weak and strong stability tests are
-* performed. The user can omit the strong stability test by changing
-* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
-* details.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software,
-* Report UMINF - 94.04, Department of Computing Science, Umea
-* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
-* Note 87. To appear in Numerical Algorithms, 1996.
-*
-* =====================================================================
-* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO
-* loops. Sven Hammarling, 1/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stgexc"></A>
- <H2>stgexc</H2>
-
- <PRE>
-USAGE:
- work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, lwork)
- or
- NumRu::Lapack.stgexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* STGEXC reorders the generalized real Schur decomposition of a real
-* matrix pair (A,B) using an orthogonal equivalence transformation
-*
-* (A, B) = Q * (A, B) * Z',
-*
-* so that the diagonal block of (A, B) with row index IFST is moved
-* to row ILST.
-*
-* (A, B) must be in generalized real Schur canonical form (as returned
-* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
-* diagonal blocks. B is upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the matrix A in generalized real Schur canonical
-* form.
-* On exit, the updated matrix A, again in generalized
-* real Schur canonical form.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB,N)
-* On entry, the matrix B in generalized real Schur canonical
-* form (A,B).
-* On exit, the updated matrix B, again in generalized
-* real Schur canonical form (A,B).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) REAL array, dimension (LDZ,N)
-* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
-* On exit, the updated matrix Q.
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) REAL array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
-* On exit, the updated matrix Z.
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* IFST (input/output) INTEGER
-* ILST (input/output) INTEGER
-* Specify the reordering of the diagonal blocks of (A, B).
-* The block with row index IFST is moved to row ILST, by a
-* sequence of swapping between adjacent blocks.
-* On exit, if IFST pointed on entry to the second row of
-* a 2-by-2 block, it is changed to point to the first row;
-* ILST always points to the first row of the block in its
-* final position (which may differ from its input value by
-* +1 or -1). 1 <= IFST, ILST <= N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* =0: successful exit.
-* <0: if INFO = -i, the i-th argument had an illegal value.
-* =1: The transformed matrix pair (A, B) would be too far
-* from generalized Schur form; the problem is ill-
-* conditioned. (A, B) may have been partially reordered,
-* and ILST points to the first row of the current
-* position of the block being moved.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stgsen"></A>
- <H2>stgsen</H2>
-
- <PRE>
-USAGE:
- alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)
- or
- NumRu::Lapack.stgsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* STGSEN reorders the generalized real Schur decomposition of a real
-* matrix pair (A, B) (in terms of an orthonormal equivalence trans-
-* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
-* appears in the leading diagonal blocks of the upper quasi-triangular
-* matrix A and the upper triangular B. The leading columns of Q and
-* Z form orthonormal bases of the corresponding left and right eigen-
-* spaces (deflating subspaces). (A, B) must be in generalized real
-* Schur canonical form (as returned by SGGES), i.e. A is block upper
-* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
-* triangular.
-*
-* STGSEN also computes the generalized eigenvalues
-*
-* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
-*
-* of the reordered matrix pair (A, B).
-*
-* Optionally, STGSEN computes the estimates of reciprocal condition
-* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
-* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
-* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
-* the selected cluster and the eigenvalues outside the cluster, resp.,
-* and norms of "projections" onto left and right eigenspaces w.r.t.
-* the selected cluster in the (1,1)-block.
-*
-
-* Arguments
-* =========
-*
-* IJOB (input) INTEGER
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (PL and PR) or the deflating subspaces
-* (Difu and Difl):
-* =0: Only reorder w.r.t. SELECT. No extras.
-* =1: Reciprocal of norms of "projections" onto left and right
-* eigenspaces w.r.t. the selected cluster (PL and PR).
-* =2: Upper bounds on Difu and Difl. F-norm-based estimate
-* (DIF(1:2)).
-* =3: Estimate of Difu and Difl. 1-norm-based estimate
-* (DIF(1:2)).
-* About 5 times as expensive as IJOB = 2.
-* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
-* version to get it all.
-* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster.
-* To select a real eigenvalue w(j), SELECT(j) must be set to
-* .TRUE.. To select a complex conjugate pair of eigenvalues
-* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
-* either SELECT(j) or SELECT(j+1) or both must be set to
-* .TRUE.; a complex conjugate pair of eigenvalues must be
-* either both included in the cluster or both excluded.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) REAL array, dimension(LDA,N)
-* On entry, the upper quasi-triangular matrix A, with (A, B) in
-* generalized real Schur canonical form.
-* On exit, A is overwritten by the reordered matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension(LDB,N)
-* On entry, the upper triangular matrix B, with (A, B) in
-* generalized real Schur canonical form.
-* On exit, B is overwritten by the reordered matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ALPHAR (output) REAL array, dimension (N)
-* ALPHAI (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
-* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
-* and BETA(j),j=1,...,N are the diagonals of the complex Schur
-* form (S,T) that would result if the 2-by-2 diagonal blocks of
-* the real generalized Schur form of (A,B) were further reduced
-* to triangular form using complex unitary transformations.
-* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
-* positive, then the j-th and (j+1)-st eigenvalues are a
-* complex conjugate pair, with ALPHAI(j+1) negative.
-*
-* Q (input/output) REAL array, dimension (LDQ,N)
-* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
-* On exit, Q has been postmultiplied by the left orthogonal
-* transformation matrix which reorder (A, B); The leading M
-* columns of Q form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1;
-* and if WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) REAL array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
-* On exit, Z has been postmultiplied by the left orthogonal
-* transformation matrix which reorder (A, B); The leading M
-* columns of Z form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1;
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* M (output) INTEGER
-* The dimension of the specified pair of left and right eigen-
-* spaces (deflating subspaces). 0 <= M <= N.
-*
-* PL (output) REAL
-* PR (output) REAL
-* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
-* reciprocal of the norm of "projections" onto left and right
-* eigenspaces with respect to the selected cluster.
-* 0 < PL, PR <= 1.
-* If M = 0 or M = N, PL = PR = 1.
-* If IJOB = 0, 2 or 3, PL and PR are not referenced.
-*
-* DIF (output) REAL array, dimension (2).
-* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
-* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
-* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
-* estimates of Difu and Difl.
-* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
-* If IJOB = 0 or 1, DIF is not referenced.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 4*N+16.
-* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
-* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= 1.
-* If IJOB = 1, 2 or 4, LIWORK >= N+6.
-* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* =1: Reordering of (A, B) failed because the transformed
-* matrix pair (A, B) would be too far from generalized
-* Schur form; the problem is very ill-conditioned.
-* (A, B) may have been partially reordered.
-* If requested, 0 is returned in DIF(*), PL and PR.
-*
-
-* Further Details
-* ===============
-*
-* STGSEN first collects the selected eigenvalues by computing
-* orthogonal U and W that move them to the top left corner of (A, B).
-* In other words, the selected eigenvalues are the eigenvalues of
-* (A11, B11) in:
-*
-* U'*(A, B)*W = (A11 A12) (B11 B12) n1
-* ( 0 A22),( 0 B22) n2
-* n1 n2 n1 n2
-*
-* where N = n1+n2 and U' means the transpose of U. The first n1 columns
-* of U and W span the specified pair of left and right eigenspaces
-* (deflating subspaces) of (A, B).
-*
-* If (A, B) has been obtained from the generalized real Schur
-* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
-* reordered generalized real Schur form of (C, D) is given by
-*
-* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
-*
-* and the first n1 columns of Q*U and Z*W span the corresponding
-* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
-*
-* Note that if the selected eigenvalue is sufficiently ill-conditioned,
-* then its value may differ significantly from its value before
-* reordering.
-*
-* The reciprocal condition numbers of the left and right eigenspaces
-* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
-* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
-*
-* The Difu and Difl are defined as:
-*
-* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
-* and
-* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
-*
-* where sigma-min(Zu) is the smallest singular value of the
-* (2*n1*n2)-by-(2*n1*n2) matrix
-*
-* Zu = [ kron(In2, A11) -kron(A22', In1) ]
-* [ kron(In2, B11) -kron(B22', In1) ].
-*
-* Here, Inx is the identity matrix of size nx and A22' is the
-* transpose of A22. kron(X, Y) is the Kronecker product between
-* the matrices X and Y.
-*
-* When DIF(2) is small, small changes in (A, B) can cause large changes
-* in the deflating subspace. An approximate (asymptotic) bound on the
-* maximum angular error in the computed deflating subspaces is
-*
-* EPS * norm((A, B)) / DIF(2),
-*
-* where EPS is the machine precision.
-*
-* The reciprocal norm of the projectors on the left and right
-* eigenspaces associated with (A11, B11) may be returned in PL and PR.
-* They are computed as follows. First we compute L and R so that
-* P*(A, B)*Q is block diagonal, where
-*
-* P = ( I -L ) n1 Q = ( I R ) n1
-* ( 0 I ) n2 and ( 0 I ) n2
-* n1 n2 n1 n2
-*
-* and (L, R) is the solution to the generalized Sylvester equation
-*
-* A11*R - L*A22 = -A12
-* B11*R - L*B22 = -B12
-*
-* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
-* An approximate (asymptotic) bound on the average absolute error of
-* the selected eigenvalues is
-*
-* EPS * norm((A, B)) / PL.
-*
-* There are also global error bounds which valid for perturbations up
-* to a certain restriction: A lower bound (x) on the smallest
-* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
-* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
-* (i.e. (A + E, B + F), is
-*
-* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
-*
-* An approximate bound on x can be computed from DIF(1:2), PL and PR.
-*
-* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
-* (L', R') and unperturbed (L, R) left and right deflating subspaces
-* associated with the selected cluster in the (1,1)-blocks can be
-* bounded as
-*
-* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
-* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
-*
-* See LAPACK User's Guide section 4.11 or the following references
-* for more information.
-*
-* Note that if the default method for computing the Frobenius-norm-
-* based estimate DIF is not wanted (see SLATDF), then the parameter
-* IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
-* (IJOB = 2 will be used)). See STGSYL for more details.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software,
-* Report UMINF - 94.04, Department of Computing Science, Umea
-* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
-* Note 87. To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
-* 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stgsja"></A>
- <H2>stgsja</H2>
-
- <PRE>
-USAGE:
- alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.stgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)
- or
- NumRu::Lapack.stgsja # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )
-
-* Purpose
-* =======
-*
-* STGSJA computes the generalized singular value decomposition (GSVD)
-* of two real upper triangular (or trapezoidal) matrices A and B.
-*
-* On entry, it is assumed that matrices A and B have the following
-* forms, which may be obtained by the preprocessing subroutine SGGSVP
-* from a general M-by-N matrix A and P-by-N matrix B:
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* B = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal.
-*
-* On exit,
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
-*
-* where U, V and Q are orthogonal matrices, Z' denotes the transpose
-* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
-* ``diagonal'' matrices, which are of the following structures:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 ) K
-* L ( 0 0 R22 ) L
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The computation of the orthogonal transformation matrices U, V or Q
-* is optional. These matrices may either be formed explicitly, or they
-* may be postmultiplied into input matrices U1, V1, or Q1.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': U must contain an orthogonal matrix U1 on entry, and
-* the product U1*U is returned;
-* = 'I': U is initialized to the unit matrix, and the
-* orthogonal matrix U is returned;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': V must contain an orthogonal matrix V1 on entry, and
-* the product V1*V is returned;
-* = 'I': V is initialized to the unit matrix, and the
-* orthogonal matrix V is returned;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and
-* the product Q1*Q is returned;
-* = 'I': Q is initialized to the unit matrix, and the
-* orthogonal matrix Q is returned;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* K (input) INTEGER
-* L (input) INTEGER
-* K and L specify the subblocks in the input matrices A and B:
-* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
-* of A and B, whose GSVD is going to be computed by STGSJA.
-* See Further Details.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
-* matrix R or part of R. See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) REAL array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
-* a part of R. See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) REAL
-* TOLB (input) REAL
-* TOLA and TOLB are the convergence criteria for the Jacobi-
-* Kogbetliantz iteration procedure. Generally, they are the
-* same as used in the preprocessing step, say
-* TOLA = max(M,N)*norm(A)*MACHEPS,
-* TOLB = max(P,N)*norm(B)*MACHEPS.
-*
-* ALPHA (output) REAL array, dimension (N)
-* BETA (output) REAL array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = diag(C),
-* BETA(K+1:K+L) = diag(S),
-* or if M-K-L < 0,
-* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
-* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
-* Furthermore, if K+L < N,
-* ALPHA(K+L+1:N) = 0 and
-* BETA(K+L+1:N) = 0.
-*
-* U (input/output) REAL array, dimension (LDU,M)
-* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
-* the orthogonal matrix returned by SGGSVP).
-* On exit,
-* if JOBU = 'I', U contains the orthogonal matrix U;
-* if JOBU = 'U', U contains the product U1*U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (input/output) REAL array, dimension (LDV,P)
-* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
-* the orthogonal matrix returned by SGGSVP).
-* On exit,
-* if JOBV = 'I', V contains the orthogonal matrix V;
-* if JOBV = 'V', V contains the product V1*V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (input/output) REAL array, dimension (LDQ,N)
-* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
-* the orthogonal matrix returned by SGGSVP).
-* On exit,
-* if JOBQ = 'I', Q contains the orthogonal matrix Q;
-* if JOBQ = 'Q', Q contains the product Q1*Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) REAL array, dimension (2*N)
-*
-* NCYCLE (output) INTEGER
-* The number of cycles required for convergence.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the procedure does not converge after MAXIT cycles.
-*
-* Internal Parameters
-* ===================
-*
-* MAXIT INTEGER
-* MAXIT specifies the total loops that the iterative procedure
-* may take. If after MAXIT cycles, the routine fails to
-* converge, we return INFO = 1.
-*
-
-* Further Details
-* ===============
-*
-* STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
-* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
-* matrix B13 to the form:
-*
-* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
-*
-* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
-* of Z. C1 and S1 are diagonal matrices satisfying
-*
-* C1**2 + S1**2 = I,
-*
-* and R1 is an L-by-L nonsingular upper triangular matrix.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stgsna"></A>
- <H2>stgsna</H2>
-
- <PRE>
-USAGE:
- s, dif, m, work, info = NumRu::Lapack.stgsna( job, howmny, select, a, b, vl, vr, lwork)
- or
- NumRu::Lapack.stgsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STGSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or eigenvectors of a matrix pair (A, B) in
-* generalized real Schur canonical form (or of any matrix pair
-* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
-* Z' denotes the transpose of Z.
-*
-* (A, B) must be in generalized real Schur form (as returned by SGGES),
-* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
-* blocks. B is upper triangular.
-*
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (DIF):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (DIF);
-* = 'B': for both eigenvalues and eigenvectors (S and DIF).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the eigenpair corresponding to a real eigenvalue w(j),
-* SELECT(j) must be set to .TRUE.. To select condition numbers
-* corresponding to a complex conjugate pair of eigenvalues w(j)
-* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
-* set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the square matrix pair (A, B). N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The upper quasi-triangular matrix A in the pair (A,B).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) REAL array, dimension (LDB,N)
-* The upper triangular matrix B in the pair (A,B).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) REAL array, dimension (LDVL,M)
-* If JOB = 'E' or 'B', VL must contain left eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns of VL, as returned by STGEVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1.
-* If JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) REAL array, dimension (LDVR,M)
-* If JOB = 'E' or 'B', VR must contain right eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns ov VR, as returned by STGEVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1.
-* If JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) REAL array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array. For a complex conjugate pair of eigenvalues two
-* consecutive elements of S are set to the same value. Thus
-* S(j), DIF(j), and the j-th columns of VL and VR all
-* correspond to the same eigenpair (but not in general the
-* j-th eigenpair, unless all eigenpairs are selected).
-* If JOB = 'V', S is not referenced.
-*
-* DIF (output) REAL array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array. For a complex eigenvector two
-* consecutive elements of DIF are set to the same value. If
-* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
-* is set to 0; this can only occur when the true value would be
-* very small anyway.
-* If JOB = 'E', DIF is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S and DIF. MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and DIF used to store
-* the specified condition numbers; for each selected real
-* eigenvalue one element is used, and for each selected complex
-* conjugate pair of eigenvalues, two elements are used.
-* If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (N + 6)
-* If JOB = 'E', IWORK is not referenced.
-*
-* INFO (output) INTEGER
-* =0: Successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value
-*
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of a generalized eigenvalue
-* w = (a, b) is defined as
-*
-* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
-*
-* where u and v are the left and right eigenvectors of (A, B)
-* corresponding to w; |z| denotes the absolute value of the complex
-* number, and norm(u) denotes the 2-norm of the vector u.
-* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
-* of the matrix pair (A, B). If both a and b equal zero, then (A B) is
-* singular and S(I) = -1 is returned.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(A, B) / S(I)
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number DIF(i) of right eigenvector u
-* and left eigenvector v corresponding to the generalized eigenvalue w
-* is defined as follows:
-*
-* a) If the i-th eigenvalue w = (a,b) is real
-*
-* Suppose U and V are orthogonal transformations such that
-*
-* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1
-* ( 0 S22 ),( 0 T22 ) n-1
-* 1 n-1 1 n-1
-*
-* Then the reciprocal condition number DIF(i) is
-*
-* Difl((a, b), (S22, T22)) = sigma-min( Zl ),
-*
-* where sigma-min(Zl) denotes the smallest singular value of the
-* 2(n-1)-by-2(n-1) matrix
-*
-* Zl = [ kron(a, In-1) -kron(1, S22) ]
-* [ kron(b, In-1) -kron(1, T22) ] .
-*
-* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
-* Kronecker product between the matrices X and Y.
-*
-* Note that if the default method for computing DIF(i) is wanted
-* (see SLATDF), then the parameter DIFDRI (see below) should be
-* changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).
-* See STGSYL for more details.
-*
-* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
-*
-* Suppose U and V are orthogonal transformations such that
-*
-* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2
-* ( 0 S22 ),( 0 T22) n-2
-* 2 n-2 2 n-2
-*
-* and (S11, T11) corresponds to the complex conjugate eigenvalue
-* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
-* that
-*
-* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )
-* ( 0 s22 ) ( 0 t22 )
-*
-* where the generalized eigenvalues w = s11/t11 and
-* conjg(w) = s22/t22.
-*
-* Then the reciprocal condition number DIF(i) is bounded by
-*
-* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
-*
-* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
-* Z1 is the complex 2-by-2 matrix
-*
-* Z1 = [ s11 -s22 ]
-* [ t11 -t22 ],
-*
-* This is done by computing (using real arithmetic) the
-* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
-* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
-* the determinant of X.
-*
-* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
-* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
-*
-* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]
-* [ kron(T11', In-2) -kron(I2, T22) ]
-*
-* Note that if the default method for computing DIF is wanted (see
-* SLATDF), then the parameter DIFDRI (see below) should be changed
-* from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL
-* for more details.
-*
-* For each eigenvalue/vector specified by SELECT, DIF stores a
-* Frobenius norm-based estimate of Difl.
-*
-* An approximate error bound for the i-th computed eigenvector VL(i) or
-* VR(i) is given by
-*
-* EPS * norm(A, B) / DIF(i).
-*
-* See ref. [2-3] for more details and further references.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software,
-* Report UMINF - 94.04, Department of Computing Science, Umea
-* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
-* Note 87. To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
-* No 1, 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stgsy2"></A>
- <H2>stgsy2</H2>
-
- <PRE>
-USAGE:
- scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.stgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)
- or
- NumRu::Lapack.stgsy2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )
-
-* Purpose
-* =======
-*
-* STGSY2 solves the generalized Sylvester equation:
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F,
-*
-* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
-* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
-* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
-* must be in generalized Schur canonical form, i.e. A, B are upper
-* quasi triangular and D, E are upper triangular. The solution (R, L)
-* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
-* chosen to avoid overflow.
-*
-* In matrix notation solving equation (1) corresponds to solve
-* Z*x = scale*b, where Z is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ],
-*
-* Ik is the identity matrix of size k and X' is the transpose of X.
-* kron(X, Y) is the Kronecker product between the matrices X and Y.
-* In the process of solving (1), we solve a number of such systems
-* where Dim(In), Dim(In) = 1 or 2.
-*
-* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
-* which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * -F
-*
-* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
-* sigma_min(Z) using reverse communicaton with SLACON.
-*
-* STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL
-* of an upper bound on the separation between to matrix pairs. Then
-* the input (A, D), (B, E) are sub-pencils of the matrix pair in
-* STGSYL. See STGSYL for details.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N', solve the generalized Sylvester equation (1).
-* = 'T': solve the 'transposed' system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* = 0: solve (1) only.
-* = 1: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (look ahead strategy is used).
-* = 2: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (SGECON on sub-systems is used.)
-* Not referenced if TRANS = 'T'.
-*
-* M (input) INTEGER
-* On entry, M specifies the order of A and D, and the row
-* dimension of C, F, R and L.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of B and E, and the column
-* dimension of C, F, R and L.
-*
-* A (input) REAL array, dimension (LDA, M)
-* On entry, A contains an upper quasi triangular matrix.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1, M).
-*
-* B (input) REAL array, dimension (LDB, N)
-* On entry, B contains an upper quasi triangular matrix.
-*
-* LDB (input) INTEGER
-* The leading dimension of the matrix B. LDB >= max(1, N).
-*
-* C (input/output) REAL array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1).
-* On exit, if IJOB = 0, C has been overwritten by the
-* solution R.
-*
-* LDC (input) INTEGER
-* The leading dimension of the matrix C. LDC >= max(1, M).
-*
-* D (input) REAL array, dimension (LDD, M)
-* On entry, D contains an upper triangular matrix.
-*
-* LDD (input) INTEGER
-* The leading dimension of the matrix D. LDD >= max(1, M).
-*
-* E (input) REAL array, dimension (LDE, N)
-* On entry, E contains an upper triangular matrix.
-*
-* LDE (input) INTEGER
-* The leading dimension of the matrix E. LDE >= max(1, N).
-*
-* F (input/output) REAL array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1).
-* On exit, if IJOB = 0, F has been overwritten by the
-* solution L.
-*
-* LDF (input) INTEGER
-* The leading dimension of the matrix F. LDF >= max(1, M).
-*
-* SCALE (output) REAL
-* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
-* R and L (C and F on entry) will hold the solutions to a
-* slightly perturbed system but the input matrices A, B, D and
-* E have not been changed. If SCALE = 0, R and L will hold the
-* solutions to the homogeneous system with C = F = 0. Normally,
-* SCALE = 1.
-*
-* RDSUM (input/output) REAL
-* On entry, the sum of squares of computed contributions to
-* the Dif-estimate under computation by STGSYL, where the
-* scaling factor RDSCAL (see below) has been factored out.
-* On exit, the corresponding sum of squares updated with the
-* contributions from the current sub-system.
-* If TRANS = 'T' RDSUM is not touched.
-* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.
-*
-* RDSCAL (input/output) REAL
-* On entry, scaling factor used to prevent overflow in RDSUM.
-* On exit, RDSCAL is updated w.r.t. the current contributions
-* in RDSUM.
-* If TRANS = 'T', RDSCAL is not touched.
-* NOTE: RDSCAL only makes sense when STGSY2 is called by
-* STGSYL.
-*
-* IWORK (workspace) INTEGER array, dimension (M+N+2)
-*
-* PQ (output) INTEGER
-* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
-* 8-by-8) solved by this routine.
-*
-* INFO (output) INTEGER
-* On exit, if INFO is set to
-* =0: Successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* >0: The matrix pairs (A, D) and (B, E) have common or very
-* close eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-* Replaced various illegal calls to SCOPY by calls to SLASET.
-* Sven Hammarling, 27/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stgsyl"></A>
- <H2>stgsyl</H2>
-
- <PRE>
-USAGE:
- scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, lwork)
- or
- NumRu::Lapack.stgsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STGSYL solves the generalized Sylvester equation:
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F
-*
-* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
-* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
-* respectively, with real entries. (A, D) and (B, E) must be in
-* generalized (real) Schur canonical form, i.e. A, B are upper quasi
-* triangular and D, E are upper triangular.
-*
-* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
-* scaling factor chosen to avoid overflow.
-*
-* In matrix notation (1) is equivalent to solve Zx = scale b, where
-* Z is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ].
-*
-* Here Ik is the identity matrix of size k and X' is the transpose of
-* X. kron(X, Y) is the Kronecker product between the matrices X and Y.
-*
-* If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b,
-* which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * (-F)
-*
-* This case (TRANS = 'T') is used to compute an one-norm-based estimate
-* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
-* and (B,E), using SLACON.
-*
-* If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate
-* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
-* reciprocal of the smallest singular value of Z. See [1-2] for more
-* information.
-*
-* This is a level 3 BLAS algorithm.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N', solve the generalized Sylvester equation (1).
-* = 'T', solve the 'transposed' system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* =0: solve (1) only.
-* =1: The functionality of 0 and 3.
-* =2: The functionality of 0 and 4.
-* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* (look ahead strategy IJOB = 1 is used).
-* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* ( SGECON on sub-systems is used ).
-* Not referenced if TRANS = 'T'.
-*
-* M (input) INTEGER
-* The order of the matrices A and D, and the row dimension of
-* the matrices C, F, R and L.
-*
-* N (input) INTEGER
-* The order of the matrices B and E, and the column dimension
-* of the matrices C, F, R and L.
-*
-* A (input) REAL array, dimension (LDA, M)
-* The upper quasi triangular matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, M).
-*
-* B (input) REAL array, dimension (LDB, N)
-* The upper quasi triangular matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1, N).
-*
-* C (input/output) REAL array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
-* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1, M).
-*
-* D (input) REAL array, dimension (LDD, M)
-* The upper triangular matrix D.
-*
-* LDD (input) INTEGER
-* The leading dimension of the array D. LDD >= max(1, M).
-*
-* E (input) REAL array, dimension (LDE, N)
-* The upper triangular matrix E.
-*
-* LDE (input) INTEGER
-* The leading dimension of the array E. LDE >= max(1, N).
-*
-* F (input/output) REAL array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
-* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDF (input) INTEGER
-* The leading dimension of the array F. LDF >= max(1, M).
-*
-* DIF (output) REAL
-* On exit DIF is the reciprocal of a lower bound of the
-* reciprocal of the Dif-function, i.e. DIF is an upper bound of
-* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
-* IF IJOB = 0 or TRANS = 'T', DIF is not touched.
-*
-* SCALE (output) REAL
-* On exit SCALE is the scaling factor in (1) or (3).
-* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
-* to a slightly perturbed system but the input matrices A, B, D
-* and E have not been changed. If SCALE = 0, C and F hold the
-* solutions R and L, respectively, to the homogeneous system
-* with C = F = 0. Normally, SCALE = 1.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK > = 1.
-* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M+N+6)
-*
-* INFO (output) INTEGER
-* =0: successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* >0: (A, D) and (B, E) have common or close eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
-* No 1, 1996.
-*
-* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
-* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
-* Appl., 15(4):1045-1060, 1994
-*
-* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
-* Condition Estimators for Solving the Generalized Sylvester
-* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
-* July 1989, pp 745-751.
-*
-* =====================================================================
-* Replaced various illegal calls to SCOPY by calls to SLASET.
-* Sven Hammarling, 1/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/stp.html b/doc/stp.html
deleted file mode 100644
index 10d2004..0000000
--- a/doc/stp.html
+++ /dev/null
@@ -1,549 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for triangular, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for triangular, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#stpcon">stpcon</A> : </LI>
- <LI><A HREF="#stprfs">stprfs</A> : </LI>
- <LI><A HREF="#stptri">stptri</A> : </LI>
- <LI><A HREF="#stptrs">stptrs</A> : </LI>
- <LI><A HREF="#stpttf">stpttf</A> : </LI>
- <LI><A HREF="#stpttr">stpttr</A> : </LI>
- </UL>
-
- <A NAME="stpcon"></A>
- <H2>stpcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.stpcon( norm, uplo, diag, ap)
- or
- NumRu::Lapack.stpcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STPCON estimates the reciprocal of the condition number of a packed
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stprfs"></A>
- <H2>stprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x)
- or
- NumRu::Lapack.stprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STPRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular packed
-* coefficient matrix.
-*
-* The solution matrix X must be computed by STPTRS or some other
-* means before entering this routine. STPRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) REAL array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stptri"></A>
- <H2>stptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap)
- or
- NumRu::Lapack.stptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* STPTRI computes the inverse of a real upper or lower triangular
-* matrix A stored in packed format.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) REAL array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangular matrix A, stored
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same packed storage format.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* Further Details
-* ===============
-*
-* A triangular matrix A can be transferred to packed storage using one
-* of the following program segments:
-*
-* UPLO = 'U': UPLO = 'L':
-*
-* JC = 1 JC = 1
-* DO 2 J = 1, N DO 2 J = 1, N
-* DO 1 I = 1, J DO 1 I = J, N
-* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
-* 1 CONTINUE 1 CONTINUE
-* JC = JC + J JC = JC + N - J + 1
-* 2 CONTINUE 2 CONTINUE
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stptrs"></A>
- <H2>stptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.stptrs( uplo, trans, diag, n, ap, b)
- or
- NumRu::Lapack.stptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* STPTRS solves a triangular system of the form
-*
-* A * X = B or A**T * X = B,
-*
-* where A is a triangular matrix of order N stored in packed format,
-* and B is an N-by-NRHS matrix. A check is made to verify that A is
-* nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) REAL array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stpttf"></A>
- <H2>stpttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.stpttf( transr, uplo, n, ap)
- or
- NumRu::Lapack.stpttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO )
-
-* Purpose
-* =======
-*
-* STPTTF copies a triangular matrix A from standard packed format (TP)
-* to rectangular full packed format (TF).
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal format is wanted;
-* = 'T': ARF in Conjugate-transpose format is wanted.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) REAL array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* ARF (output) REAL array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A stored in
-* RFP format. For a further discussion see Notes below.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Rectangular Full Packed (RFP) Format when N is
-* even. We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* the transpose of the first three columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* the transpose of the last three columns of AP lower.
-* This covers the case N even and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 03 04 05 33 43 53
-* 13 14 15 00 44 54
-* 23 24 25 10 11 55
-* 33 34 35 20 21 22
-* 00 44 45 30 31 32
-* 01 11 55 40 41 42
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We then consider Rectangular Full Packed (RFP) Format when N is
-* odd. We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* the transpose of the first two columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* the transpose of the last two columns of AP lower.
-* This covers the case N odd and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 02 03 04 00 33 43
-* 12 13 14 10 11 44
-* 22 23 24 20 21 22
-* 00 33 34 30 31 32
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-* RFP A RFP A
-*
-* 02 12 22 00 01 00 10 20 30 40 50
-* 03 13 23 33 11 33 11 21 31 41 51
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stpttr"></A>
- <H2>stpttr</H2>
-
- <PRE>
-USAGE:
- a, info = NumRu::Lapack.stpttr( uplo, ap)
- or
- NumRu::Lapack.stpttr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* STPTTR copies a triangular matrix A from standard packed format (TP)
-* to standard full format (TR).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular.
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) REAL array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* A (output) REAL array, dimension ( LDA, N )
-* On exit, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/str.html b/doc/str.html
deleted file mode 100644
index 3cfed28..0000000
--- a/doc/str.html
+++ /dev/null
@@ -1,1381 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for triangular (or in some cases quasi-triangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for triangular (or in some cases quasi-triangular) matrix</H1>
- <UL>
- <LI><A HREF="#strcon">strcon</A> : </LI>
- <LI><A HREF="#strevc">strevc</A> : </LI>
- <LI><A HREF="#strexc">strexc</A> : </LI>
- <LI><A HREF="#strrfs">strrfs</A> : </LI>
- <LI><A HREF="#strsen">strsen</A> : </LI>
- <LI><A HREF="#strsna">strsna</A> : </LI>
- <LI><A HREF="#strsyl">strsyl</A> : </LI>
- <LI><A HREF="#strti2">strti2</A> : </LI>
- <LI><A HREF="#strtri">strtri</A> : </LI>
- <LI><A HREF="#strtrs">strtrs</A> : </LI>
- <LI><A HREF="#strttf">strttf</A> : </LI>
- <LI><A HREF="#strttp">strttp</A> : </LI>
- </UL>
-
- <A NAME="strcon"></A>
- <H2>strcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.strcon( norm, uplo, diag, a)
- or
- NumRu::Lapack.strcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STRCON estimates the reciprocal of the condition number of a
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* RCOND (output) REAL
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strevc"></A>
- <H2>strevc</H2>
-
- <PRE>
-USAGE:
- m, info, select, vl, vr = NumRu::Lapack.strevc( side, howmny, select, t, vl, vr)
- or
- NumRu::Lapack.strevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )
-
-* Purpose
-* =======
-*
-* STREVC computes some or all of the right and/or left eigenvectors of
-* a real upper quasi-triangular matrix T.
-* Matrices of this type are produced by the Schur factorization of
-* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.
-*
-* The right eigenvector x and the left eigenvector y of T corresponding
-* to an eigenvalue w are defined by:
-*
-* T*x = w*x, (y**H)*T = w*(y**H)
-*
-* where y**H denotes the conjugate transpose of y.
-* The eigenvalues are not input to this routine, but are read directly
-* from the diagonal blocks of T.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
-* input matrix. If Q is the orthogonal factor that reduces a matrix
-* A to Schur form T, then Q*X and Q*Y are the matrices of right and
-* left eigenvectors of A.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed by the matrices in VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* as indicated by the logical array SELECT.
-*
-* SELECT (input/output) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
-* computed.
-* If w(j) is a real eigenvalue, the corresponding real
-* eigenvector is computed if SELECT(j) is .TRUE..
-* If w(j) and w(j+1) are the real and imaginary parts of a
-* complex eigenvalue, the corresponding complex eigenvector is
-* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
-* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
-* .FALSE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input) REAL array, dimension (LDT,N)
-* The upper quasi-triangular matrix T in Schur canonical form.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input/output) REAL array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the orthogonal matrix Q
-* of Schur vectors returned by SHSEQR).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VL, in the same order as their
-* eigenvalues.
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part, and the second the imaginary part.
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'B', LDVL >= N.
-*
-* VR (input/output) REAL array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Q (usually the orthogonal matrix Q
-* of Schur vectors returned by SHSEQR).
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*X;
-* if HOWMNY = 'S', the right eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VR, in the same order as their
-* eigenvalues.
-* A complex eigenvector corresponding to a complex eigenvalue
-* is stored in two consecutive columns, the first holding the
-* real part and the second the imaginary part.
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B', LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors.
-* If HOWMNY = 'A' or 'B', M is set to N.
-* Each selected real eigenvector occupies one column and each
-* selected complex eigenvector occupies two columns.
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The algorithm used in this program is basically backward (forward)
-* substitution, with scaling to make the the code robust against
-* possible overflow.
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x| + |y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strexc"></A>
- <H2>strexc</H2>
-
- <PRE>
-USAGE:
- info, t, q, ifst, ilst = NumRu::Lapack.strexc( compq, t, q, ifst, ilst)
- or
- NumRu::Lapack.strexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )
-
-* Purpose
-* =======
-*
-* STREXC reorders the real Schur factorization of a real matrix
-* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
-* moved to row ILST.
-*
-* The real Schur form T is reordered by an orthogonal similarity
-* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
-* is updated by postmultiplying it with Z.
-*
-* T must be in Schur canonical form (as returned by SHSEQR), that is,
-* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
-* 2-by-2 diagonal block has its diagonal elements equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) REAL array, dimension (LDT,N)
-* On entry, the upper quasi-triangular matrix T, in Schur
-* Schur canonical form.
-* On exit, the reordered upper quasi-triangular matrix, again
-* in Schur canonical form.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) REAL array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* orthogonal transformation matrix Z which reorders T.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* IFST (input/output) INTEGER
-* ILST (input/output) INTEGER
-* Specify the reordering of the diagonal blocks of T.
-* The block with row index IFST is moved to row ILST, by a
-* sequence of transpositions between adjacent blocks.
-* On exit, if IFST pointed on entry to the second row of a
-* 2-by-2 block, it is changed to point to the first row; ILST
-* always points to the first row of the block in its final
-* position (which may differ from its input value by +1 or -1).
-* 1 <= IFST <= N; 1 <= ILST <= N.
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: two adjacent blocks were too close to swap (the problem
-* is very ill-conditioned); T may have been partially
-* reordered, and ILST points to the first row of the
-* current position of the block being moved.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strrfs"></A>
- <H2>strrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.strrfs( uplo, trans, diag, a, b, x)
- or
- NumRu::Lapack.strrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STRRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular
-* coefficient matrix.
-*
-* The solution matrix X must be computed by STRTRS or some other
-* means before entering this routine. STRRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) REAL array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) REAL array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) REAL array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) REAL array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) REAL array, dimension (3*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strsen"></A>
- <H2>strsen</H2>
-
- <PRE>
-USAGE:
- wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.strsen( job, compq, select, t, q, lwork, liwork)
- or
- NumRu::Lapack.strsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* STRSEN reorders the real Schur factorization of a real matrix
-* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
-* the leading diagonal blocks of the upper quasi-triangular matrix T,
-* and the leading columns of Q form an orthonormal basis of the
-* corresponding right invariant subspace.
-*
-* Optionally the routine computes the reciprocal condition numbers of
-* the cluster of eigenvalues and/or the invariant subspace.
-*
-* T must be in Schur canonical form (as returned by SHSEQR), that is,
-* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
-* 2-by-2 diagonal block has its diagonal elemnts equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (S) or the invariant subspace (SEP):
-* = 'N': none;
-* = 'E': for eigenvalues only (S);
-* = 'V': for invariant subspace only (SEP);
-* = 'B': for both eigenvalues and invariant subspace (S and
-* SEP).
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster. To
-* select a real eigenvalue w(j), SELECT(j) must be set to
-* .TRUE.. To select a complex conjugate pair of eigenvalues
-* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
-* either SELECT(j) or SELECT(j+1) or both must be set to
-* .TRUE.; a complex conjugate pair of eigenvalues must be
-* either both included in the cluster or both excluded.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) REAL array, dimension (LDT,N)
-* On entry, the upper quasi-triangular matrix T, in Schur
-* canonical form.
-* On exit, T is overwritten by the reordered matrix T, again in
-* Schur canonical form, with the selected eigenvalues in the
-* leading diagonal blocks.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) REAL array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* orthogonal transformation matrix which reorders T; the
-* leading M columns of Q form an orthonormal basis for the
-* specified invariant subspace.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
-*
-* WR (output) REAL array, dimension (N)
-* WI (output) REAL array, dimension (N)
-* The real and imaginary parts, respectively, of the reordered
-* eigenvalues of T. The eigenvalues are stored in the same
-* order as on the diagonal of T, with WR(i) = T(i,i) and, if
-* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
-* WI(i+1) = -WI(i). Note that if a complex eigenvalue is
-* sufficiently ill-conditioned, then its value may differ
-* significantly from its value before reordering.
-*
-* M (output) INTEGER
-* The dimension of the specified invariant subspace.
-* 0 < = M <= N.
-*
-* S (output) REAL
-* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
-* condition number for the selected cluster of eigenvalues.
-* S cannot underestimate the true reciprocal condition number
-* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
-* If JOB = 'N' or 'V', S is not referenced.
-*
-* SEP (output) REAL
-* If JOB = 'V' or 'B', SEP is the estimated reciprocal
-* condition number of the specified invariant subspace. If
-* M = 0 or N, SEP = norm(T).
-* If JOB = 'N' or 'E', SEP is not referenced.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If JOB = 'N', LWORK >= max(1,N);
-* if JOB = 'E', LWORK >= max(1,M*(N-M));
-* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If JOB = 'N' or 'E', LIWORK >= 1;
-* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: reordering of T failed because some eigenvalues are too
-* close to separate (the problem is very ill-conditioned);
-* T may have been partially reordered, and WR and WI
-* contain the eigenvalues in the same order as in T; S and
-* SEP (if requested) are set to zero.
-*
-
-* Further Details
-* ===============
-*
-* STRSEN first collects the selected eigenvalues by computing an
-* orthogonal transformation Z to move them to the top left corner of T.
-* In other words, the selected eigenvalues are the eigenvalues of T11
-* in:
-*
-* Z'*T*Z = ( T11 T12 ) n1
-* ( 0 T22 ) n2
-* n1 n2
-*
-* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
-* of Z span the specified invariant subspace of T.
-*
-* If T has been obtained from the real Schur factorization of a matrix
-* A = Q*T*Q', then the reordered real Schur factorization of A is given
-* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
-* the corresponding invariant subspace of A.
-*
-* The reciprocal condition number of the average of the eigenvalues of
-* T11 may be returned in S. S lies between 0 (very badly conditioned)
-* and 1 (very well conditioned). It is computed as follows. First we
-* compute R so that
-*
-* P = ( I R ) n1
-* ( 0 0 ) n2
-* n1 n2
-*
-* is the projector on the invariant subspace associated with T11.
-* R is the solution of the Sylvester equation:
-*
-* T11*R - R*T22 = T12.
-*
-* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
-* the two-norm of M. Then S is computed as the lower bound
-*
-* (1 + F-norm(R)**2)**(-1/2)
-*
-* on the reciprocal of 2-norm(P), the true reciprocal condition number.
-* S cannot underestimate 1 / 2-norm(P) by more than a factor of
-* sqrt(N).
-*
-* An approximate error bound for the computed average of the
-* eigenvalues of T11 is
-*
-* EPS * norm(T) / S
-*
-* where EPS is the machine precision.
-*
-* The reciprocal condition number of the right invariant subspace
-* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
-* SEP is defined as the separation of T11 and T22:
-*
-* sep( T11, T22 ) = sigma-min( C )
-*
-* where sigma-min(C) is the smallest singular value of the
-* n1*n2-by-n1*n2 matrix
-*
-* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
-*
-* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
-* product. We estimate sigma-min(C) by the reciprocal of an estimate of
-* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
-* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
-*
-* When SEP is small, small changes in T can cause large changes in
-* the invariant subspace. An approximate bound on the maximum angular
-* error in the computed right invariant subspace is
-*
-* EPS * norm(T) / SEP
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strsna"></A>
- <H2>strsna</H2>
-
- <PRE>
-USAGE:
- s, sep, m, info = NumRu::Lapack.strsna( job, howmny, select, t, vl, vr, ldwork)
- or
- NumRu::Lapack.strsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* STRSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or right eigenvectors of a real upper
-* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
-* orthogonal).
-*
-* T must be in Schur canonical form (as returned by SHSEQR), that is,
-* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
-* 2-by-2 diagonal block has its diagonal elements equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (SEP):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (SEP);
-* = 'B': for both eigenvalues and eigenvectors (S and SEP).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the eigenpair corresponding to a real eigenvalue w(j),
-* SELECT(j) must be set to .TRUE.. To select condition numbers
-* corresponding to a complex conjugate pair of eigenvalues w(j)
-* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
-* set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input) REAL array, dimension (LDT,N)
-* The upper quasi-triangular matrix T, in Schur canonical form.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input) REAL array, dimension (LDVL,M)
-* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
-* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VL, as returned by
-* SHSEIN or STREVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) REAL array, dimension (LDVR,M)
-* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
-* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VR, as returned by
-* SHSEIN or STREVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) REAL array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array. For a complex conjugate pair of eigenvalues two
-* consecutive elements of S are set to the same value. Thus
-* S(j), SEP(j), and the j-th columns of VL and VR all
-* correspond to the same eigenpair (but not in general the
-* j-th eigenpair, unless all eigenpairs are selected).
-* If JOB = 'V', S is not referenced.
-*
-* SEP (output) REAL array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array. For a complex eigenvector two
-* consecutive elements of SEP are set to the same value. If
-* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
-* is set to 0; this can only occur when the true value would be
-* very small anyway.
-* If JOB = 'E', SEP is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S (if JOB = 'E' or 'B')
-* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and/or SEP actually
-* used to store the estimated condition numbers.
-* If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace) REAL array, dimension (LDWORK,N+6)
-* If JOB = 'E', WORK is not referenced.
-*
-* LDWORK (input) INTEGER
-* The leading dimension of the array WORK.
-* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
-*
-* IWORK (workspace) INTEGER array, dimension (2*(N-1))
-* If JOB = 'E', IWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of an eigenvalue lambda is
-* defined as
-*
-* S(lambda) = |v'*u| / (norm(u)*norm(v))
-*
-* where u and v are the right and left eigenvectors of T corresponding
-* to lambda; v' denotes the conjugate-transpose of v, and norm(u)
-* denotes the Euclidean norm. These reciprocal condition numbers always
-* lie between zero (very badly conditioned) and one (very well
-* conditioned). If n = 1, S(lambda) is defined to be 1.
-*
-* An approximate error bound for a computed eigenvalue W(i) is given by
-*
-* EPS * norm(T) / S(i)
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number of the right eigenvector u
-* corresponding to lambda is defined as follows. Suppose
-*
-* T = ( lambda c )
-* ( 0 T22 )
-*
-* Then the reciprocal condition number is
-*
-* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
-*
-* where sigma-min denotes the smallest singular value. We approximate
-* the smallest singular value by the reciprocal of an estimate of the
-* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
-* defined to be abs(T(1,1)).
-*
-* An approximate error bound for a computed right eigenvector VR(i)
-* is given by
-*
-* EPS * norm(T) / SEP(i)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strsyl"></A>
- <H2>strsyl</H2>
-
- <PRE>
-USAGE:
- scale, info, c = NumRu::Lapack.strsyl( trana, tranb, isgn, a, b, c)
- or
- NumRu::Lapack.strsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* STRSYL solves the real Sylvester matrix equation:
-*
-* op(A)*X + X*op(B) = scale*C or
-* op(A)*X - X*op(B) = scale*C,
-*
-* where op(A) = A or A**T, and A and B are both upper quasi-
-* triangular. A is M-by-M and B is N-by-N; the right hand side C and
-* the solution X are M-by-N; and scale is an output scale factor, set
-* <= 1 to avoid overflow in X.
-*
-* A and B must be in Schur canonical form (as returned by SHSEQR), that
-* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
-* each 2-by-2 diagonal block has its diagonal elements equal and its
-* off-diagonal elements of opposite sign.
-*
-
-* Arguments
-* =========
-*
-* TRANA (input) CHARACTER*1
-* Specifies the option op(A):
-* = 'N': op(A) = A (No transpose)
-* = 'T': op(A) = A**T (Transpose)
-* = 'C': op(A) = A**H (Conjugate transpose = Transpose)
-*
-* TRANB (input) CHARACTER*1
-* Specifies the option op(B):
-* = 'N': op(B) = B (No transpose)
-* = 'T': op(B) = B**T (Transpose)
-* = 'C': op(B) = B**H (Conjugate transpose = Transpose)
-*
-* ISGN (input) INTEGER
-* Specifies the sign in the equation:
-* = +1: solve op(A)*X + X*op(B) = scale*C
-* = -1: solve op(A)*X - X*op(B) = scale*C
-*
-* M (input) INTEGER
-* The order of the matrix A, and the number of rows in the
-* matrices X and C. M >= 0.
-*
-* N (input) INTEGER
-* The order of the matrix B, and the number of columns in the
-* matrices X and C. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,M)
-* The upper quasi-triangular matrix A, in Schur canonical form.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input) REAL array, dimension (LDB,N)
-* The upper quasi-triangular matrix B, in Schur canonical form.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* C (input/output) REAL array, dimension (LDC,N)
-* On entry, the M-by-N right hand side matrix C.
-* On exit, C is overwritten by the solution matrix X.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M)
-*
-* SCALE (output) REAL
-* The scale factor, scale, set <= 1 to avoid overflow in X.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: A and B have common or very close eigenvalues; perturbed
-* values were used to solve the equation (but the matrices
-* A and B are unchanged).
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strti2"></A>
- <H2>strti2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.strti2( uplo, diag, a)
- or
- NumRu::Lapack.strti2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* STRTI2 computes the inverse of a real upper or lower triangular
-* matrix.
-*
-* This is the Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the matrix A is upper or lower triangular.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* DIAG (input) CHARACTER*1
-* Specifies whether or not the matrix A is unit triangular.
-* = 'N': Non-unit triangular
-* = 'U': Unit triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading n by n upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-*
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strtri"></A>
- <H2>strtri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.strtri( uplo, diag, a)
- or
- NumRu::Lapack.strtri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* STRTRI computes the inverse of a real upper or lower triangular
-* matrix A.
-*
-* This is the Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strtrs"></A>
- <H2>strtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.strtrs( uplo, trans, diag, a, b)
- or
- NumRu::Lapack.strtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* STRTRS solves a triangular system of the form
-*
-* A * X = B or A**T * X = B,
-*
-* where A is a triangular matrix of order N, and B is an N-by-NRHS
-* matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the solutions
-* X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strttf"></A>
- <H2>strttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.strttf( transr, uplo, a)
- or
- NumRu::Lapack.strttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )
-
-* Purpose
-* =======
-*
-* STRTTF copies a triangular matrix A from standard full format (TR)
-* to rectangular full packed format (TF) .
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal form is wanted;
-* = 'T': ARF in Transpose form is wanted.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N).
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1,N).
-*
-* ARF (output) REAL array, dimension (NT).
-* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Rectangular Full Packed (RFP) Format when N is
-* even. We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* the transpose of the first three columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* the transpose of the last three columns of AP lower.
-* This covers the case N even and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 03 04 05 33 43 53
-* 13 14 15 00 44 54
-* 23 24 25 10 11 55
-* 33 34 35 20 21 22
-* 00 44 45 30 31 32
-* 01 11 55 40 41 42
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We then consider Rectangular Full Packed (RFP) Format when N is
-* odd. We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* the transpose of the first two columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* the transpose of the last two columns of AP lower.
-* This covers the case N odd and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* 02 03 04 00 33 43
-* 12 13 14 10 11 44
-* 22 23 24 20 21 22
-* 00 33 34 30 31 32
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
-* transpose of RFP A above. One therefore gets:
-*
-* RFP A RFP A
-*
-* 02 12 22 00 01 00 10 20 30 40 50
-* 03 13 23 33 11 33 11 21 31 41 51
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* Reference
-* =========
-*
-* =====================================================================
-*
-* ..
-* .. Local Scalars ..
- LOGICAL LOWER, NISODD, NORMALTRANSR
- INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MOD
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="strttp"></A>
- <H2>strttp</H2>
-
- <PRE>
-USAGE:
- ap, info = NumRu::Lapack.strttp( uplo, a)
- or
- NumRu::Lapack.strttp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO )
-
-* Purpose
-* =======
-*
-* STRTTP copies a triangular matrix A from full format (TR) to standard
-* packed format (TP).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular.
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrices AP and A. N >= 0.
-*
-* A (input) REAL array, dimension (LDA,N)
-* On exit, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AP (output) REAL array, dimension (N*(N+1)/2
-* On exit, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/stz.html b/doc/stz.html
deleted file mode 100644
index ba45c4f..0000000
--- a/doc/stz.html
+++ /dev/null
@@ -1,216 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>REAL routines for trapezoidal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>REAL routines for trapezoidal matrix</H1>
- <UL>
- <LI><A HREF="#stzrqf">stzrqf</A> : </LI>
- <LI><A HREF="#stzrzf">stzrzf</A> : </LI>
- </UL>
-
- <A NAME="stzrqf"></A>
- <H2>stzrqf</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.stzrqf( a)
- or
- NumRu::Lapack.stzrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine STZRZF.
-*
-* STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
-* to upper triangular form by means of orthogonal transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* orthogonal matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), which is used to introduce zeros into
-* the ( m - k + 1 )th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="stzrzf"></A>
- <H2>stzrzf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.stzrzf( a, lwork)
- or
- NumRu::Lapack.stzrzf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
-* to upper triangular form by means of orthogonal transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* orthogonal matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) REAL array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), which is used to introduce zeros into
-* the ( m - k + 1 )th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="s.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/z.html b/doc/z.html
deleted file mode 100644
index 7f48973..0000000
--- a/doc/z.html
+++ /dev/null
@@ -1,36 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines</TITLE>
- </HEAD>
- <BODY>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines</H1>
- <UL>
- <LI><A HREF="zbd.html">BD: bidiagonal</A></LI>
- <LI><A HREF="zgb.html">GB: general band</A></LI>
- <LI><A HREF="zge.html">GE: general (i.e., unsymmetric, in some cases rectangular)</A></LI>
- <LI><A HREF="zgg.html">GG: general matrices, generalized problem (i.e., a pair of general matrices)</A></LI>
- <LI><A HREF="zgt.html">GT: general tridiagonal</A></LI>
- <LI><A HREF="zhb.html">HB: (complex) Hermitian band</A></LI>
- <LI><A HREF="zhe.html">HE: (complex) Hermitian</A></LI>
- <LI><A HREF="zhg.html">HG: upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix)</A></LI>
- <LI><A HREF="zhp.html">HP: (complex) Hermitian, packed storage</A></LI>
- <LI><A HREF="zhs.html">HS: upper Hessenberg</A></LI>
- <LI><A HREF="zpb.html">PB: symmetric or Hermitian positive definite band</A></LI>
- <LI><A HREF="zpo.html">PO: symmetric or Hermitian positive definite</A></LI>
- <LI><A HREF="zpp.html">PP: symmetric or Hermitian positive definite, packed storage</A></LI>
- <LI><A HREF="zpt.html">PT: symmetric or Hermitian positive definite tridiagonal</A></LI>
- <LI><A HREF="zsp.html">SP: symmetric, packed storage</A></LI>
- <LI><A HREF="zst.html">ST: (real) symmetric tridiagonal</A></LI>
- <LI><A HREF="zsy.html">SY: symmetric</A></LI>
- <LI><A HREF="ztb.html">TB: triangular band</A></LI>
- <LI><A HREF="ztg.html">TG: triangular matrices, generalized problem (i.e., a pair of triangular matrices)</A></LI>
- <LI><A HREF="ztp.html">TP: triangular, packed storage</A></LI>
- <LI><A HREF="ztr.html">TR: triangular (or in some cases quasi-triangular)</A></LI>
- <LI><A HREF="ztz.html">TZ: trapezoidal</A></LI>
- <LI><A HREF="zun.html">UN: (complex) unitary</A></LI>
- <LI><A HREF="zup.html">UP: (complex) unitary, packed storageBDbidiagonal</A></LI>
- </UL>
- <HR />
- <A HREF="index.html">back to data types</A>
- </BODY>
-</HTML>
diff --git a/doc/zbd.html b/doc/zbd.html
deleted file mode 100644
index c5994d8..0000000
--- a/doc/zbd.html
+++ /dev/null
@@ -1,163 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for bidiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for bidiagonal matrix</H1>
- <UL>
- <LI><A HREF="#zbdsqr">zbdsqr</A> : </LI>
- </UL>
-
- <A NAME="zbdsqr"></A>
- <H2>zbdsqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, vt, u, c = NumRu::Lapack.zbdsqr( uplo, nru, d, e, vt, u, c)
- or
- NumRu::Lapack.zbdsqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZBDSQR computes the singular values and, optionally, the right and/or
-* left singular vectors from the singular value decomposition (SVD) of
-* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
-* zero-shift QR algorithm. The SVD of B has the form
-*
-* B = Q * S * P**H
-*
-* where S is the diagonal matrix of singular values, Q is an orthogonal
-* matrix of left singular vectors, and P is an orthogonal matrix of
-* right singular vectors. If left singular vectors are requested, this
-* subroutine actually returns U*Q instead of Q, and, if right singular
-* vectors are requested, this subroutine returns P**H*VT instead of
-* P**H, for given complex input matrices U and VT. When U and VT are
-* the unitary matrices that reduce a general matrix A to bidiagonal
-* form: A = U*B*VT, as computed by ZGEBRD, then
-*
-* A = (U*Q) * S * (P**H*VT)
-*
-* is the SVD of A. Optionally, the subroutine may also compute Q**H*C
-* for a given complex input matrix C.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices With
-* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
-* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
-* no. 5, pp. 873-912, Sept 1990) and
-* "Accurate singular values and differential qd algorithms," by
-* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
-* Department, University of California at Berkeley, July 1992
-* for a detailed description of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': B is upper bidiagonal;
-* = 'L': B is lower bidiagonal.
-*
-* N (input) INTEGER
-* The order of the matrix B. N >= 0.
-*
-* NCVT (input) INTEGER
-* The number of columns of the matrix VT. NCVT >= 0.
-*
-* NRU (input) INTEGER
-* The number of rows of the matrix U. NRU >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the bidiagonal matrix B.
-* On exit, if INFO=0, the singular values of B in decreasing
-* order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the N-1 offdiagonal elements of the bidiagonal
-* matrix B.
-* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
-* will contain the diagonal and superdiagonal elements of a
-* bidiagonal matrix orthogonally equivalent to the one given
-* as input.
-*
-* VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)
-* On entry, an N-by-NCVT matrix VT.
-* On exit, VT is overwritten by P**H * VT.
-* Not referenced if NCVT = 0.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT.
-* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
-*
-* U (input/output) COMPLEX*16 array, dimension (LDU, N)
-* On entry, an NRU-by-N matrix U.
-* On exit, U is overwritten by U * Q.
-* Not referenced if NRU = 0.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,NRU).
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC, NCC)
-* On entry, an N-by-NCC matrix C.
-* On exit, C is overwritten by Q**H * C.
-* Not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm did not converge; D and E contain the
-* elements of a bidiagonal matrix which is orthogonally
-* similar to the input matrix B; if INFO = i, i
-* elements of E have not converged to zero.
-*
-* Internal Parameters
-* ===================
-*
-* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
-* TOLMUL controls the convergence criterion of the QR loop.
-* If it is positive, TOLMUL*EPS is the desired relative
-* precision in the computed singular values.
-* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
-* desired absolute accuracy in the computed singular
-* values (corresponds to relative accuracy
-* abs(TOLMUL*EPS) in the largest singular value.
-* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
-* between 10 (for fast convergence) and .1/EPS
-* (for there to be some accuracy in the results).
-* Default is to lose at either one eighth or 2 of the
-* available decimal digits in each computed singular value
-* (whichever is smaller).
-*
-* MAXITR INTEGER, default = 6
-* MAXITR controls the maximum number of passes of the
-* algorithm through its inner loop. The algorithms stops
-* (and so fails to converge) if the number of passes
-* through the inner loop exceeds MAXITR*N**2.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zc.html b/doc/zc.html
deleted file mode 100644
index 91cde21..0000000
--- a/doc/zc.html
+++ /dev/null
@@ -1,14 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>Data type in complex*16 but solving problem using complex precision routines</TITLE>
- </HEAD>
- <BODY>
- <H1>Data type in complex*16 but solving problem using complex precision routines</H1>
- <UL>
- <LI><A HREF="zcge.html">GE: general (i.e., unsymmetric, in some cases rectangular)</A></LI>
- <LI><A HREF="zcpo.html">PO: symmetric or Hermitian positive definite</A></LI>
- </UL>
- <HR />
- <A HREF="index.html">back to data types</A>
- </BODY>
-</HTML>
diff --git a/doc/zcge.html b/doc/zcge.html
deleted file mode 100644
index b5c3f89..0000000
--- a/doc/zcge.html
+++ /dev/null
@@ -1,143 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>Data type in complex*16 but solving problem using complex precision routines for general (i.e., unsymmetric, in some cases rectangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>Data type in complex*16 but solving problem using complex precision routines for general (i.e., unsymmetric, in some cases rectangular) matrix</H1>
- <UL>
- <LI><A HREF="#zcgesv">zcgesv</A> : </LI>
- </UL>
-
- <A NAME="zcgesv"></A>
- <H2>zcgesv</H2>
-
- <PRE>
-USAGE:
- ipiv, x, iter, info, a = NumRu::Lapack.zcgesv( a, b)
- or
- NumRu::Lapack.zcgesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )
-
-* Purpose
-* =======
-*
-* ZCGESV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* ZCGESV first attempts to factorize the matrix in COMPLEX and use this
-* factorization within an iterative refinement procedure to produce a
-* solution with COMPLEX*16 normwise backward error quality (see below).
-* If the approach fails the method switches to a COMPLEX*16
-* factorization and solve.
-*
-* The iterative refinement is not going to be a winning strategy if
-* the ratio COMPLEX performance over COMPLEX*16 performance is too
-* small. A reasonable strategy should take the number of right-hand
-* sides and the size of the matrix into account. This might be done
-* with a call to ILAENV in the future. Up to now, we always try
-* iterative refinement.
-*
-* The iterative refinement process is stopped if
-* ITER > ITERMAX
-* or for all the RHS we have:
-* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
-* where
-* o ITER is the number of the current iteration in the iterative
-* refinement process
-* o RNRM is the infinity-norm of the residual
-* o XNRM is the infinity-norm of the solution
-* o ANRM is the infinity-operator-norm of the matrix A
-* o EPS is the machine epsilon returned by DLAMCH('Epsilon')
-* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00
-* respectively.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array,
-* dimension (LDA,N)
-* On entry, the N-by-N coefficient matrix A.
-* On exit, if iterative refinement has been successfully used
-* (INFO.EQ.0 and ITER.GE.0, see description below), then A is
-* unchanged, if double precision factorization has been used
-* (INFO.EQ.0 and ITER.LT.0, see description below), then the
-* array A contains the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-* Corresponds either to the single precision factorization
-* (if INFO.EQ.0 and ITER.GE.0) or the double precision
-* factorization (if INFO.EQ.0 and ITER.LT.0).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)
-* This array is used to hold the residual vectors.
-*
-* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))
-* This array is used to use the single precision matrix and the
-* right-hand sides or solutions in single precision.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* ITER (output) INTEGER
-* < 0: iterative refinement has failed, COMPLEX*16
-* factorization has been performed
-* -1 : the routine fell back to full precision for
-* implementation- or machine-specific reasons
-* -2 : narrowing the precision induced an overflow,
-* the routine fell back to full precision
-* -3 : failure of CGETRF
-* -31: stop the iterative refinement after the 30th
-* iterations
-* > 0: iterative refinement has been sucessfully used.
-* Returns the number of iterations
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) computed in COMPLEX*16 is exactly
-* zero. The factorization has been completed, but the
-* factor U is exactly singular, so the solution
-* could not be computed.
-*
-* =========
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="zc.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zcpo.html b/doc/zcpo.html
deleted file mode 100644
index 31c08a0..0000000
--- a/doc/zcpo.html
+++ /dev/null
@@ -1,151 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>Data type in complex*16 but solving problem using complex precision routines for symmetric or Hermitian positive definite matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>Data type in complex*16 but solving problem using complex precision routines for symmetric or Hermitian positive definite matrix</H1>
- <UL>
- <LI><A HREF="#zcposv">zcposv</A> : </LI>
- </UL>
-
- <A NAME="zcposv"></A>
- <H2>zcposv</H2>
-
- <PRE>
-USAGE:
- x, iter, info, a = NumRu::Lapack.zcposv( uplo, a, b)
- or
- NumRu::Lapack.zcposv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )
-
-* Purpose
-* =======
-*
-* ZCPOSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* ZCPOSV first attempts to factorize the matrix in COMPLEX and use this
-* factorization within an iterative refinement procedure to produce a
-* solution with COMPLEX*16 normwise backward error quality (see below).
-* If the approach fails the method switches to a COMPLEX*16
-* factorization and solve.
-*
-* The iterative refinement is not going to be a winning strategy if
-* the ratio COMPLEX performance over COMPLEX*16 performance is too
-* small. A reasonable strategy should take the number of right-hand
-* sides and the size of the matrix into account. This might be done
-* with a call to ILAENV in the future. Up to now, we always try
-* iterative refinement.
-*
-* The iterative refinement process is stopped if
-* ITER > ITERMAX
-* or for all the RHS we have:
-* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
-* where
-* o ITER is the number of the current iteration in the iterative
-* refinement process
-* o RNRM is the infinity-norm of the residual
-* o XNRM is the infinity-norm of the solution
-* o ANRM is the infinity-operator-norm of the matrix A
-* o EPS is the machine epsilon returned by DLAMCH('Epsilon')
-* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00
-* respectively.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array,
-* dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* Note that the imaginary parts of the diagonal
-* elements need not be set and are assumed to be zero.
-*
-* On exit, if iterative refinement has been successfully used
-* (INFO.EQ.0 and ITER.GE.0, see description below), then A is
-* unchanged, if double precision factorization has been used
-* (INFO.EQ.0 and ITER.LT.0, see description below), then the
-* array A contains the factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)
-* This array is used to hold the residual vectors.
-*
-* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))
-* This array is used to use the single precision matrix and the
-* right-hand sides or solutions in single precision.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* ITER (output) INTEGER
-* < 0: iterative refinement has failed, COMPLEX*16
-* factorization has been performed
-* -1 : the routine fell back to full precision for
-* implementation- or machine-specific reasons
-* -2 : narrowing the precision induced an overflow,
-* the routine fell back to full precision
-* -3 : failure of CPOTRF
-* -31: stop the iterative refinement after the 30th
-* iterations
-* > 0: iterative refinement has been sucessfully used.
-* Returns the number of iterations
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of
-* (COMPLEX*16) A is not positive definite, so the
-* factorization could not be completed, and the solution
-* has not been computed.
-*
-* =========
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="zc.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zgb.html b/doc/zgb.html
deleted file mode 100644
index 46c9c7e..0000000
--- a/doc/zgb.html
+++ /dev/null
@@ -1,1897 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for general band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for general band matrix</H1>
- <UL>
- <LI><A HREF="#zgbbrd">zgbbrd</A> : </LI>
- <LI><A HREF="#zgbcon">zgbcon</A> : </LI>
- <LI><A HREF="#zgbequ">zgbequ</A> : </LI>
- <LI><A HREF="#zgbequb">zgbequb</A> : </LI>
- <LI><A HREF="#zgbrfs">zgbrfs</A> : </LI>
- <LI><A HREF="#zgbrfsx">zgbrfsx</A> : </LI>
- <LI><A HREF="#zgbsv">zgbsv</A> : </LI>
- <LI><A HREF="#zgbsvx">zgbsvx</A> : </LI>
- <LI><A HREF="#zgbsvxx">zgbsvxx</A> : </LI>
- <LI><A HREF="#zgbtf2">zgbtf2</A> : </LI>
- <LI><A HREF="#zgbtrf">zgbtrf</A> : </LI>
- <LI><A HREF="#zgbtrs">zgbtrs</A> : </LI>
- </UL>
-
- <A NAME="zgbbrd"></A>
- <H2>zgbbrd</H2>
-
- <PRE>
-USAGE:
- d, e, q, pt, info, ab, c = NumRu::Lapack.zgbbrd( vect, kl, ku, ab, c)
- or
- NumRu::Lapack.zgbbrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGBBRD reduces a complex general m-by-n band matrix A to real upper
-* bidiagonal form B by a unitary transformation: Q' * A * P = B.
-*
-* The routine computes B, and optionally forms Q or P', or computes
-* Q'*C for a given matrix C.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether or not the matrices Q and P' are to be
-* formed.
-* = 'N': do not form Q or P';
-* = 'Q': form Q only;
-* = 'P': form P' only;
-* = 'B': form both.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NCC (input) INTEGER
-* The number of columns of the matrix C. NCC >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals of the matrix A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals of the matrix A. KU >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the m-by-n band matrix A, stored in rows 1 to
-* KL+KU+1. The j-th column of A is stored in the j-th column of
-* the array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-* On exit, A is overwritten by values generated during the
-* reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KL+KU+1.
-*
-* D (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B.
-*
-* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
-* The superdiagonal elements of the bidiagonal matrix B.
-*
-* Q (output) COMPLEX*16 array, dimension (LDQ,M)
-* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.
-* If VECT = 'N' or 'P', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
-*
-* PT (output) COMPLEX*16 array, dimension (LDPT,N)
-* If VECT = 'P' or 'B', the n-by-n unitary matrix P'.
-* If VECT = 'N' or 'Q', the array PT is not referenced.
-*
-* LDPT (input) INTEGER
-* The leading dimension of the array PT.
-* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,NCC)
-* On entry, an m-by-ncc matrix C.
-* On exit, C is overwritten by Q'*C.
-* C is not referenced if NCC = 0.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C.
-* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (max(M,N))
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbcon"></A>
- <H2>zgbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zgbcon( norm, kl, ku, ab, ipiv, anorm)
- or
- NumRu::Lapack.zgbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGBCON estimates the reciprocal of the condition number of a complex
-* general band matrix A, in either the 1-norm or the infinity-norm,
-* using the LU factorization computed by ZGBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by ZGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* ANORM (input) DOUBLE PRECISION
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbequ"></A>
- <H2>zgbequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequ( m, kl, ku, ab)
- or
- NumRu::Lapack.zgbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZGBEQU computes row and column scalings intended to equilibrate an
-* M-by-N band matrix A and reduce its condition number. R returns the
-* row scale factors and C the column scale factors, chosen to try to
-* make the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
-* column of A is stored in the j-th column of the array AB as
-* follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0, or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbequb"></A>
- <H2>zgbequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequb( kl, ku, ab)
- or
- NumRu::Lapack.zgbequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZGBEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from ZGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= max(1,M).
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbrfs"></A>
- <H2>zgbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)
- or
- NumRu::Lapack.zgbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is banded, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by ZGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from ZGBTRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZGBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbrfsx"></A>
- <H2>zgbrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.zgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.zgbrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGBRFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The original band matrix A, stored in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from DGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbsv"></A>
- <H2>zgbsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab, b = NumRu::Lapack.zgbsv( kl, ku, ab, b)
- or
- NumRu::Lapack.zgbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZGBSV computes the solution to a complex system of linear equations
-* A * X = B, where A is a band matrix of order N with KL subdiagonals
-* and KU superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as A = L * U, where L is a product of permutation
-* and unit lower triangular matrices with KL subdiagonals, and U is
-* upper triangular with KL+KU superdiagonals. The factored form of A
-* is then used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGBTRF, ZGBTRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbsvx"></A>
- <H2>zgbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.zgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.zgbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGBSVX uses the LU factorization to compute the solution to a complex
-* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
-* where A is a band matrix of order N with KL subdiagonals and KU
-* superdiagonals, and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed by this subroutine:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = L * U,
-* where L is a product of permutation and unit lower triangular
-* matrices with KL subdiagonals, and U is upper triangular with
-* KL+KU superdiagonals.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB and IPIV contain the factored form of
-* A. If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* AB, AFB, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then A must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by ZGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns details of the LU factorization of A.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns details of the LU factorization of the equilibrated
-* matrix A (see the description of AB for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = L*U
-* as computed by ZGBTRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace/output) DOUBLE PRECISION array, dimension (N)
-* On exit, RWORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If RWORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* RWORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-* Moved setting of INFO = N+1 so INFO does not subsequently get
-* overwritten. Sven, 17 Mar 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbsvxx"></A>
- <H2>zgbsvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.zgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.zgbsvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGBSVXX uses the LU factorization to compute the solution to a
-* complex*16 system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. ZGBSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* ZGBSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* ZGBSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what ZGBSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose = Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
-*
-* If FACT = 'F' and EQUED is not 'N', then AB must have been
-* equilibrated by the scaling factors in R and/or C. AB is not
-* modified if FACT = 'F' or 'N', or if FACT = 'E' and
-* EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KL+KU+1.
-*
-* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains details of the LU factorization of the band matrix
-* A, as computed by ZGBTRF. U is stored as an upper triangular
-* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
-* and the multipliers used during the factorization are stored
-* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
-* the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by DGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In DGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbtf2"></A>
- <H2>zgbtf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.zgbtf2( m, kl, ku, ab)
- or
- NumRu::Lapack.zgbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZGBTF2 computes an LU factorization of a complex m-by-n band matrix
-* A using partial pivoting with row interchanges.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U, because of fill-in resulting from the row
-* interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbtrf"></A>
- <H2>zgbtrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ab = NumRu::Lapack.zgbtrf( m, kl, ku, ab)
- or
- NumRu::Lapack.zgbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgbtrs"></A>
- <H2>zgbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zgbtrs( trans, kl, ku, ab, ipiv, b)
- or
- NumRu::Lapack.zgbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZGBTRS solves a system of linear equations
-* A * X = B, A**T * X = B, or A**H * X = B
-* with a general band matrix A using the LU factorization computed
-* by ZGBTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by ZGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zge.html b/doc/zge.html
deleted file mode 100644
index 95f19f4..0000000
--- a/doc/zge.html
+++ /dev/null
@@ -1,5392 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for general (i.e., unsymmetric, in some cases rectangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for general (i.e., unsymmetric, in some cases rectangular) matrix</H1>
- <UL>
- <LI><A HREF="#zgebak">zgebak</A> : </LI>
- <LI><A HREF="#zgebal">zgebal</A> : </LI>
- <LI><A HREF="#zgebd2">zgebd2</A> : </LI>
- <LI><A HREF="#zgebrd">zgebrd</A> : </LI>
- <LI><A HREF="#zgecon">zgecon</A> : </LI>
- <LI><A HREF="#zgeequ">zgeequ</A> : </LI>
- <LI><A HREF="#zgeequb">zgeequb</A> : </LI>
- <LI><A HREF="#zgees">zgees</A> : </LI>
- <LI><A HREF="#zgeesx">zgeesx</A> : </LI>
- <LI><A HREF="#zgeev">zgeev</A> : </LI>
- <LI><A HREF="#zgeevx">zgeevx</A> : </LI>
- <LI><A HREF="#zgegs">zgegs</A> : </LI>
- <LI><A HREF="#zgegv">zgegv</A> : </LI>
- <LI><A HREF="#zgehd2">zgehd2</A> : </LI>
- <LI><A HREF="#zgehrd">zgehrd</A> : </LI>
- <LI><A HREF="#zgelq2">zgelq2</A> : </LI>
- <LI><A HREF="#zgelqf">zgelqf</A> : </LI>
- <LI><A HREF="#zgels">zgels</A> : </LI>
- <LI><A HREF="#zgelsd">zgelsd</A> : </LI>
- <LI><A HREF="#zgelss">zgelss</A> : </LI>
- <LI><A HREF="#zgelsx">zgelsx</A> : </LI>
- <LI><A HREF="#zgelsy">zgelsy</A> : </LI>
- <LI><A HREF="#zgeql2">zgeql2</A> : </LI>
- <LI><A HREF="#zgeqlf">zgeqlf</A> : </LI>
- <LI><A HREF="#zgeqp3">zgeqp3</A> : </LI>
- <LI><A HREF="#zgeqpf">zgeqpf</A> : </LI>
- <LI><A HREF="#zgeqr2">zgeqr2</A> : </LI>
- <LI><A HREF="#zgeqr2p">zgeqr2p</A> : </LI>
- <LI><A HREF="#zgeqrf">zgeqrf</A> : </LI>
- <LI><A HREF="#zgeqrfp">zgeqrfp</A> : </LI>
- <LI><A HREF="#zgerfs">zgerfs</A> : </LI>
- <LI><A HREF="#zgerfsx">zgerfsx</A> : </LI>
- <LI><A HREF="#zgerq2">zgerq2</A> : </LI>
- <LI><A HREF="#zgerqf">zgerqf</A> : </LI>
- <LI><A HREF="#zgesc2">zgesc2</A> : </LI>
- <LI><A HREF="#zgesdd">zgesdd</A> : </LI>
- <LI><A HREF="#zgesv">zgesv</A> : </LI>
- <LI><A HREF="#zgesvd">zgesvd</A> : </LI>
- <LI><A HREF="#zgesvx">zgesvx</A> : </LI>
- <LI><A HREF="#zgesvxx">zgesvxx</A> : </LI>
- <LI><A HREF="#zgetc2">zgetc2</A> : </LI>
- <LI><A HREF="#zgetf2">zgetf2</A> : </LI>
- <LI><A HREF="#zgetrf">zgetrf</A> : </LI>
- <LI><A HREF="#zgetri">zgetri</A> : </LI>
- <LI><A HREF="#zgetrs">zgetrs</A> : </LI>
- </UL>
-
- <A NAME="zgebak"></A>
- <H2>zgebak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.zgebak( job, side, ilo, ihi, scale, v)
- or
- NumRu::Lapack.zgebak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* ZGEBAK forms the right or left eigenvectors of a complex general
-* matrix by backward transformation on the computed eigenvectors of the
-* balanced matrix output by ZGEBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N', do nothing, return immediately;
-* = 'P', do backward transformation for permutation only;
-* = 'S', do backward transformation for scaling only;
-* = 'B', do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to ZGEBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by ZGEBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* SCALE (input) DOUBLE PRECISION array, dimension (N)
-* Details of the permutation and scaling factors, as returned
-* by ZGEBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) COMPLEX*16 array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by ZHSEIN or ZTREVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgebal"></A>
- <H2>zgebal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, scale, info, a = NumRu::Lapack.zgebal( job, a)
- or
- NumRu::Lapack.zgebal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* ZGEBAL balances a general complex matrix A. This involves, first,
-* permuting A by a similarity transformation to isolate eigenvalues
-* in the first 1 to ILO-1 and last IHI+1 to N elements on the
-* diagonal; and second, applying a diagonal similarity transformation
-* to rows and columns ILO to IHI to make the rows and columns as
-* close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrix, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A:
-* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
-* for i = 1,...,N;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* SCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied to
-* A. If P(j) is the index of the row and column interchanged
-* with row and column j and D(j) is the scaling factor
-* applied to row and column j, then
-* SCALE(j) = P(j) for j = 1,...,ILO-1
-* = D(j) for j = ILO,...,IHI
-* = P(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The permutations consist of row and column interchanges which put
-* the matrix in the form
-*
-* ( T1 X Y )
-* P A P = ( 0 B Z )
-* ( 0 0 T2 )
-*
-* where T1 and T2 are upper triangular matrices whose eigenvalues lie
-* along the diagonal. The column indices ILO and IHI mark the starting
-* and ending columns of the submatrix B. Balancing consists of applying
-* a diagonal similarity transformation inv(D) * B * D to make the
-* 1-norms of each row of B and its corresponding column nearly equal.
-* The output matrix is
-*
-* ( T1 X*D Y )
-* ( 0 inv(D)*B*D inv(D)*Z ).
-* ( 0 0 T2 )
-*
-* Information about the permutations P and the diagonal matrix D is
-* returned in the vector SCALE.
-*
-* This subroutine is based on the EISPACK routine CBAL.
-*
-* Modified by Tzu-Yi Chen, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgebd2"></A>
- <H2>zgebd2</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, info, a = NumRu::Lapack.zgebd2( m, a)
- or
- NumRu::Lapack.zgebd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEBD2 reduces a complex general m by n matrix A to upper or lower
-* real bidiagonal form B by a unitary transformation: Q' * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the m by n general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the unitary matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the unitary matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) COMPLEX*16 array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q. See Further Details.
-*
-* TAUP (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix P. See Further Details.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (max(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, and v and u are complex
-* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
-* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
-* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, v and u are complex vectors;
-* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
-* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
-* tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgebrd"></A>
- <H2>zgebrd</H2>
-
- <PRE>
-USAGE:
- d, e, tauq, taup, work, info, a = NumRu::Lapack.zgebrd( m, a, lwork)
- or
- NumRu::Lapack.zgebrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEBRD reduces a general complex M-by-N matrix A to upper or lower
-* bidiagonal form B by a unitary transformation: Q**H * A * P = B.
-*
-* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows in the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns in the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N general matrix to be reduced.
-* On exit,
-* if m >= n, the diagonal and the first superdiagonal are
-* overwritten with the upper bidiagonal matrix B; the
-* elements below the diagonal, with the array TAUQ, represent
-* the unitary matrix Q as a product of elementary
-* reflectors, and the elements above the first superdiagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors;
-* if m < n, the diagonal and the first subdiagonal are
-* overwritten with the lower bidiagonal matrix B; the
-* elements below the first subdiagonal, with the array TAUQ,
-* represent the unitary matrix Q as a product of
-* elementary reflectors, and the elements above the diagonal,
-* with the array TAUP, represent the unitary matrix P as
-* a product of elementary reflectors.
-* See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* D (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The diagonal elements of the bidiagonal matrix B:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
-* The off-diagonal elements of the bidiagonal matrix B:
-* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
-* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
-*
-* TAUQ (output) COMPLEX*16 array dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q. See Further Details.
-*
-* TAUP (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix P. See Further Details.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,M,N).
-* For optimum performance LWORK >= (M+N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrices Q and P are represented as products of elementary
-* reflectors:
-*
-* If m >= n,
-*
-* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, and v and u are complex
-* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in
-* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in
-* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* If m < n,
-*
-* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
-*
-* Each H(i) and G(i) has the form:
-*
-* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
-*
-* where tauq and taup are complex scalars, and v and u are complex
-* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in
-* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in
-* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
-*
-* The contents of A on exit are illustrated by the following examples:
-*
-* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
-*
-* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
-* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
-* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
-* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
-* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
-* ( v1 v2 v3 v4 v5 )
-*
-* where d and e denote diagonal and off-diagonal elements of B, vi
-* denotes an element of the vector defining H(i), and ui an element of
-* the vector defining G(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgecon"></A>
- <H2>zgecon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zgecon( norm, a, anorm)
- or
- NumRu::Lapack.zgecon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGECON estimates the reciprocal of the condition number of a general
-* complex matrix A, in either the 1-norm or the infinity-norm, using
-* the LU factorization computed by ZGETRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by ZGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) DOUBLE PRECISION
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeequ"></A>
- <H2>zgeequ</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequ( a)
- or
- NumRu::Lapack.zgeequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZGEEQU computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
-*
-* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
-* number and BIGNUM = largest safe number. Use of these scaling
-* factors is not guaranteed to reduce the condition number of A but
-* works well in practice.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeequb"></A>
- <H2>zgeequb</H2>
-
- <PRE>
-USAGE:
- r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequb( a)
- or
- NumRu::Lapack.zgeequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZGEEQUB computes row and column scalings intended to equilibrate an
-* M-by-N matrix A and reduce its condition number. R returns the row
-* scale factors and C the column scale factors, chosen to try to make
-* the largest element in each row and column of the matrix B with
-* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most
-* the radix.
-*
-* R(i) and C(j) are restricted to be a power of the radix between
-* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use
-* of these scaling factors is not guaranteed to reduce the condition
-* number of A but works well in practice.
-*
-* This routine differs from ZGEEQU by restricting the scaling factors
-* to a power of the radix. Baring over- and underflow, scaling by
-* these factors introduces no additional rounding errors. However, the
-* scaled entries' magnitured are no longer approximately 1 but lie
-* between sqrt(radix) and 1/sqrt(radix).
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The M-by-N matrix whose equilibration factors are
-* to be computed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* R (output) DOUBLE PRECISION array, dimension (M)
-* If INFO = 0 or INFO > M, R contains the row scale factors
-* for A.
-*
-* C (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, C contains the column scale factors for A.
-*
-* ROWCND (output) DOUBLE PRECISION
-* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
-* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
-* AMAX is neither too large nor too small, it is not worth
-* scaling by R.
-*
-* COLCND (output) DOUBLE PRECISION
-* If INFO = 0, COLCND contains the ratio of the smallest
-* C(i) to the largest C(i). If COLCND >= 0.1, it is not
-* worth scaling by C.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= M: the i-th row of A is exactly zero
-* > M: the (i-M)-th column of A is exactly zero
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgees"></A>
- <H2>zgees</H2>
-
- <PRE>
-USAGE:
- sdim, w, vs, work, info, a = NumRu::Lapack.zgees( jobvs, sort, a, lwork){|a| ... }
- or
- NumRu::Lapack.zgees # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEES computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues, the Schur form T, and, optionally, the matrix of Schur
-* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* Schur form so that selected eigenvalues are at the top left.
-* The leading columns of Z then form an orthonormal basis for the
-* invariant subspace corresponding to the selected eigenvalues.
-*
-* A complex matrix is in Schur form if it is upper triangular.
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered:
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to order
-* to the top left of the Schur form.
-* IF SORT = 'N', SELECT is not referenced.
-* The eigenvalue W(j) is selected if SELECT(W(j)) is true.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten by its Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues for which
-* SELECT is true.
-*
-* W (output) COMPLEX*16 array, dimension (N)
-* W contains the computed eigenvalues, in the same order that
-* they appear on the diagonal of the output Schur form T.
-*
-* VS (output) COMPLEX*16 array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the unitary matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1; if
-* JOBVS = 'V', LDVS >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of W
-* contain those eigenvalues which have converged;
-* if JOBVS = 'V', VS contains the matrix which
-* reduces A to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because
-* some eigenvalues were too close to separate (the
-* problem is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Schur form no longer satisfy
-* SELECT = .TRUE.. This could also be caused by
-* underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeesx"></A>
- <H2>zgeesx</H2>
-
- <PRE>
-USAGE:
- sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.zgeesx( jobvs, sort, sense, a, lwork){|a| ... }
- or
- NumRu::Lapack.zgeesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues, the Schur form T, and, optionally, the matrix of Schur
-* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).
-*
-* Optionally, it also orders the eigenvalues on the diagonal of the
-* Schur form so that selected eigenvalues are at the top left;
-* computes a reciprocal condition number for the average of the
-* selected eigenvalues (RCONDE); and computes a reciprocal condition
-* number for the right invariant subspace corresponding to the
-* selected eigenvalues (RCONDV). The leading columns of Z form an
-* orthonormal basis for this invariant subspace.
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
-* these quantities are called s and sep respectively).
-*
-* A complex matrix is in Schur form if it is upper triangular.
-*
-
-* Arguments
-* =========
-*
-* JOBVS (input) CHARACTER*1
-* = 'N': Schur vectors are not computed;
-* = 'V': Schur vectors are computed.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELECT).
-*
-* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument
-* SELECT must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'S', SELECT is used to select eigenvalues to order
-* to the top left of the Schur form.
-* If SORT = 'N', SELECT is not referenced.
-* An eigenvalue W(j) is selected if SELECT(W(j)) is true.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for average of selected eigenvalues only;
-* = 'V': Computed for selected right invariant subspace only;
-* = 'B': Computed for both.
-* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the N-by-N matrix A.
-* On exit, A is overwritten by its Schur form T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues for which
-* SELECT is true.
-*
-* W (output) COMPLEX*16 array, dimension (N)
-* W contains the computed eigenvalues, in the same order
-* that they appear on the diagonal of the output Schur form T.
-*
-* VS (output) COMPLEX*16 array, dimension (LDVS,N)
-* If JOBVS = 'V', VS contains the unitary matrix Z of Schur
-* vectors.
-* If JOBVS = 'N', VS is not referenced.
-*
-* LDVS (input) INTEGER
-* The leading dimension of the array VS. LDVS >= 1, and if
-* JOBVS = 'V', LDVS >= N.
-*
-* RCONDE (output) DOUBLE PRECISION
-* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
-* condition number for the average of the selected eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) DOUBLE PRECISION
-* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
-* condition number for the selected right invariant subspace.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),
-* where SDIM is the number of selected eigenvalues computed by
-* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also
-* that an error is only returned if LWORK < max(1,2*N), but if
-* SENSE = 'E' or 'V' or 'B' this may not be large enough.
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates upper bound on the optimal size of the
-* array WORK, returns this value as the first entry of the WORK
-* array, and no error message related to LWORK is issued by
-* XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is
-* <= N: the QR algorithm failed to compute all the
-* eigenvalues; elements 1:ILO-1 and i+1:N of W
-* contain those eigenvalues which have converged; if
-* JOBVS = 'V', VS contains the transformation which
-* reduces A to its partially converged Schur form.
-* = N+1: the eigenvalues could not be reordered because some
-* eigenvalues were too close to separate (the problem
-* is very ill-conditioned);
-* = N+2: after reordering, roundoff changed values of some
-* complex eigenvalues so that leading eigenvalues in
-* the Schur form no longer satisfy SELECT=.TRUE. This
-* could also be caused by underflow due to scaling.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeev"></A>
- <H2>zgeev</H2>
-
- <PRE>
-USAGE:
- w, vl, vr, work, info, a = NumRu::Lapack.zgeev( jobvl, jobvr, a, lwork)
- or
- NumRu::Lapack.zgeev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of are computed.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) COMPLEX*16 array, dimension (N)
-* W contains the computed eigenvalues.
-*
-* VL (output) COMPLEX*16 array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* u(j) = VL(:,j), the j-th column of VL.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX*16 array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* v(j) = VR(:,j), the j-th column of VR.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1; if
-* JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors have been computed;
-* elements and i+1:N of W contain eigenvalues which have
-* converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeevx"></A>
- <H2>zgeevx</H2>
-
- <PRE>
-USAGE:
- w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.zgeevx( balanc, jobvl, jobvr, sense, a, lwork)
- or
- NumRu::Lapack.zgeevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the
-* eigenvalues and, optionally, the left and/or right eigenvectors.
-*
-* Optionally also, it computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
-* (RCONDE), and reciprocal condition numbers for the right
-* eigenvectors (RCONDV).
-*
-* The right eigenvector v(j) of A satisfies
-* A * v(j) = lambda(j) * v(j)
-* where lambda(j) is its eigenvalue.
-* The left eigenvector u(j) of A satisfies
-* u(j)**H * A = lambda(j) * u(j)**H
-* where u(j)**H denotes the conjugate transpose of u(j).
-*
-* The computed eigenvectors are normalized to have Euclidean norm
-* equal to 1 and largest component real.
-*
-* Balancing a matrix means permuting the rows and columns to make it
-* more nearly upper triangular, and applying a diagonal similarity
-* transformation D * A * D**(-1), where D is a diagonal matrix, to
-* make its rows and columns closer in norm and the condition numbers
-* of its eigenvalues and eigenvectors smaller. The computed
-* reciprocal condition numbers correspond to the balanced matrix.
-* Permuting rows and columns will not change the condition numbers
-* (in exact arithmetic) but diagonal scaling will. For further
-* explanation of balancing, see section 4.10.2 of the LAPACK
-* Users' Guide.
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Indicates how the input matrix should be diagonally scaled
-* and/or permuted to improve the conditioning of its
-* eigenvalues.
-* = 'N': Do not diagonally scale or permute;
-* = 'P': Perform permutations to make the matrix more nearly
-* upper triangular. Do not diagonally scale;
-* = 'S': Diagonally scale the matrix, ie. replace A by
-* D*A*D**(-1), where D is a diagonal matrix chosen
-* to make the rows and columns of A more equal in
-* norm. Do not permute;
-* = 'B': Both diagonally scale and permute A.
-*
-* Computed reciprocal condition numbers will be for the matrix
-* after balancing and/or permuting. Permuting does not change
-* condition numbers (in exact arithmetic), but balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': left eigenvectors of A are not computed;
-* = 'V': left eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVL must = 'V'.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': right eigenvectors of A are not computed;
-* = 'V': right eigenvectors of A are computed.
-* If SENSE = 'E' or 'B', JOBVR must = 'V'.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': None are computed;
-* = 'E': Computed for eigenvalues only;
-* = 'V': Computed for right eigenvectors only;
-* = 'B': Computed for eigenvalues and right eigenvectors.
-*
-* If SENSE = 'E' or 'B', both left and right eigenvectors
-* must also be computed (JOBVL = 'V' and JOBVR = 'V').
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the N-by-N matrix A.
-* On exit, A has been overwritten. If JOBVL = 'V' or
-* JOBVR = 'V', A contains the Schur form of the balanced
-* version of the matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) COMPLEX*16 array, dimension (N)
-* W contains the computed eigenvalues.
-*
-* VL (output) COMPLEX*16 array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored one
-* after another in the columns of VL, in the same order
-* as their eigenvalues.
-* If JOBVL = 'N', VL is not referenced.
-* u(j) = VL(:,j), the j-th column of VL.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; if
-* JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX*16 array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors v(j) are stored one
-* after another in the columns of VR, in the same order
-* as their eigenvalues.
-* If JOBVR = 'N', VR is not referenced.
-* v(j) = VR(:,j), the j-th column of VR.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1; if
-* JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values determined when A was
-* balanced. The balanced A(i,j) = 0 if I > J and
-* J = 1,...,ILO-1 or I = IHI+1,...,N.
-*
-* SCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* when balancing A. If P(j) is the index of the row and column
-* interchanged with row and column j, and D(j) is the scaling
-* factor applied to row and column j, then
-* SCALE(J) = P(J), for J = 1,...,ILO-1
-* = D(J), for J = ILO,...,IHI
-* = P(J) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) DOUBLE PRECISION
-* The one-norm of the balanced matrix (the maximum
-* of the sum of absolute values of elements of any column).
-*
-* RCONDE (output) DOUBLE PRECISION array, dimension (N)
-* RCONDE(j) is the reciprocal condition number of the j-th
-* eigenvalue.
-*
-* RCONDV (output) DOUBLE PRECISION array, dimension (N)
-* RCONDV(j) is the reciprocal condition number of the j-th
-* right eigenvector.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. If SENSE = 'N' or 'E',
-* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',
-* LWORK >= N*N+2*N.
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the QR algorithm failed to compute all the
-* eigenvalues, and no eigenvectors or condition numbers
-* have been computed; elements 1:ILO-1 and i+1:N of W
-* contain eigenvalues which have converged.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgegs"></A>
- <H2>zgegs</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgegs( jobvsl, jobvsr, a, b, lwork)
- or
- NumRu::Lapack.zgegs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine ZGGES.
-*
-* ZGEGS computes the eigenvalues, Schur form, and, optionally, the
-* left and or/right Schur vectors of a complex matrix pair (A,B).
-* Given two square matrices A and B, the generalized Schur
-* factorization has the form
-*
-* A = Q*S*Z**H, B = Q*T*Z**H
-*
-* where Q and Z are unitary matrices and S and T are upper triangular.
-* The columns of Q are the left Schur vectors
-* and the columns of Z are the right Schur vectors.
-*
-* If only the eigenvalues of (A,B) are needed, the driver routine
-* ZGEGV should be used instead. See ZGEGV for a description of the
-* eigenvalues of the generalized nonsymmetric eigenvalue problem
-* (GNEP).
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors (returned in VSL).
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors (returned in VSR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the matrix A.
-* On exit, the upper triangular matrix S from the generalized
-* Schur factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the matrix B.
-* On exit, the upper triangular matrix T from the generalized
-* Schur factorization.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* The complex scalars alpha that define the eigenvalues of
-* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur
-* form of A.
-*
-* BETA (output) COMPLEX*16 array, dimension (N)
-* The non-negative real scalars beta that define the
-* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element
-* of the triangular factor T.
-*
-* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
-* represent the j-th eigenvalue of the matrix pair (A,B), in
-* one of the forms lambda = alpha/beta or mu = beta/alpha.
-* Since either lambda or mu may overflow, they should not,
-* in general, be computed.
-*
-*
-* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)
-* If JOBVSL = 'V', the matrix of left Schur vectors Q.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >= 1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)
-* If JOBVSR = 'V', the matrix of right Schur vectors Z.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute:
-* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;
-* the optimal LWORK is N*(NB+1).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHA(j) and BETA(j) should be correct for
-* j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from ZGGBAL
-* =N+2: error return from ZGEQRF
-* =N+3: error return from ZUNMQR
-* =N+4: error return from ZUNGQR
-* =N+5: error return from ZGGHRD
-* =N+6: error return from ZHGEQZ (other than failed
-* iteration)
-* =N+7: error return from ZGGBAK (computing VSL)
-* =N+8: error return from ZGGBAK (computing VSR)
-* =N+9: error return from ZLASCL (various places)
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgegv"></A>
- <H2>zgegv</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zgegv( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.zgegv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine ZGGEV.
-*
-* ZGEGV computes the eigenvalues and, optionally, the left and/or right
-* eigenvectors of a complex matrix pair (A,B).
-* Given two square matrices A and B,
-* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
-* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
-* that
-* A*x = lambda*B*x.
-*
-* An alternate form is to find the eigenvalues mu and corresponding
-* eigenvectors y such that
-* mu*A*y = B*y.
-*
-* These two forms are equivalent with mu = 1/lambda and x = y if
-* neither lambda nor mu is zero. In order to deal with the case that
-* lambda or mu is zero or small, two values alpha and beta are returned
-* for each eigenvalue, such that lambda = alpha/beta and
-* mu = beta/alpha.
-*
-* The vectors x and y in the above equations are right eigenvectors of
-* the matrix pair (A,B). Vectors u and v satisfying
-* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
-* are left eigenvectors of (A,B).
-*
-* Note: this routine performs "full balancing" on A and B -- see
-* "Further Details", below.
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors (returned
-* in VL).
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors (returned
-* in VR).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the matrix A.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit A
-* contains the Schur form of A from the generalized Schur
-* factorization of the pair (A,B) after balancing. If no
-* eigenvectors were computed, then only the diagonal elements
-* of the Schur form will be correct. See ZGGHRD and ZHGEQZ
-* for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the matrix B.
-* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
-* upper triangular matrix obtained from B in the generalized
-* Schur factorization of the pair (A,B) after balancing.
-* If no eigenvectors were computed, then only the diagonal
-* elements of B will be correct. See ZGGHRD and ZHGEQZ for
-* details.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* The complex scalars alpha that define the eigenvalues of
-* GNEP.
-*
-* BETA (output) COMPLEX*16 array, dimension (N)
-* The complex scalars beta that define the eigenvalues of GNEP.
-*
-* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
-* represent the j-th eigenvalue of the matrix pair (A,B), in
-* one of the forms lambda = alpha/beta or mu = beta/alpha.
-* Since either lambda or mu may overflow, they should not,
-* in general, be computed.
-*
-* VL (output) COMPLEX*16 array, dimension (LDVL,N)
-* If JOBVL = 'V', the left eigenvectors u(j) are stored
-* in the columns of VL, in the same order as their eigenvalues.
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvectors
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX*16 array, dimension (LDVR,N)
-* If JOBVR = 'V', the right eigenvectors x(j) are stored
-* in the columns of VR, in the same order as their eigenvalues.
-* Each eigenvector is scaled so that its largest component has
-* abs(real part) + abs(imag. part) = 1, except for eigenvectors
-* corresponding to an eigenvalue with alpha = beta = 0, which
-* are set to zero.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-* To compute the optimal value of LWORK, call ILAENV to get
-* blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.) Then compute:
-* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR;
-* The optimal LWORK is MAX( 2*N, N*(NB+1) ).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHA(j) and BETA(j) should be
-* correct for j=INFO+1,...,N.
-* > N: errors that usually indicate LAPACK problems:
-* =N+1: error return from ZGGBAL
-* =N+2: error return from ZGEQRF
-* =N+3: error return from ZUNMQR
-* =N+4: error return from ZUNGQR
-* =N+5: error return from ZGGHRD
-* =N+6: error return from ZHGEQZ (other than failed
-* iteration)
-* =N+7: error return from ZTGEVC
-* =N+8: error return from ZGGBAK (computing VL)
-* =N+9: error return from ZGGBAK (computing VR)
-* =N+10: error return from ZLASCL (various calls)
-*
-
-* Further Details
-* ===============
-*
-* Balancing
-* ---------
-*
-* This driver calls ZGGBAL to both permute and scale rows and columns
-* of A and B. The permutations PL and PR are chosen so that PL*A*PR
-* and PL*B*R will be upper triangular except for the diagonal blocks
-* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
-* possible. The diagonal scaling matrices DL and DR are chosen so
-* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
-* one (except for the elements that start out zero.)
-*
-* After the eigenvalues and eigenvectors of the balanced matrices
-* have been computed, ZGGBAK transforms the eigenvectors back to what
-* they would have been (in perfect arithmetic) if they had not been
-* balanced.
-*
-* Contents of A and B on Exit
-* -------- -- - --- - -- ----
-*
-* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
-* both), then on exit the arrays A and B will contain the complex Schur
-* form[*] of the "balanced" versions of A and B. If no eigenvectors
-* are computed, then only the diagonal blocks will be correct.
-*
-* [*] In other words, upper triangular form.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgehd2"></A>
- <H2>zgehd2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.zgehd2( ilo, ihi, a)
- or
- NumRu::Lapack.zgehd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H
-* by a unitary similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to ZGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= max(1,N).
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the n by n general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the unitary matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) COMPLEX*16 array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgehrd"></A>
- <H2>zgehrd</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.zgehrd( ilo, ihi, a, lwork)
- or
- NumRu::Lapack.zgehrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by
-* an unitary similarity transformation: Q' * A * Q = H .
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that A is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to ZGEBAL; otherwise they should be
-* set to 1 and N respectively. See Further Details.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* elements below the first subdiagonal, with the array TAU,
-* represent the unitary matrix Q as a product of elementary
-* reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (output) COMPLEX*16 array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
-* zero.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of (ihi-ilo) elementary
-* reflectors
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
-* exit in A(i+2:ihi,i), and tau in TAU(i).
-*
-* The contents of A are illustrated by the following example, with
-* n = 7, ilo = 2 and ihi = 6:
-*
-* on entry, on exit,
-*
-* ( a a a a a a a ) ( a a h h h h a )
-* ( a a a a a a ) ( a h h h h a )
-* ( a a a a a a ) ( h h h h h h )
-* ( a a a a a a ) ( v2 h h h h h )
-* ( a a a a a a ) ( v2 v3 h h h h )
-* ( a a a a a a ) ( v2 v3 v4 h h h )
-* ( a ) ( a )
-*
-* where a denotes an element of the original matrix A, h denotes a
-* modified element of the upper Hessenberg matrix H, and vi denotes an
-* element of the vector defining H(i).
-*
-* This file is a slight modification of LAPACK-3.0's DGEHRD
-* subroutine incorporating improvements proposed by Quintana-Orti and
-* Van de Geijn (2006). (See DLAHR2.)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgelq2"></A>
- <H2>zgelq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.zgelq2( a)
- or
- NumRu::Lapack.zgelq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGELQ2 computes an LQ factorization of a complex m by n matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m by min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
-* A(i,i+1:n), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgelqf"></A>
- <H2>zgelqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.zgelqf( m, a, lwork)
- or
- NumRu::Lapack.zgelqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGELQF computes an LQ factorization of a complex M-by-N matrix A:
-* A = L * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and below the diagonal of the array
-* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
-* lower triangular if m <= n); the elements above the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in
-* A(i,i+1:n), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgels"></A>
- <H2>zgels</H2>
-
- <PRE>
-USAGE:
- work, info, a, b = NumRu::Lapack.zgels( trans, m, a, b, lwork)
- or
- NumRu::Lapack.zgels # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGELS solves overdetermined or underdetermined complex linear systems
-* involving an M-by-N matrix A, or its conjugate-transpose, using a QR
-* or LQ factorization of A. It is assumed that A has full rank.
-*
-* The following options are provided:
-*
-* 1. If TRANS = 'N' and m >= n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A*X ||.
-*
-* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
-* an underdetermined system A * X = B.
-*
-* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of
-* an undetermined system A**H * X = B.
-*
-* 4. If TRANS = 'C' and m < n: find the least squares solution of
-* an overdetermined system, i.e., solve the least squares problem
-* minimize || B - A**H * X ||.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N': the linear system involves A;
-* = 'C': the linear system involves A**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* if M >= N, A is overwritten by details of its QR
-* factorization as returned by ZGEQRF;
-* if M < N, A is overwritten by details of its LQ
-* factorization as returned by ZGELQF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the matrix B of right hand side vectors, stored
-* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
-* if TRANS = 'C'.
-* On exit, if INFO = 0, B is overwritten by the solution
-* vectors, stored columnwise:
-* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
-* squares solution vectors; the residual sum of squares for the
-* solution in each column is given by the sum of squares of the
-* modulus of elements N+1 to M in that column;
-* if TRANS = 'N' and m < n, rows 1 to N of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'C' and m >= n, rows 1 to M of B contain the
-* minimum norm solution vectors;
-* if TRANS = 'C' and m < n, rows 1 to M of B contain the
-* least squares solution vectors; the residual sum of squares
-* for the solution in each column is given by the sum of
-* squares of the modulus of elements M+1 to N in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= MAX(1,M,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= max( 1, MN + max( MN, NRHS ) ).
-* For optimal performance,
-* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
-* where MN = min(M,N) and NB is the optimum block size.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of the
-* triangular factor of A is zero, so that A does not have
-* full rank; the least squares solution could not be
-* computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgelsd"></A>
- <H2>zgelsd</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, b = NumRu::Lapack.zgelsd( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.zgelsd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGELSD computes the minimum-norm solution to a real linear least
-* squares problem:
-* minimize 2-norm(| b - A*x |)
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The problem is solved in three steps:
-* (1) Reduce the coefficient matrix A to bidiagonal form with
-* Householder tranformations, reducing the original problem
-* into a "bidiagonal least squares problem" (BLS)
-* (2) Solve the BLS using a divide and conquer approach.
-* (3) Apply back all the Householder tranformations to solve
-* the original least squares problem.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of the modulus of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK must be at least 1.
-* The exact minimum amount of workspace needed depends on M,
-* N and NRHS. As long as LWORK is at least
-* 2*N + N*NRHS
-* if M is greater than or equal to N or
-* 2*M + M*NRHS
-* if M is less than N, the code will execute correctly.
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the array WORK and the
-* minimum sizes of the arrays RWORK and IWORK, and returns
-* these values as the first entries of the WORK, RWORK and
-* IWORK arrays, and no error message related to LWORK is issued
-* by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
-* LRWORK >=
-* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +
-* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
-* if M is greater than or equal to N or
-* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +
-* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )
-* if M is less than N, the code will execute correctly.
-* SMLSIZ is returned by ILAENV and is equal to the maximum
-* size of the subproblems at the bottom of the computation
-* tree (usually about 25), and
-* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
-* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.
-*
-* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
-* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
-* where MINMN = MIN( M,N ).
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Ren-Cang Li, Computer Science Division, University of
-* California at Berkeley, USA
-* Osni Marques, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgelss"></A>
- <H2>zgelss</H2>
-
- <PRE>
-USAGE:
- s, rank, work, info, a, b = NumRu::Lapack.zgelss( m, a, b, rcond, lwork)
- or
- NumRu::Lapack.zgelss # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGELSS computes the minimum norm solution to a complex linear
-* least squares problem:
-*
-* Minimize 2-norm(| b - A*x |).
-*
-* using the singular value decomposition (SVD) of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
-* X.
-*
-* The effective rank of A is determined by treating as zero those
-* singular values which are less than RCOND times the largest singular
-* value.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the first min(m,n) rows of A are overwritten with
-* its right singular vectors, stored rowwise.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, B is overwritten by the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of the modulus of elements n+1:m in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A in decreasing order.
-* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A.
-* Singular values S(i) <= RCOND*S(1) are treated as zero.
-* If RCOND < 0, machine precision is used instead.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the number of singular values
-* which are greater than RCOND*S(1).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1, and also:
-* LWORK >= 2*min(M,N) + max(M,N,NRHS)
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: the algorithm for computing the SVD failed to converge;
-* if INFO = i, i off-diagonal elements of an intermediate
-* bidiagonal form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgelsx"></A>
- <H2>zgelsx</H2>
-
- <PRE>
-USAGE:
- rank, info, a, b, jpvt = NumRu::Lapack.zgelsx( m, a, b, jpvt, rcond)
- or
- NumRu::Lapack.zgelsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine ZGELSY.
-*
-* ZGELSX computes the minimum-norm solution to a complex linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by unitary transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-* If m >= n and RANK = n, the residual sum-of-squares for
-* the solution in the i-th column is given by the sum of
-* squares of elements N+1:M in that column.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
-* initial column, otherwise it is a free column. Before
-* the QR factorization of A, all initial columns are
-* permuted to the leading positions; only the remaining
-* free columns are moved as a result of column pivoting
-* during the factorization.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace) COMPLEX*16 array, dimension
-* (min(M,N) + max( N, 2*min(M,N)+NRHS )),
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgelsy"></A>
- <H2>zgelsy</H2>
-
- <PRE>
-USAGE:
- rank, work, info, a, b, jpvt = NumRu::Lapack.zgelsy( m, a, b, jpvt, rcond, lwork)
- or
- NumRu::Lapack.zgelsy # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGELSY computes the minimum-norm solution to a complex linear least
-* squares problem:
-* minimize || A * X - B ||
-* using a complete orthogonal factorization of A. A is an M-by-N
-* matrix which may be rank-deficient.
-*
-* Several right hand side vectors b and solution vectors x can be
-* handled in a single call; they are stored as the columns of the
-* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
-* matrix X.
-*
-* The routine first computes a QR factorization with column pivoting:
-* A * P = Q * [ R11 R12 ]
-* [ 0 R22 ]
-* with R11 defined as the largest leading submatrix whose estimated
-* condition number is less than 1/RCOND. The order of R11, RANK,
-* is the effective rank of A.
-*
-* Then, R22 is considered to be negligible, and R12 is annihilated
-* by unitary transformations from the right, arriving at the
-* complete orthogonal factorization:
-* A * P = Q * [ T11 0 ] * Z
-* [ 0 0 ]
-* The minimum-norm solution is then
-* X = P * Z' [ inv(T11)*Q1'*B ]
-* [ 0 ]
-* where Q1 consists of the first RANK columns of Q.
-*
-* This routine is basically identical to the original xGELSX except
-* three differences:
-* o The permutation of matrix B (the right hand side) is faster and
-* more simple.
-* o The call to the subroutine xGEQPF has been substituted by the
-* the call to the subroutine xGEQP3. This subroutine is a Blas-3
-* version of the QR factorization with column pivoting.
-* o Matrix B (the right hand side) is updated with Blas-3.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of
-* columns of matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A has been overwritten by details of its
-* complete orthogonal factorization.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the M-by-NRHS right hand side matrix B.
-* On exit, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,M,N).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of AP, otherwise column i is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* RCOND (input) DOUBLE PRECISION
-* RCOND is used to determine the effective rank of A, which
-* is defined as the order of the largest leading triangular
-* submatrix R11 in the QR factorization with pivoting of A,
-* whose estimated condition number < 1/RCOND.
-*
-* RANK (output) INTEGER
-* The effective rank of A, i.e., the order of the submatrix
-* R11. This is the same as the order of the submatrix T11
-* in the complete orthogonal factorization of A.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* The unblocked strategy requires that:
-* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )
-* where MN = min(M,N).
-* The block algorithm requires that:
-* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )
-* where NB is an upper bound on the blocksize returned
-* by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,
-* and ZUNMRZ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeql2"></A>
- <H2>zgeql2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.zgeql2( m, a)
- or
- NumRu::Lapack.zgeql2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEQL2 computes a QL factorization of a complex m by n matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the m by n lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* unitary matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeqlf"></A>
- <H2>zgeqlf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.zgeqlf( m, a, lwork)
- or
- NumRu::Lapack.zgeqlf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEQLF computes a QL factorization of a complex M-by-N matrix A:
-* A = Q * L.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m >= n, the lower triangle of the subarray
-* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
-* if m <= n, the elements on and below the (n-m)-th
-* superdiagonal contain the M-by-N lower trapezoidal matrix L;
-* the remaining elements, with the array TAU, represent the
-* unitary matrix Q as a product of elementary reflectors
-* (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
-* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGEQL2, ZLARFB, ZLARFT
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeqp3"></A>
- <H2>zgeqp3</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a, jpvt = NumRu::Lapack.zgeqp3( m, a, jpvt, lwork)
- or
- NumRu::Lapack.zgeqp3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEQP3 computes a QR factorization with column pivoting of a
-* matrix A: A*P = Q*R using Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper trapezoidal matrix R; the elements below
-* the diagonal, together with the array TAU, represent the
-* unitary matrix Q as a product of min(M,N) elementary
-* reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(J)=0,
-* the J-th column of A is a free column.
-* On exit, if JPVT(J)=K, then the J-th column of A*P was the
-* the K-th column of A.
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= N+1.
-* For optimal performance LWORK >= ( N+1 )*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a real/complex scalar, and v is a real/complex vector
-* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
-* A(i+1:m,i), and tau in TAU(i).
-*
-* Based on contributions by
-* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
-* X. Sun, Computer Science Dept., Duke University, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeqpf"></A>
- <H2>zgeqpf</H2>
-
- <PRE>
-USAGE:
- tau, info, a, jpvt = NumRu::Lapack.zgeqpf( m, a, jpvt)
- or
- NumRu::Lapack.zgeqpf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine ZGEQP3.
-*
-* ZGEQPF computes a QR factorization with column pivoting of a
-* complex M-by-N matrix A: A*P = Q*R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the upper triangle of the array contains the
-* min(M,N)-by-N upper triangular matrix R; the elements
-* below the diagonal, together with the array TAU,
-* represent the unitary matrix Q as a product of
-* min(m,n) elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* JPVT (input/output) INTEGER array, dimension (N)
-* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
-* to the front of A*P (a leading column); if JPVT(i) = 0,
-* the i-th column of A is a free column.
-* On exit, if JPVT(i) = k, then the i-th column of A*P
-* was the k-th column of A.
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(n)
-*
-* Each H(i) has the form
-*
-* H = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
-*
-* The matrix P is represented in jpvt as follows: If
-* jpvt(j) = i
-* then the jth column of P is the ith canonical unit vector.
-*
-* Partial column norm updating strategy modified by
-* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
-* University of Zagreb, Croatia.
-* June 2010
-* For more details see LAPACK Working Note 176.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeqr2"></A>
- <H2>zgeqr2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.zgeqr2( m, a)
- or
- NumRu::Lapack.zgeqr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEQR2 computes a QR factorization of a complex m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeqr2p"></A>
- <H2>zgeqr2p</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.zgeqr2p( m, a)
- or
- NumRu::Lapack.zgeqr2p # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEQR2P computes a QR factorization of a complex m by n matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(m,n) by n upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of elementary reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeqrf"></A>
- <H2>zgeqrf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.zgeqrf( m, a, lwork)
- or
- NumRu::Lapack.zgeqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEQRF computes a QR factorization of a complex M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgeqrfp"></A>
- <H2>zgeqrfp</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.zgeqrfp( m, a, lwork)
- or
- NumRu::Lapack.zgeqrfp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGEQRFP computes a QR factorization of a complex M-by-N matrix A:
-* A = Q * R.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
-* upper triangular if m >= n); the elements below the diagonal,
-* with the array TAU, represent the unitary matrix Q as a
-* product of min(m,n) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
-* and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
- $ NBMIN, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGEQR2P, ZLARFB, ZLARFT
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgerfs"></A>
- <H2>zgerfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zgerfs( trans, a, af, ipiv, b, x)
- or
- NumRu::Lapack.zgerfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGERFS improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates for
-* the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by ZGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from ZGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgerfsx"></A>
- <H2>zgerfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.zgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)
- or
- NumRu::Lapack.zgerfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGERFSX improves the computed solution to a system of linear
-* equations and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED, R
-* and C below. In this case, the solution and error bounds returned
-* are for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose = Transpose)
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The original N-by-N matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by ZGETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from ZGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* R (input) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed.
-* If R is accessed, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed.
-* If C is accessed, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgerq2"></A>
- <H2>zgerq2</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.zgerq2( a)
- or
- NumRu::Lapack.zgerq2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGERQ2 computes an RQ factorization of a complex m by n matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the m by n matrix A.
-* On exit, if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the m by n upper trapezoidal matrix R; the remaining
-* elements, with the array TAU, represent the unitary matrix
-* Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on
-* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgerqf"></A>
- <H2>zgerqf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.zgerqf( m, a, lwork)
- or
- NumRu::Lapack.zgerqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGERQF computes an RQ factorization of a complex M-by-N matrix A:
-* A = R * Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if m <= n, the upper triangle of the subarray
-* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
-* if m >= n, the elements on and above the (m-n)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R;
-* the remaining elements, with the array TAU, represent the
-* unitary matrix Q as a product of min(m,n) elementary
-* reflectors (see Further Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on
-* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
- $ MU, NB, NBMIN, NU, NX
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGERQ2, ZLARFB, ZLARFT
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgesc2"></A>
- <H2>zgesc2</H2>
-
- <PRE>
-USAGE:
- scale, rhs = NumRu::Lapack.zgesc2( a, rhs, ipiv, jpiv)
- or
- NumRu::Lapack.zgesc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
-
-* Purpose
-* =======
-*
-* ZGESC2 solves a system of linear equations
-*
-* A * X = scale* RHS
-*
-* with a general N-by-N matrix A using the LU factorization with
-* complete pivoting computed by ZGETC2.
-*
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of columns of the matrix A.
-*
-* A (input) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the LU part of the factorization of the n-by-n
-* matrix A computed by ZGETC2: A = P * L * U * Q
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, N).
-*
-* RHS (input/output) COMPLEX*16 array, dimension N.
-* On entry, the right hand side vector b.
-* On exit, the solution vector X.
-*
-* IPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (input) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* SCALE (output) DOUBLE PRECISION
-* On exit, SCALE contains the scale factor. SCALE is chosen
-* 0 <= SCALE <= 1 to prevent owerflow in the solution.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgesdd"></A>
- <H2>zgesdd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.zgesdd( jobz, m, a, lwork)
- or
- NumRu::Lapack.zgesdd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGESDD computes the singular value decomposition (SVD) of a complex
-* M-by-N matrix A, optionally computing the left and/or right singular
-* vectors, by using divide-and-conquer method. The SVD is written
-*
-* A = U * SIGMA * conjugate-transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
-* V is an N-by-N unitary matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns VT = V**H, not V.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U and all N rows of V**H are
-* returned in the arrays U and VT;
-* = 'S': the first min(M,N) columns of U and the first
-* min(M,N) rows of V**H are returned in the arrays U
-* and VT;
-* = 'O': If M >= N, the first N columns of U are overwritten
-* in the array A and all rows of V**H are returned in
-* the array VT;
-* otherwise, all columns of U are returned in the
-* array U and the first M rows of V**H are overwritten
-* in the array A;
-* = 'N': no columns of U or rows of V**H are computed.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBZ = 'O', A is overwritten with the first N columns
-* of U (the left singular vectors, stored
-* columnwise) if M >= N;
-* A is overwritten with the first M rows
-* of V**H (the right singular vectors, stored
-* rowwise) otherwise.
-* if JOBZ .ne. 'O', the contents of A are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) COMPLEX*16 array, dimension (LDU,UCOL)
-* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
-* UCOL = min(M,N) if JOBZ = 'S'.
-* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
-* unitary matrix U;
-* if JOBZ = 'S', U contains the first min(M,N) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
-*
-* VT (output) COMPLEX*16 array, dimension (LDVT,N)
-* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
-* N-by-N unitary matrix V**H;
-* if JOBZ = 'S', VT contains the first min(M,N) rows of
-* V**H (the right singular vectors, stored rowwise);
-* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
-* if JOBZ = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).
-* if JOBZ = 'O',
-* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
-* if JOBZ = 'S' or 'A',
-* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, a workspace query is assumed. The optimal
-* size for the WORK array is calculated and stored in WORK(1),
-* and no other work except argument checking is performed.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
-* If JOBZ = 'N', LRWORK >= 5*min(M,N).
-* Otherwise,
-* LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)
-*
-* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The updating process of DBDSDC did not converge.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgesv"></A>
- <H2>zgesv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a, b = NumRu::Lapack.zgesv( a, b)
- or
- NumRu::Lapack.zgesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZGESV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* The LU decomposition with partial pivoting and row interchanges is
-* used to factor A as
-* A = P * L * U,
-* where P is a permutation matrix, L is unit lower triangular, and U is
-* upper triangular. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the N-by-N coefficient matrix A.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices that define the permutation matrix P;
-* row i of the matrix was interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS matrix of right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGETRF, ZGETRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgesvd"></A>
- <H2>zgesvd</H2>
-
- <PRE>
-USAGE:
- s, u, vt, work, info, a = NumRu::Lapack.zgesvd( jobu, jobvt, m, a, lwork)
- or
- NumRu::Lapack.zgesvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGESVD computes the singular value decomposition (SVD) of a complex
-* M-by-N matrix A, optionally computing the left and/or right singular
-* vectors. The SVD is written
-*
-* A = U * SIGMA * conjugate-transpose(V)
-*
-* where SIGMA is an M-by-N matrix which is zero except for its
-* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
-* V is an N-by-N unitary matrix. The diagonal elements of SIGMA
-* are the singular values of A; they are real and non-negative, and
-* are returned in descending order. The first min(m,n) columns of
-* U and V are the left and right singular vectors of A.
-*
-* Note that the routine returns V**H, not V.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix U:
-* = 'A': all M columns of U are returned in array U:
-* = 'S': the first min(m,n) columns of U (the left singular
-* vectors) are returned in the array U;
-* = 'O': the first min(m,n) columns of U (the left singular
-* vectors) are overwritten on the array A;
-* = 'N': no columns of U (no left singular vectors) are
-* computed.
-*
-* JOBVT (input) CHARACTER*1
-* Specifies options for computing all or part of the matrix
-* V**H:
-* = 'A': all N rows of V**H are returned in the array VT;
-* = 'S': the first min(m,n) rows of V**H (the right singular
-* vectors) are returned in the array VT;
-* = 'O': the first min(m,n) rows of V**H (the right singular
-* vectors) are overwritten on the array A;
-* = 'N': no rows of V**H (no right singular vectors) are
-* computed.
-*
-* JOBVT and JOBU cannot both be 'O'.
-*
-* M (input) INTEGER
-* The number of rows of the input matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the input matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit,
-* if JOBU = 'O', A is overwritten with the first min(m,n)
-* columns of U (the left singular vectors,
-* stored columnwise);
-* if JOBVT = 'O', A is overwritten with the first min(m,n)
-* rows of V**H (the right singular vectors,
-* stored rowwise);
-* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
-* are destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* S (output) DOUBLE PRECISION array, dimension (min(M,N))
-* The singular values of A, sorted so that S(i) >= S(i+1).
-*
-* U (output) COMPLEX*16 array, dimension (LDU,UCOL)
-* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
-* If JOBU = 'A', U contains the M-by-M unitary matrix U;
-* if JOBU = 'S', U contains the first min(m,n) columns of U
-* (the left singular vectors, stored columnwise);
-* if JOBU = 'N' or 'O', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= 1; if
-* JOBU = 'S' or 'A', LDU >= M.
-*
-* VT (output) COMPLEX*16 array, dimension (LDVT,N)
-* If JOBVT = 'A', VT contains the N-by-N unitary matrix
-* V**H;
-* if JOBVT = 'S', VT contains the first min(m,n) rows of
-* V**H (the right singular vectors, stored rowwise);
-* if JOBVT = 'N' or 'O', VT is not referenced.
-*
-* LDVT (input) INTEGER
-* The leading dimension of the array VT. LDVT >= 1; if
-* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).
-* For good performance, LWORK should generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))
-* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the
-* unconverged superdiagonal elements of an upper bidiagonal
-* matrix B whose diagonal is in S (not necessarily sorted).
-* B satisfies A = U * B * VT, so it has the same singular
-* values as A, and singular vectors related by U and VT.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if ZBDSQR did not converge, INFO specifies how many
-* superdiagonals of an intermediate bidiagonal form B
-* did not converge to zero. See the description of RWORK
-* above for details.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgesvx"></A>
- <H2>zgesvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.zgesvx( fact, trans, a, af, ipiv, equed, r, c, b)
- or
- NumRu::Lapack.zgesvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGESVX uses the LU factorization to compute the solution to a complex
-* system of linear equations
-* A * X = B,
-* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
-* matrix A (after equilibration if FACT = 'E') as
-* A = P * L * U,
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by ZGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
-* to the original system of equations. Note that A and B are
-* modified on exit if EQUED .ne. 'N', and the solution to the
-* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
-* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
-* and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace/output) DOUBLE PRECISION array, dimension (2*N)
-* On exit, RWORK(1) contains the reciprocal pivot growth
-* factor norm(A)/norm(U). The "max absolute element" norm is
-* used. If RWORK(1) is much less than 1, then the stability
-* of the LU factorization of the (equilibrated) matrix A
-* could be poor. This also means that the solution X, condition
-* estimator RCOND, and forward error bound FERR could be
-* unreliable. If factorization fails with 0<INFO<=N, then
-* RWORK(1) contains the reciprocal pivot growth factor for the
-* leading INFO columns of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization has
-* been completed, but the factor U is exactly
-* singular, so the solution and error bounds
-* could not be computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgesvxx"></A>
- <H2>zgesvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.zgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)
- or
- NumRu::Lapack.zgesvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGESVXX uses the LU factorization to compute the solution to a
-* complex*16 system of linear equations A * X = B, where A is an
-* N-by-N matrix and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. ZGESVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* ZGESVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* ZGESVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what ZGESVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
-* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
-* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
-* or diag(C)*B (if TRANS = 'T' or 'C').
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = P * L * U,
-*
-* where P is a permutation matrix, L is a unit lower triangular
-* matrix, and U is upper triangular.
-*
-* 3. If some U(i,i)=0, so that U is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is less
-* than machine precision, the routine still goes on to solve for X
-* and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
-* that it solves the original system before equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by R and C.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate Transpose)
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
-* not 'N', then A must have been equilibrated by the scaling
-* factors in R and/or C. A is not modified if FACT = 'F' or
-* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if EQUED .ne. 'N', A is scaled as follows:
-* EQUED = 'R': A := diag(R) * A
-* EQUED = 'C': A := A * diag(C)
-* EQUED = 'B': A := diag(R) * A * diag(C).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the factors L and U from the factorization
-* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then
-* AF is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the factors L and U from the factorization A = P*L*U
-* of the equilibrated matrix A (see the description of A for
-* the form of the equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the factorization A = P*L*U
-* as computed by ZGETRF; row i of the matrix was interchanged
-* with row IPIV(i).
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the original matrix A.
-*
-* If FACT = 'E', then IPIV is an output argument and on exit
-* contains the pivot indices from the factorization A = P*L*U
-* of the equilibrated matrix A.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'R': Row equilibration, i.e., A has been premultiplied by
-* diag(R).
-* = 'C': Column equilibration, i.e., A has been postmultiplied
-* by diag(C).
-* = 'B': Both row and column equilibration, i.e., A has been
-* replaced by diag(R) * A * diag(C).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* R (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'R' or 'B', A is
-* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
-* is not accessed. R is an input argument if FACT = 'F';
-* otherwise, R is an output argument. If FACT = 'F' and
-* EQUED = 'R' or 'B', each element of R must be positive.
-* If R is output, each element of R is a power of the radix.
-* If R is input, each element of R should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* C (input or output) DOUBLE PRECISION array, dimension (N)
-* The column scale factors for A. If EQUED = 'C' or 'B', A is
-* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
-* is not accessed. C is an input argument if FACT = 'F';
-* otherwise, C is an output argument. If FACT = 'F' and
-* EQUED = 'C' or 'B', each element of C must be positive.
-* If C is output, each element of C is a power of the radix.
-* If C is input, each element of C should be a power of the radix
-* to ensure a reliable solution and error estimates. Scaling by
-* powers of the radix does not cause rounding errors unless the
-* result underflows or overflows. Rounding errors during scaling
-* lead to refining with a matrix that is not equivalent to the
-* input matrix, producing error estimates that may not be
-* reliable.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
-* diag(R)*B;
-* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
-* overwritten by diag(C)*B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit
-* if EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or
-* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A. In ZGESVX, this quantity is
-* returned in WORK(1).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgetc2"></A>
- <H2>zgetc2</H2>
-
- <PRE>
-USAGE:
- ipiv, jpiv, info, a = NumRu::Lapack.zgetc2( a)
- or
- NumRu::Lapack.zgetc2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZGETC2 computes an LU factorization, using complete pivoting, of the
-* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
-* where P and Q are permutation matrices, L is lower triangular with
-* unit diagonal elements and U is upper triangular.
-*
-* This is a level 1 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the n-by-n matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U*Q; the unit diagonal elements of L are not stored.
-* If U(k, k) appears to be less than SMIN, U(k, k) is given the
-* value of SMIN, giving a nonsingular perturbed system.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, N).
-*
-* IPIV (output) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= i <= N, row i of the
-* matrix has been interchanged with row IPIV(i).
-*
-* JPIV (output) INTEGER array, dimension (N).
-* The pivot indices; for 1 <= j <= N, column j of the
-* matrix has been interchanged with column JPIV(j).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* > 0: if INFO = k, U(k, k) is likely to produce overflow if
-* one tries to solve for x in Ax = b. So U is perturbed
-* to avoid the overflow.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgetf2"></A>
- <H2>zgetf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.zgetf2( m, a)
- or
- NumRu::Lapack.zgetf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZGETF2 computes an LU factorization of a general m-by-n matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the m by n matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgetrf"></A>
- <H2>zgetrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.zgetrf( m, a)
- or
- NumRu::Lapack.zgetrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZGETRF computes an LU factorization of a general M-by-N matrix A
-* using partial pivoting with row interchanges.
-*
-* The factorization has the form
-* A = P * L * U
-* where P is a permutation matrix, L is lower triangular with unit
-* diagonal elements (lower trapezoidal if m > n), and U is upper
-* triangular (upper trapezoidal if m < n).
-*
-* This is the right-looking Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix to be factored.
-* On exit, the factors L and U from the factorization
-* A = P*L*U; the unit diagonal elements of L are not stored.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgetri"></A>
- <H2>zgetri</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zgetri( a, ipiv, lwork)
- or
- NumRu::Lapack.zgetri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGETRI computes the inverse of a matrix using the LU factorization
-* computed by ZGETRF.
-*
-* This method inverts U and then computes inv(A) by solving the system
-* inv(A)*L = inv(U) for inv(A).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the factors L and U from the factorization
-* A = P*L*U as computed by ZGETRF.
-* On exit, if INFO = 0, the inverse of the original matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from ZGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimal performance LWORK >= N*NB, where NB is
-* the optimal blocksize returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
-* singular and its inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgetrs"></A>
- <H2>zgetrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zgetrs( trans, a, ipiv, b)
- or
- NumRu::Lapack.zgetrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZGETRS solves a system of linear equations
-* A * X = B, A**T * X = B, or A**H * X = B
-* with a general N-by-N matrix A using the LU factorization computed
-* by ZGETRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The factors L and U from the factorization A = P*L*U
-* as computed by ZGETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices from ZGETRF; for 1<=i<=N, row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zgg.html b/doc/zgg.html
deleted file mode 100644
index c050985..0000000
--- a/doc/zgg.html
+++ /dev/null
@@ -1,2065 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for general matrices, generalized problem (i.e., a pair of general matrices) matrix</H1>
- <UL>
- <LI><A HREF="#zggbak">zggbak</A> : </LI>
- <LI><A HREF="#zggbal">zggbal</A> : </LI>
- <LI><A HREF="#zgges">zgges</A> : </LI>
- <LI><A HREF="#zggesx">zggesx</A> : </LI>
- <LI><A HREF="#zggev">zggev</A> : </LI>
- <LI><A HREF="#zggevx">zggevx</A> : </LI>
- <LI><A HREF="#zggglm">zggglm</A> : </LI>
- <LI><A HREF="#zgghrd">zgghrd</A> : </LI>
- <LI><A HREF="#zgglse">zgglse</A> : </LI>
- <LI><A HREF="#zggqrf">zggqrf</A> : </LI>
- <LI><A HREF="#zggrqf">zggrqf</A> : </LI>
- <LI><A HREF="#zggsvd">zggsvd</A> : </LI>
- <LI><A HREF="#zggsvp">zggsvp</A> : </LI>
- </UL>
-
- <A NAME="zggbak"></A>
- <H2>zggbak</H2>
-
- <PRE>
-USAGE:
- info, v = NumRu::Lapack.zggbak( job, side, ilo, ihi, lscale, rscale, v)
- or
- NumRu::Lapack.zggbak # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )
-
-* Purpose
-* =======
-*
-* ZGGBAK forms the right or left eigenvectors of a complex generalized
-* eigenvalue problem A*x = lambda*B*x, by backward transformation on
-* the computed eigenvectors of the balanced pair of matrices output by
-* ZGGBAL.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the type of backward transformation required:
-* = 'N': do nothing, return immediately;
-* = 'P': do backward transformation for permutation only;
-* = 'S': do backward transformation for scaling only;
-* = 'B': do backward transformations for both permutation and
-* scaling.
-* JOB must be the same as the argument JOB supplied to ZGGBAL.
-*
-* SIDE (input) CHARACTER*1
-* = 'R': V contains right eigenvectors;
-* = 'L': V contains left eigenvectors.
-*
-* N (input) INTEGER
-* The number of rows of the matrix V. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* The integers ILO and IHI determined by ZGGBAL.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* LSCALE (input) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the left side of A and B, as returned by ZGGBAL.
-*
-* RSCALE (input) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and/or scaling factors applied
-* to the right side of A and B, as returned by ZGGBAL.
-*
-* M (input) INTEGER
-* The number of columns of the matrix V. M >= 0.
-*
-* V (input/output) COMPLEX*16 array, dimension (LDV,M)
-* On entry, the matrix of right or left eigenvectors to be
-* transformed, as returned by ZTGEVC.
-* On exit, V is overwritten by the transformed eigenvectors.
-*
-* LDV (input) INTEGER
-* The leading dimension of the matrix V. LDV >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. Ward, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFTV, RIGHTV
- INTEGER I, K
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZDSCAL, ZSWAP
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggbal"></A>
- <H2>zggbal</H2>
-
- <PRE>
-USAGE:
- ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.zggbal( job, a, b)
- or
- NumRu::Lapack.zggbal # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGBAL balances a pair of general complex matrices (A,B). This
-* involves, first, permuting A and B by similarity transformations to
-* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
-* elements on the diagonal; and second, applying a diagonal similarity
-* transformation to rows and columns ILO to IHI to make the rows
-* and columns as close in norm as possible. Both steps are optional.
-*
-* Balancing may reduce the 1-norm of the matrices, and improve the
-* accuracy of the computed eigenvalues and/or eigenvectors in the
-* generalized eigenvalue problem A*x = lambda*B*x.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies the operations to be performed on A and B:
-* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
-* and RSCALE(I) = 1.0 for i=1,...,N;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the input matrix A.
-* On exit, A is overwritten by the balanced matrix.
-* If JOB = 'N', A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the input matrix B.
-* On exit, B is overwritten by the balanced matrix.
-* If JOB = 'N', B is not referenced.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are set to integers such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If P(j) is the index of the
-* row interchanged with row j, and D(j) is the scaling factor
-* applied to row j, then
-* LSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If P(j) is the index of the
-* column interchanged with column j, and D(j) is the scaling
-* factor applied to column j, then
-* RSCALE(j) = P(j) for J = 1,...,ILO-1
-* = D(j) for J = ILO,...,IHI
-* = P(j) for J = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* WORK (workspace) REAL array, dimension (lwork)
-* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
-* at least 1 when JOB = 'N' or 'P'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* See R.C. WARD, Balancing the generalized eigenvalue problem,
-* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgges"></A>
- <H2>zgges</H2>
-
- <PRE>
-USAGE:
- sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b| ... }
- or
- NumRu::Lapack.zgges # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGES computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B), the generalized eigenvalues, the generalized complex Schur
-* form (S, T), and optionally left and/or right Schur vectors (VSL
-* and VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )
-*
-* where (VSR)**H is the conjugate-transpose of VSR.
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* triangular matrix S and the upper triangular matrix T. The leading
-* columns of VSL and VSR then form an unitary basis for the
-* corresponding left and right eigenspaces (deflating subspaces).
-*
-* (If only the generalized eigenvalues are needed, use the driver
-* ZGGEV instead, which is faster.)
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0, and even for both being zero.
-*
-* A pair of matrices (S,T) is in generalized complex Schur form if S
-* and T are upper triangular and, in addition, the diagonal elements
-* of T are non-negative real numbers.
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG).
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* An eigenvalue ALPHA(j)/BETA(j) is selected if
-* SELCTG(ALPHA(j),BETA(j)) is true.
-*
-* Note that a selected complex eigenvalue may no longer satisfy
-* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned), in this
-* case INFO is set to N+2 (See INFO below).
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true.
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* BETA (output) COMPLEX*16 array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
-* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),
-* j=1,...,N are the diagonals of the complex Schur form (A,B)
-* output by ZGGES. The BETA(j) will be non-negative real.
-*
-* Note: the quotients ALPHA(j)/BETA(j) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio alpha/beta.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >= 1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (8*N)
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHA(j) and BETA(j) should be correct for
-* j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in ZHGEQZ
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering falied in ZTGSEN.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggesx"></A>
- <H2>zggesx</H2>
-
- <PRE>
-USAGE:
- sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.zggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b| ... }
- or
- NumRu::Lapack.zggesx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B), the generalized eigenvalues, the complex Schur form (S,T),
-* and, optionally, the left and/or right matrices of Schur vectors (VSL
-* and VSR). This gives the generalized Schur factorization
-*
-* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )
-*
-* where (VSR)**H is the conjugate-transpose of VSR.
-*
-* Optionally, it also orders the eigenvalues so that a selected cluster
-* of eigenvalues appears in the leading diagonal blocks of the upper
-* triangular matrix S and the upper triangular matrix T; computes
-* a reciprocal condition number for the average of the selected
-* eigenvalues (RCONDE); and computes a reciprocal condition number for
-* the right and left deflating subspaces corresponding to the selected
-* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
-* an orthonormal basis for the corresponding left and right eigenspaces
-* (deflating subspaces).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
-* or a ratio alpha/beta = w, such that A - w*B is singular. It is
-* usually represented as the pair (alpha,beta), as there is a
-* reasonable interpretation for beta=0 or for both being zero.
-*
-* A pair of matrices (S,T) is in generalized complex Schur form if T is
-* upper triangular with non-negative diagonal and S is upper
-* triangular.
-*
-
-* Arguments
-* =========
-*
-* JOBVSL (input) CHARACTER*1
-* = 'N': do not compute the left Schur vectors;
-* = 'V': compute the left Schur vectors.
-*
-* JOBVSR (input) CHARACTER*1
-* = 'N': do not compute the right Schur vectors;
-* = 'V': compute the right Schur vectors.
-*
-* SORT (input) CHARACTER*1
-* Specifies whether or not to order the eigenvalues on the
-* diagonal of the generalized Schur form.
-* = 'N': Eigenvalues are not ordered;
-* = 'S': Eigenvalues are ordered (see SELCTG).
-*
-* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments
-* SELCTG must be declared EXTERNAL in the calling subroutine.
-* If SORT = 'N', SELCTG is not referenced.
-* If SORT = 'S', SELCTG is used to select eigenvalues to sort
-* to the top left of the Schur form.
-* Note that a selected complex eigenvalue may no longer satisfy
-* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since
-* ordering may change the value of complex eigenvalues
-* (especially if the eigenvalue is ill-conditioned), in this
-* case INFO is set to N+3 see INFO below).
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N' : None are computed;
-* = 'E' : Computed for average of selected eigenvalues only;
-* = 'V' : Computed for selected deflating subspaces only;
-* = 'B' : Computed for both.
-* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VSL, and VSR. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the first of the pair of matrices.
-* On exit, A has been overwritten by its generalized Schur
-* form S.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the second of the pair of matrices.
-* On exit, B has been overwritten by its generalized Schur
-* form T.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* SDIM (output) INTEGER
-* If SORT = 'N', SDIM = 0.
-* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
-* for which SELCTG is true.
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* BETA (output) COMPLEX*16 array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
-* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are
-* the diagonals of the complex Schur form (S,T). BETA(j) will
-* be non-negative real.
-*
-* Note: the quotients ALPHA(j)/BETA(j) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio alpha/beta.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)
-* If JOBVSL = 'V', VSL will contain the left Schur vectors.
-* Not referenced if JOBVSL = 'N'.
-*
-* LDVSL (input) INTEGER
-* The leading dimension of the matrix VSL. LDVSL >=1, and
-* if JOBVSL = 'V', LDVSL >= N.
-*
-* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)
-* If JOBVSR = 'V', VSR will contain the right Schur vectors.
-* Not referenced if JOBVSR = 'N'.
-*
-* LDVSR (input) INTEGER
-* The leading dimension of the matrix VSR. LDVSR >= 1, and
-* if JOBVSR = 'V', LDVSR >= N.
-*
-* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )
-* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
-* reciprocal condition numbers for the average of the selected
-* eigenvalues.
-* Not referenced if SENSE = 'N' or 'V'.
-*
-* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )
-* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
-* reciprocal condition number for the selected deflating
-* subspaces.
-* Not referenced if SENSE = 'N' or 'E'.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
-* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else
-* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.
-* Note also that an error is only returned if
-* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may
-* not be large enough.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the bound on the optimal size of the WORK
-* array and the minimum size of the IWORK array, returns these
-* values as the first entries of the WORK and IWORK arrays, and
-* no error message related to LWORK or LIWORK is issued by
-* XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N )
-* Real workspace.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
-* LIWORK >= N+2.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the bound on the optimal size of the
-* WORK array and the minimum size of the IWORK array, returns
-* these values as the first entries of the WORK and IWORK
-* arrays, and no error message related to LWORK or LIWORK is
-* issued by XERBLA.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* Not referenced if SORT = 'N'.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. (A,B) are not in Schur
-* form, but ALPHA(j) and BETA(j) should be correct for
-* j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in ZHGEQZ
-* =N+2: after reordering, roundoff changed values of
-* some complex eigenvalues so that leading
-* eigenvalues in the Generalized Schur form no
-* longer satisfy SELCTG=.TRUE. This could also
-* be caused due to scaling.
-* =N+3: reordering failed in ZTGSEN.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggev"></A>
- <H2>zggev</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zggev( jobvl, jobvr, a, b, lwork)
- or
- NumRu::Lapack.zggev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B), the generalized eigenvalues, and optionally, the left and/or
-* right generalized eigenvectors.
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right generalized eigenvector v(j) corresponding to the
-* generalized eigenvalue lambda(j) of (A,B) satisfies
-*
-* A * v(j) = lambda(j) * B * v(j).
-*
-* The left generalized eigenvector u(j) corresponding to the
-* generalized eigenvalues lambda(j) of (A,B) satisfies
-*
-* u(j)**H * A = lambda(j) * u(j)**H * B
-*
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-
-* Arguments
-* =========
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* BETA (output) COMPLEX*16 array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
-* generalized eigenvalues.
-*
-* Note: the quotients ALPHA(j)/BETA(j) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio alpha/beta.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VL (output) COMPLEX*16 array, dimension (LDVL,N)
-* If JOBVL = 'V', the left generalized eigenvectors u(j) are
-* stored one after another in the columns of VL, in the same
-* order as their eigenvalues.
-* Each eigenvector is scaled so the largest component has
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX*16 array, dimension (LDVR,N)
-* If JOBVR = 'V', the right generalized eigenvectors v(j) are
-* stored one after another in the columns of VR, in the same
-* order as their eigenvalues.
-* Each eigenvector is scaled so the largest component has
-* abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* For good performance, LWORK must generally be larger.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* =1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHA(j) and BETA(j) should be
-* correct for j=INFO+1,...,N.
-* > N: =N+1: other then QZ iteration failed in DHGEQZ,
-* =N+2: error return from DTGEVC.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggevx"></A>
- <H2>zggevx</H2>
-
- <PRE>
-USAGE:
- alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.zggevx( balanc, jobvl, jobvr, sense, a, b, lwork)
- or
- NumRu::Lapack.zggevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
-* (A,B) the generalized eigenvalues, and optionally, the left and/or
-* right generalized eigenvectors.
-*
-* Optionally, it also computes a balancing transformation to improve
-* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
-* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
-* the eigenvalues (RCONDE), and reciprocal condition numbers for the
-* right eigenvectors (RCONDV).
-*
-* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
-* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
-* singular. It is usually represented as the pair (alpha,beta), as
-* there is a reasonable interpretation for beta=0, and even for both
-* being zero.
-*
-* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-* A * v(j) = lambda(j) * B * v(j) .
-* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
-* of (A,B) satisfies
-* u(j)**H * A = lambda(j) * u(j)**H * B.
-* where u(j)**H is the conjugate-transpose of u(j).
-*
-*
-
-* Arguments
-* =========
-*
-* BALANC (input) CHARACTER*1
-* Specifies the balance option to be performed:
-* = 'N': do not diagonally scale or permute;
-* = 'P': permute only;
-* = 'S': scale only;
-* = 'B': both permute and scale.
-* Computed reciprocal condition numbers will be for the
-* matrices after permuting and/or balancing. Permuting does
-* not change condition numbers (in exact arithmetic), but
-* balancing does.
-*
-* JOBVL (input) CHARACTER*1
-* = 'N': do not compute the left generalized eigenvectors;
-* = 'V': compute the left generalized eigenvectors.
-*
-* JOBVR (input) CHARACTER*1
-* = 'N': do not compute the right generalized eigenvectors;
-* = 'V': compute the right generalized eigenvectors.
-*
-* SENSE (input) CHARACTER*1
-* Determines which reciprocal condition numbers are computed.
-* = 'N': none are computed;
-* = 'E': computed for eigenvalues only;
-* = 'V': computed for eigenvectors only;
-* = 'B': computed for eigenvalues and eigenvectors.
-*
-* N (input) INTEGER
-* The order of the matrices A, B, VL, and VR. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the matrix A in the pair (A,B).
-* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then A contains the first part of the complex Schur
-* form of the "balanced" versions of the input A and B.
-*
-* LDA (input) INTEGER
-* The leading dimension of A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the matrix B in the pair (A,B).
-* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
-* or both, then B contains the second part of the complex
-* Schur form of the "balanced" versions of the input A and B.
-*
-* LDB (input) INTEGER
-* The leading dimension of B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* BETA (output) COMPLEX*16 array, dimension (N)
-* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized
-* eigenvalues.
-*
-* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or
-* underflow, and BETA(j) may even be zero. Thus, the user
-* should avoid naively computing the ratio ALPHA/BETA.
-* However, ALPHA will be always less than and usually
-* comparable with norm(A) in magnitude, and BETA always less
-* than and usually comparable with norm(B).
-*
-* VL (output) COMPLEX*16 array, dimension (LDVL,N)
-* If JOBVL = 'V', the left generalized eigenvectors u(j) are
-* stored one after another in the columns of VL, in the same
-* order as their eigenvalues.
-* Each eigenvector will be scaled so the largest component
-* will have abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVL = 'N'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the matrix VL. LDVL >= 1, and
-* if JOBVL = 'V', LDVL >= N.
-*
-* VR (output) COMPLEX*16 array, dimension (LDVR,N)
-* If JOBVR = 'V', the right generalized eigenvectors v(j) are
-* stored one after another in the columns of VR, in the same
-* order as their eigenvalues.
-* Each eigenvector will be scaled so the largest component
-* will have abs(real part) + abs(imag. part) = 1.
-* Not referenced if JOBVR = 'N'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the matrix VR. LDVR >= 1, and
-* if JOBVR = 'V', LDVR >= N.
-*
-* ILO (output) INTEGER
-* IHI (output) INTEGER
-* ILO and IHI are integer values such that on exit
-* A(i,j) = 0 and B(i,j) = 0 if i > j and
-* j = 1,...,ILO-1 or i = IHI+1,...,N.
-* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
-*
-* LSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the left side of A and B. If PL(j) is the index of the
-* row interchanged with row j, and DL(j) is the scaling
-* factor applied to row j, then
-* LSCALE(j) = PL(j) for j = 1,...,ILO-1
-* = DL(j) for j = ILO,...,IHI
-* = PL(j) for j = IHI+1,...,N.
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* RSCALE (output) DOUBLE PRECISION array, dimension (N)
-* Details of the permutations and scaling factors applied
-* to the right side of A and B. If PR(j) is the index of the
-* column interchanged with column j, and DR(j) is the scaling
-* factor applied to column j, then
-* RSCALE(j) = PR(j) for j = 1,...,ILO-1
-* = DR(j) for j = ILO,...,IHI
-* = PR(j) for j = IHI+1,...,N
-* The order in which the interchanges are made is N to IHI+1,
-* then 1 to ILO-1.
-*
-* ABNRM (output) DOUBLE PRECISION
-* The one-norm of the balanced matrix A.
-*
-* BBNRM (output) DOUBLE PRECISION
-* The one-norm of the balanced matrix B.
-*
-* RCONDE (output) DOUBLE PRECISION array, dimension (N)
-* If SENSE = 'E' or 'B', the reciprocal condition numbers of
-* the eigenvalues, stored in consecutive elements of the array.
-* If SENSE = 'N' or 'V', RCONDE is not referenced.
-*
-* RCONDV (output) DOUBLE PRECISION array, dimension (N)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the eigenvectors, stored in consecutive elements
-* of the array. If the eigenvalues cannot be reordered to
-* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur
-* when the true value would be very small anyway.
-* If SENSE = 'N' or 'E', RCONDV is not referenced.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,2*N).
-* If SENSE = 'E', LWORK >= max(1,4*N).
-* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) REAL array, dimension (lrwork)
-* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',
-* and at least max(1,2*N) otherwise.
-* Real workspace.
-*
-* IWORK (workspace) INTEGER array, dimension (N+2)
-* If SENSE = 'E', IWORK is not referenced.
-*
-* BWORK (workspace) LOGICAL array, dimension (N)
-* If SENSE = 'N', BWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1,...,N:
-* The QZ iteration failed. No eigenvectors have been
-* calculated, but ALPHA(j) and BETA(j) should be correct
-* for j=INFO+1,...,N.
-* > N: =N+1: other than QZ iteration failed in ZHGEQZ.
-* =N+2: error return from ZTGEVC.
-*
-
-* Further Details
-* ===============
-*
-* Balancing a matrix pair (A,B) includes, first, permuting rows and
-* columns to isolate eigenvalues, second, applying diagonal similarity
-* transformation to the rows and columns to make the rows and columns
-* as close in norm as possible. The computed reciprocal condition
-* numbers correspond to the balanced matrix. Permuting rows and columns
-* will not change the condition numbers (in exact arithmetic) but
-* diagonal scaling will. For further explanation of balancing, see
-* section 4.11.1.2 of LAPACK Users' Guide.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
-*
-* An approximate error bound for the angle between the i-th computed
-* eigenvector VL(i) or VR(i) is given by
-*
-* EPS * norm(ABNRM, BBNRM) / DIF(i).
-*
-* For further explanation of the reciprocal condition numbers RCONDE
-* and RCONDV, see section 4.11 of LAPACK User's Guide.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggglm"></A>
- <H2>zggglm</H2>
-
- <PRE>
-USAGE:
- x, y, work, info, a, b, d = NumRu::Lapack.zggglm( a, b, d, lwork)
- or
- NumRu::Lapack.zggglm # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGGLM solves a general Gauss-Markov linear model (GLM) problem:
-*
-* minimize || y ||_2 subject to d = A*x + B*y
-* x
-*
-* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
-* given N-vector. It is assumed that M <= N <= M+P, and
-*
-* rank(A) = M and rank( A B ) = N.
-*
-* Under these assumptions, the constrained equation is always
-* consistent, and there is a unique solution x and a minimal 2-norm
-* solution y, which is obtained using a generalized QR factorization
-* of the matrices (A, B) given by
-*
-* A = Q*(R), B = Q*T*Z.
-* (0)
-*
-* In particular, if matrix B is square nonsingular, then the problem
-* GLM is equivalent to the following weighted linear least squares
-* problem
-*
-* minimize || inv(B)*(d-A*x) ||_2
-* x
-*
-* where inv(B) denotes the inverse of B.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. 0 <= M <= N.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= N-M.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the upper triangular part of the array A contains
-* the M-by-M upper triangular matrix R.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* D (input/output) COMPLEX*16 array, dimension (N)
-* On entry, D is the left hand side of the GLM equation.
-* On exit, D is destroyed.
-*
-* X (output) COMPLEX*16 array, dimension (M)
-* Y (output) COMPLEX*16 array, dimension (P)
-* On exit, X and Y are the solutions of the GLM problem.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N+M+P).
-* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with A in the
-* generalized QR factorization of the pair (A, B) is
-* singular, so that rank(A) < M; the least squares
-* solution could not be computed.
-* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
-* factor T associated with B in the generalized QR
-* factorization of the pair (A, B) is singular, so that
-* rank( A B ) < N; the least squares solution could not
-* be computed.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgghrd"></A>
- <H2>zgghrd</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.zgghrd( compq, compz, ilo, ihi, a, b, q, z)
- or
- NumRu::Lapack.zgghrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )
-
-* Purpose
-* =======
-*
-* ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper
-* Hessenberg form using unitary transformations, where A is a
-* general matrix and B is upper triangular. The form of the
-* generalized eigenvalue problem is
-* A*x = lambda*B*x,
-* and B is typically made upper triangular by computing its QR
-* factorization and moving the unitary matrix Q to the left side
-* of the equation.
-*
-* This subroutine simultaneously reduces A to a Hessenberg matrix H:
-* Q**H*A*Z = H
-* and transforms B to another upper triangular matrix T:
-* Q**H*B*Z = T
-* in order to reduce the problem to its standard form
-* H*y = lambda*T*y
-* where y = Z**H*x.
-*
-* The unitary matrices Q and Z are determined as products of Givens
-* rotations. They may either be formed explicitly, or they may be
-* postmultiplied into input matrices Q1 and Z1, so that
-* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H
-* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H
-* If Q1 is the unitary matrix from the QR factorization of B in the
-* original equation A*x = lambda*B*x, then ZGGHRD reduces the original
-* problem to generalized Hessenberg form.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': do not compute Q;
-* = 'I': Q is initialized to the unit matrix, and the
-* unitary matrix Q is returned;
-* = 'V': Q must contain a unitary matrix Q1 on entry,
-* and the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': do not compute Q;
-* = 'I': Q is initialized to the unit matrix, and the
-* unitary matrix Q is returned;
-* = 'V': Q must contain a unitary matrix Q1 on entry,
-* and the product Q1*Q is returned.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of A which are to be
-* reduced. It is assumed that A is already upper triangular
-* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
-* normally set by a previous call to ZGGBAL; otherwise they
-* should be set to 1 and N respectively.
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the N-by-N general matrix to be reduced.
-* On exit, the upper triangle and the first subdiagonal of A
-* are overwritten with the upper Hessenberg matrix H, and the
-* rest is set to zero.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the N-by-N upper triangular matrix B.
-* On exit, the upper triangular matrix T = Q**H B Z. The
-* elements below the diagonal are set to zero.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDQ, N)
-* On entry, if COMPQ = 'V', the unitary matrix Q1, typically
-* from the QR factorization of B.
-* On exit, if COMPQ='I', the unitary matrix Q, and if
-* COMPQ = 'V', the product Q1*Q.
-* Not referenced if COMPQ='N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the unitary matrix Z1.
-* On exit, if COMPZ='I', the unitary matrix Z, and if
-* COMPZ = 'V', the product Z1*Z.
-* Not referenced if COMPZ='N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z.
-* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* This routine reduces A to Hessenberg and B to triangular form by
-* an unblocked reduction, as described in _Matrix_Computations_,
-* by Golub and van Loan (Johns Hopkins Press).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgglse"></A>
- <H2>zgglse</H2>
-
- <PRE>
-USAGE:
- x, work, info, a, b, c, d = NumRu::Lapack.zgglse( a, b, c, d, lwork)
- or
- NumRu::Lapack.zgglse # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGLSE solves the linear equality-constrained least squares (LSE)
-* problem:
-*
-* minimize || c - A*x ||_2 subject to B*x = d
-*
-* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
-* M-vector, and d is a given P-vector. It is assumed that
-* P <= N <= M+P, and
-*
-* rank(B) = P and rank( ( A ) ) = N.
-* ( ( B ) )
-*
-* These conditions ensure that the LSE problem has a unique solution,
-* which is obtained using a generalized RQ factorization of the
-* matrices (B, A) given by
-*
-* B = (0 R)*Q, A = Z*T*Q.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. 0 <= P <= N <= M+P.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(M,N)-by-N upper trapezoidal matrix T.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
-* contains the P-by-P upper triangular matrix R.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* C (input/output) COMPLEX*16 array, dimension (M)
-* On entry, C contains the right hand side vector for the
-* least squares part of the LSE problem.
-* On exit, the residual sum of squares for the solution
-* is given by the sum of squares of elements N-P+1 to M of
-* vector C.
-*
-* D (input/output) COMPLEX*16 array, dimension (P)
-* On entry, D contains the right hand side vector for the
-* constrained equation.
-* On exit, D is destroyed.
-*
-* X (output) COMPLEX*16 array, dimension (N)
-* On exit, X is the solution of the LSE problem.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M+N+P).
-* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
-* where NB is an upper bound for the optimal blocksizes for
-* ZGEQRF, CGERQF, ZUNMQR and CUNMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the upper triangular factor R associated with B in the
-* generalized RQ factorization of the pair (B, A) is
-* singular, so that rank(B) < P; the least squares
-* solution could not be computed.
-* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
-* T associated with A in the generalized RQ factorization
-* of the pair (B, A) is singular, so that
-* rank( (A) ) < N; the least squares solution could not
-* ( (B) )
-* be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggqrf"></A>
- <H2>zggqrf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.zggqrf( n, a, b, lwork)
- or
- NumRu::Lapack.zggqrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGQRF computes a generalized QR factorization of an N-by-M matrix A
-* and an N-by-P matrix B:
-*
-* A = Q*R, B = Q*T*Z,
-*
-* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,
-* and R and T assume one of the forms:
-*
-* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
-* ( 0 ) N-M N M-N
-* M
-*
-* where R11 is upper triangular, and
-*
-* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
-* P-N N ( T21 ) P
-* P
-*
-* where T12 or T21 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GQR factorization
-* of A and B implicitly gives the QR factorization of inv(B)*A:
-*
-* inv(B)*A = Z'*(inv(T)*R)
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* conjugate transpose of matrix Z.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of rows of the matrices A and B. N >= 0.
-*
-* M (input) INTEGER
-* The number of columns of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of columns of the matrix B. P >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,M)
-* On entry, the N-by-M matrix A.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
-* upper triangular if N >= M); the elements below the diagonal,
-* with the array TAUA, represent the unitary matrix Q as a
-* product of min(N,M) elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAUA (output) COMPLEX*16 array, dimension (min(N,M))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q (see Further Details).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,P)
-* On entry, the N-by-P matrix B.
-* On exit, if N <= P, the upper triangle of the subarray
-* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
-* if N > P, the elements on and above the (N-P)-th subdiagonal
-* contain the N-by-P upper trapezoidal matrix T; the remaining
-* elements, with the array TAUB, represent the unitary
-* matrix Z as a product of elementary reflectors (see Further
-* Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* TAUB (output) COMPLEX*16 array, dimension (min(N,P))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Z (see Further Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the QR factorization
-* of an N-by-M matrix, NB2 is the optimal blocksize for the
-* RQ factorization of an N-by-P matrix, and NB3 is the optimal
-* blocksize for a call of ZUNMQR.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(n,m).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
-* and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine ZUNGQR.
-* To use Q to update another matrix, use LAPACK subroutine ZUNMQR.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(n,p).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a complex scalar, and v is a complex vector with
-* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
-* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine ZUNGRQ.
-* To use Z to update another matrix, use LAPACK subroutine ZUNMRQ.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMQR
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggrqf"></A>
- <H2>zggrqf</H2>
-
- <PRE>
-USAGE:
- taua, taub, work, info, a, b = NumRu::Lapack.zggrqf( m, p, a, b, lwork)
- or
- NumRu::Lapack.zggrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A
-* and a P-by-N matrix B:
-*
-* A = R*Q, B = Z*T*Q,
-*
-* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary
-* matrix, and R and T assume one of the forms:
-*
-* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
-* N-M M ( R21 ) N
-* N
-*
-* where R12 or R21 is upper triangular, and
-*
-* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
-* ( 0 ) P-N P N-P
-* N
-*
-* where T11 is upper triangular.
-*
-* In particular, if B is square and nonsingular, the GRQ factorization
-* of A and B implicitly gives the RQ factorization of A*inv(B):
-*
-* A*inv(B) = (R*inv(T))*Z'
-*
-* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
-* conjugate transpose of the matrix Z.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, if M <= N, the upper triangle of the subarray
-* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
-* if M > N, the elements on and above the (M-N)-th subdiagonal
-* contain the M-by-N upper trapezoidal matrix R; the remaining
-* elements, with the array TAUA, represent the unitary
-* matrix Q as a product of elementary reflectors (see Further
-* Details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAUA (output) COMPLEX*16 array, dimension (min(M,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Q (see Further Details).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, the elements on and above the diagonal of the array
-* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
-* upper triangular if P >= N); the elements below the diagonal,
-* with the array TAUB, represent the unitary matrix Z as a
-* product of elementary reflectors (see Further Details).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TAUB (output) COMPLEX*16 array, dimension (min(P,N))
-* The scalar factors of the elementary reflectors which
-* represent the unitary matrix Z (see Further Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N,M,P).
-* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
-* where NB1 is the optimal blocksize for the RQ factorization
-* of an M-by-N matrix, NB2 is the optimal blocksize for the
-* QR factorization of a P-by-N matrix, and NB3 is the optimal
-* blocksize for a call of ZUNMRQ.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO=-i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The matrix Q is represented as a product of elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k), where k = min(m,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taua * v * v'
-*
-* where taua is a complex scalar, and v is a complex vector with
-* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
-* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
-* To form Q explicitly, use LAPACK subroutine ZUNGRQ.
-* To use Q to update another matrix, use LAPACK subroutine ZUNMRQ.
-*
-* The matrix Z is represented as a product of elementary reflectors
-*
-* Z = H(1) H(2) . . . H(k), where k = min(p,n).
-*
-* Each H(i) has the form
-*
-* H(i) = I - taub * v * v'
-*
-* where taub is a complex scalar, and v is a complex vector with
-* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
-* and taub in TAUB(i).
-* To form Z explicitly, use LAPACK subroutine ZUNGQR.
-* To use Z to update another matrix, use LAPACK subroutine ZUNMQR.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMRQ
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC INT, MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggsvd"></A>
- <H2>zggsvd</H2>
-
- <PRE>
-USAGE:
- k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.zggsvd( jobu, jobv, jobq, a, b)
- or
- NumRu::Lapack.zggsvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGSVD computes the generalized singular value decomposition (GSVD)
-* of an M-by-N complex matrix A and P-by-N complex matrix B:
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
-*
-* where U, V and Q are unitary matrices, and Z' means the conjugate
-* transpose of Z. Let K+L = the effective numerical rank of the
-* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper
-* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) "diagonal"
-* matrices and of the following structures, respectively:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 )
-* L ( 0 0 R22 )
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The routine computes C, S, R, and optionally the unitary
-* transformation matrices U, V and Q.
-*
-* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
-* A and B implicitly gives the SVD of A*inv(B):
-* A*inv(B) = U*(D1*inv(D2))*V'.
-* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also
-* equal to the CS decomposition of A and B. Furthermore, the GSVD can
-* be used to derive the solution of the eigenvalue problem:
-* A'*A x = lambda* B'*B x.
-* In some literature, the GSVD of A and B is presented in the form
-* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
-* where U and V are orthogonal and X is nonsingular, and D1 and D2 are
-* ``diagonal''. The former GSVD form can be converted to the latter
-* form by taking the nonsingular matrix X as
-*
-* X = Q*( I 0 )
-* ( 0 inv(R) )
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Unitary matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Unitary matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Unitary matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in Purpose.
-* K + L = effective numerical rank of (A',B')'.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular matrix R, or part of R.
-* See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains part of the triangular matrix R if
-* M-K-L < 0. See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* ALPHA (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = C,
-* BETA(K+1:K+L) = S,
-* or if M-K-L < 0,
-* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
-* BETA(K+1:M) = S, BETA(M+1:K+L) = 1
-* and
-* ALPHA(K+L+1:N) = 0
-* BETA(K+L+1:N) = 0
-*
-* U (output) COMPLEX*16 array, dimension (LDU,M)
-* If JOBU = 'U', U contains the M-by-M unitary matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) COMPLEX*16 array, dimension (LDV,P)
-* If JOBV = 'V', V contains the P-by-P unitary matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) COMPLEX*16 array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)+N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* IWORK (workspace/output) INTEGER array, dimension (N)
-* On exit, IWORK stores the sorting information. More
-* precisely, the following loop will sort ALPHA
-* for I = K+1, min(M,K+L)
-* swap ALPHA(I) and ALPHA(IWORK(I))
-* endfor
-* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = 1, the Jacobi-type procedure failed to
-* converge. For further details, see subroutine ZTGSJA.
-*
-* Internal Parameters
-* ===================
-*
-* TOLA DOUBLE PRECISION
-* TOLB DOUBLE PRECISION
-* TOLA and TOLB are the thresholds to determine the effective
-* rank of (A',B')'. Generally, they are set to
-* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
-* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-
-* Further Details
-* ===============
-*
-* 2-96 Based on modifications by
-* Ming Gu and Huan Ren, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL WANTQ, WANTU, WANTV
- INTEGER I, IBND, ISUB, J, NCYCLE
- DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- DOUBLE PRECISION DLAMCH, ZLANGE
- EXTERNAL LSAME, DLAMCH, ZLANGE
-* ..
-* .. External Subroutines ..
- EXTERNAL DCOPY, XERBLA, ZGGSVP, ZTGSJA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zggsvp"></A>
- <H2>zggsvp</H2>
-
- <PRE>
-USAGE:
- k, l, u, v, q, info, a, b = NumRu::Lapack.zggsvp( jobu, jobv, jobq, a, b, tola, tolb)
- or
- NumRu::Lapack.zggsvp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGGSVP computes unitary matrices U, V and Q such that
-*
-* N-K-L K L
-* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* V'*B*Q = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
-* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
-* conjugate transpose of Z.
-*
-* This decomposition is the preprocessing step for computing the
-* Generalized Singular Value Decomposition (GSVD), see subroutine
-* ZGGSVD.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': Unitary matrix U is computed;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': Unitary matrix V is computed;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Unitary matrix Q is computed;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A contains the triangular (or trapezoidal) matrix
-* described in the Purpose section.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, B contains the triangular matrix described in
-* the Purpose section.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) DOUBLE PRECISION
-* TOLB (input) DOUBLE PRECISION
-* TOLA and TOLB are the thresholds to determine the effective
-* numerical rank of matrix B and a subblock of A. Generally,
-* they are set to
-* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
-* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
-* The size of TOLA and TOLB may affect the size of backward
-* errors of the decomposition.
-*
-* K (output) INTEGER
-* L (output) INTEGER
-* On exit, K and L specify the dimension of the subblocks
-* described in Purpose section.
-* K + L = effective numerical rank of (A',B')'.
-*
-* U (output) COMPLEX*16 array, dimension (LDU,M)
-* If JOBU = 'U', U contains the unitary matrix U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (output) COMPLEX*16 array, dimension (LDV,P)
-* If JOBV = 'V', V contains the unitary matrix V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (output) COMPLEX*16 array, dimension (LDQ,N)
-* If JOBQ = 'Q', Q contains the unitary matrix Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* TAU (workspace) COMPLEX*16 array, dimension (N)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The subroutine uses LAPACK subroutine ZGEQPF for the QR factorization
-* with column pivoting to detect the effective numerical rank of the
-* a matrix. It may be replaced by a better rank determination strategy.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zgt.html b/doc/zgt.html
deleted file mode 100644
index 41d4d6a..0000000
--- a/doc/zgt.html
+++ /dev/null
@@ -1,731 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for general tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for general tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#zgtcon">zgtcon</A> : </LI>
- <LI><A HREF="#zgtrfs">zgtrfs</A> : </LI>
- <LI><A HREF="#zgtsv">zgtsv</A> : </LI>
- <LI><A HREF="#zgtsvx">zgtsvx</A> : </LI>
- <LI><A HREF="#zgttrf">zgttrf</A> : </LI>
- <LI><A HREF="#zgttrs">zgttrs</A> : </LI>
- <LI><A HREF="#zgtts2">zgtts2</A> : </LI>
- </UL>
-
- <A NAME="zgtcon"></A>
- <H2>zgtcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zgtcon( norm, dl, d, du, du2, ipiv, anorm)
- or
- NumRu::Lapack.zgtcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGTCON estimates the reciprocal of the condition number of a complex
-* tridiagonal matrix A using the LU factorization as computed by
-* ZGTTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* DL (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by ZGTTRF.
-*
-* D (input) COMPLEX*16 array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) COMPLEX*16 array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* ANORM (input) DOUBLE PRECISION
-* If NORM = '1' or 'O', the 1-norm of the original matrix A.
-* If NORM = 'I', the infinity-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgtrfs"></A>
- <H2>zgtrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)
- or
- NumRu::Lapack.zgtrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is tridiagonal, and provides
-* error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) COMPLEX*16 array, dimension (N)
-* The diagonal elements of A.
-*
-* DU (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A as computed by ZGTTRF.
-*
-* DF (input) COMPLEX*16 array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DUF (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input) COMPLEX*16 array, dimension (N-2)
-* The (n-2) elements of the second superdiagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZGTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgtsv"></A>
- <H2>zgtsv</H2>
-
- <PRE>
-USAGE:
- info, dl, d, du, b = NumRu::Lapack.zgtsv( dl, d, du, b)
- or
- NumRu::Lapack.zgtsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZGTSV solves the equation
-*
-* A*X = B,
-*
-* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
-* partial pivoting.
-*
-* Note that the equation A'*X = B may be solved by interchanging the
-* order of the arguments DU and DL.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input/output) COMPLEX*16 array, dimension (N-1)
-* On entry, DL must contain the (n-1) subdiagonal elements of
-* A.
-* On exit, DL is overwritten by the (n-2) elements of the
-* second superdiagonal of the upper triangular matrix U from
-* the LU factorization of A, in DL(1), ..., DL(n-2).
-*
-* D (input/output) COMPLEX*16 array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-* On exit, D is overwritten by the n diagonal elements of U.
-*
-* DU (input/output) COMPLEX*16 array, dimension (N-1)
-* On entry, DU must contain the (n-1) superdiagonal elements
-* of A.
-* On exit, DU is overwritten by the (n-1) elements of the first
-* superdiagonal of U.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
-* has not been computed. The factorization has not been
-* completed unless i = N.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgtsvx"></A>
- <H2>zgtsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.zgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)
- or
- NumRu::Lapack.zgtsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZGTSVX uses the LU factorization to compute the solution to a complex
-* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
-* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
-* as A = L * U, where L is a product of permutation and unit lower
-* bidiagonal matrices and U is upper triangular with nonzeros in
-* only the main diagonal and first two superdiagonals.
-*
-* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form
-* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not
-* be modified.
-* = 'N': The matrix will be copied to DLF, DF, and DUF
-* and factored.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) subdiagonal elements of A.
-*
-* D (input) COMPLEX*16 array, dimension (N)
-* The n diagonal elements of A.
-*
-* DU (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) superdiagonal elements of A.
-*
-* DLF (input or output) COMPLEX*16 array, dimension (N-1)
-* If FACT = 'F', then DLF is an input argument and on entry
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A as computed by ZGTTRF.
-*
-* If FACT = 'N', then DLF is an output argument and on exit
-* contains the (n-1) multipliers that define the matrix L from
-* the LU factorization of A.
-*
-* DF (input or output) COMPLEX*16 array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the upper triangular
-* matrix U from the LU factorization of A.
-*
-* DUF (input or output) COMPLEX*16 array, dimension (N-1)
-* If FACT = 'F', then DUF is an input argument and on entry
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* If FACT = 'N', then DUF is an output argument and on exit
-* contains the (n-1) elements of the first superdiagonal of U.
-*
-* DU2 (input or output) COMPLEX*16 array, dimension (N-2)
-* If FACT = 'F', then DU2 is an input argument and on entry
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* If FACT = 'N', then DU2 is an output argument and on exit
-* contains the (n-2) elements of the second superdiagonal of
-* U.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains the pivot indices from the LU factorization of A as
-* computed by ZGTTRF.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains the pivot indices from the LU factorization of A;
-* row i of the matrix was interchanged with row IPIV(i).
-* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
-* a row interchange was not required.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: U(i,i) is exactly zero. The factorization
-* has not been completed unless i = N, but the
-* factor U is exactly singular, so the solution
-* and error bounds could not be computed.
-* RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgttrf"></A>
- <H2>zgttrf</H2>
-
- <PRE>
-USAGE:
- du2, ipiv, info, dl, d, du = NumRu::Lapack.zgttrf( dl, d, du)
- or
- NumRu::Lapack.zgttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZGTTRF computes an LU factorization of a complex tridiagonal matrix A
-* using elimination with partial pivoting and row interchanges.
-*
-* The factorization has the form
-* A = L * U
-* where L is a product of permutation and unit lower bidiagonal
-* matrices and U is upper triangular with nonzeros in only the main
-* diagonal and first two superdiagonals.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* DL (input/output) COMPLEX*16 array, dimension (N-1)
-* On entry, DL must contain the (n-1) sub-diagonal elements of
-* A.
-*
-* On exit, DL is overwritten by the (n-1) multipliers that
-* define the matrix L from the LU factorization of A.
-*
-* D (input/output) COMPLEX*16 array, dimension (N)
-* On entry, D must contain the diagonal elements of A.
-*
-* On exit, D is overwritten by the n diagonal elements of the
-* upper triangular matrix U from the LU factorization of A.
-*
-* DU (input/output) COMPLEX*16 array, dimension (N-1)
-* On entry, DU must contain the (n-1) super-diagonal elements
-* of A.
-*
-* On exit, DU is overwritten by the (n-1) elements of the first
-* super-diagonal of U.
-*
-* DU2 (output) COMPLEX*16 array, dimension (N-2)
-* On exit, DU2 is overwritten by the (n-2) elements of the
-* second super-diagonal of U.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgttrs"></A>
- <H2>zgttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zgttrs( trans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.zgttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZGTTRS solves one of the systems of equations
-* A * X = B, A**T * X = B, or A**H * X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by ZGTTRF.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) COMPLEX*16 array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) COMPLEX*16 array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL NOTRAN
- INTEGER ITRANS, J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZGTTS2
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zgtts2"></A>
- <H2>zgtts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.zgtts2( itrans, dl, d, du, du2, ipiv, b)
- or
- NumRu::Lapack.zgtts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
-
-* Purpose
-* =======
-*
-* ZGTTS2 solves one of the systems of equations
-* A * X = B, A**T * X = B, or A**H * X = B,
-* with a tridiagonal matrix A using the LU factorization computed
-* by ZGTTRF.
-*
-
-* Arguments
-* =========
-*
-* ITRANS (input) INTEGER
-* Specifies the form of the system of equations.
-* = 0: A * X = B (No transpose)
-* = 1: A**T * X = B (Transpose)
-* = 2: A**H * X = B (Conjugate transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* DL (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) multipliers that define the matrix L from the
-* LU factorization of A.
-*
-* D (input) COMPLEX*16 array, dimension (N)
-* The n diagonal elements of the upper triangular matrix U from
-* the LU factorization of A.
-*
-* DU (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) elements of the first super-diagonal of U.
-*
-* DU2 (input) COMPLEX*16 array, dimension (N-2)
-* The (n-2) elements of the second super-diagonal of U.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= n, row i of the matrix was
-* interchanged with row IPIV(i). IPIV(i) will always be either
-* i or i+1; IPIV(i) = i indicates a row interchange was not
-* required.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the matrix of right hand side vectors B.
-* On exit, B is overwritten by the solution vectors X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, J
- COMPLEX*16 TEMP
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DCONJG
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zhb.html b/doc/zhb.html
deleted file mode 100644
index fb11cd1..0000000
--- a/doc/zhb.html
+++ /dev/null
@@ -1,1054 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) Hermitian band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) Hermitian band matrix</H1>
- <UL>
- <LI><A HREF="#zhbev">zhbev</A> : </LI>
- <LI><A HREF="#zhbevd">zhbevd</A> : </LI>
- <LI><A HREF="#zhbevx">zhbevx</A> : </LI>
- <LI><A HREF="#zhbgst">zhbgst</A> : </LI>
- <LI><A HREF="#zhbgv">zhbgv</A> : </LI>
- <LI><A HREF="#zhbgvd">zhbgvd</A> : </LI>
- <LI><A HREF="#zhbgvx">zhbgvx</A> : </LI>
- <LI><A HREF="#zhbtrd">zhbtrd</A> : </LI>
- </UL>
-
- <A NAME="zhbev"></A>
- <H2>zhbev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab = NumRu::Lapack.zhbev( jobz, uplo, kd, ab)
- or
- NumRu::Lapack.zhbev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHBEV computes all the eigenvalues and, optionally, eigenvectors of
-* a complex Hermitian band matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhbevd"></A>
- <H2>zhbevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, rwork, iwork, info, ab = NumRu::Lapack.zhbevd( jobz, uplo, kd, ab, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zhbevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of
-* a complex Hermitian band matrix A. If eigenvectors are desired, it
-* uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the first
-* superdiagonal and the diagonal of the tridiagonal matrix T
-* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
-* the diagonal and first subdiagonal of T are returned in the
-* first two rows of AB.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LRWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhbevx"></A>
- <H2>zhbevx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, ifail, info, ab = NumRu::Lapack.zhbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.zhbevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* ZHBEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors
-* can be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, AB is overwritten by values generated during the
-* reduction to tridiagonal form.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD + 1.
-*
-* Q (output) COMPLEX*16 array, dimension (LDQ, N)
-* If JOBZ = 'V', the N-by-N unitary matrix used in the
-* reduction to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'V', then
-* LDQ >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AB to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhbgst"></A>
- <H2>zhbgst</H2>
-
- <PRE>
-USAGE:
- x, info, ab = NumRu::Lapack.zhbgst( vect, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.zhbgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHBGST reduces a complex Hermitian-definite banded generalized
-* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
-* such that C has the same bandwidth as A.
-*
-* B must have been previously factorized as S**H*S by ZPBSTF, using a
-* split Cholesky factorization. A is overwritten by C = X**H*A*X, where
-* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the
-* bandwidth of A.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form the transformation matrix X;
-* = 'V': form X.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the transformed matrix X**H*A*X, stored in the same
-* format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input) COMPLEX*16 array, dimension (LDBB,N)
-* The banded factor S from the split Cholesky factorization of
-* B, as returned by ZPBSTF, stored in the first kb+1 rows of
-* the array.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* X (output) COMPLEX*16 array, dimension (LDX,N)
-* If VECT = 'V', the n-by-n matrix X.
-* If VECT = 'N', the array X is not referenced.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X.
-* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhbgv"></A>
- <H2>zhbgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ab, bb = NumRu::Lapack.zhbgv( jobz, uplo, ka, kb, ab, bb)
- or
- NumRu::Lapack.zhbgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHBGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
-* and banded, and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**H*S, as returned by ZPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**H*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER VECT
- INTEGER IINFO, INDE, INDWRK
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DSTERF, XERBLA, ZHBGST, ZHBTRD, ZPBSTF, ZSTEQR
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhbgvd"></A>
- <H2>zhbgvd</H2>
-
- <PRE>
-USAGE:
- w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.zhbgvd( jobz, uplo, ka, kb, ab, bb, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zhbgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
-* and banded, and B is also positive definite. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**H*S, as returned by ZPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**H*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= N.
-* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
-* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK >= 1.
-* If JOBZ = 'N' and N > 1, LRWORK >= N.
-* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: the algorithm failed to converge:
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhbgvx"></A>
- <H2>zhbgvx</H2>
-
- <PRE>
-USAGE:
- q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.zhbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.zhbgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite banded eigenproblem, of
-* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
-* and banded, and B is also positive definite. Eigenvalues and
-* eigenvectors can be selected by specifying either all eigenvalues,
-* a range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* KA (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
-*
-* KB (input) INTEGER
-* The number of superdiagonals of the matrix B if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first ka+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
-*
-* On exit, the contents of AB are destroyed.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KA+1.
-*
-* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix B, stored in the first kb+1 rows of the array. The
-* j-th column of B is stored in the j-th column of the array BB
-* as follows:
-* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
-* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
-*
-* On exit, the factor S from the split Cholesky factorization
-* B = S**H*S, as returned by ZPBSTF.
-*
-* LDBB (input) INTEGER
-* The leading dimension of the array BB. LDBB >= KB+1.
-*
-* Q (output) COMPLEX*16 array, dimension (LDQ, N)
-* If JOBZ = 'V', the n-by-n matrix used in the reduction of
-* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
-* and consequently C to tridiagonal form.
-* If JOBZ = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. If JOBZ = 'N',
-* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors, with the i-th column of Z holding the
-* eigenvector associated with W(i). The eigenvectors are
-* normalized so that Z**H*B*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= N.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is:
-* <= N: then i eigenvectors failed to converge. Their
-* indices are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF
-* returned INFO = i: B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhbtrd"></A>
- <H2>zhbtrd</H2>
-
- <PRE>
-USAGE:
- d, e, info, ab, q = NumRu::Lapack.zhbtrd( vect, uplo, kd, ab, q)
- or
- NumRu::Lapack.zhbtrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHBTRD reduces a complex Hermitian band matrix A to real symmetric
-* tridiagonal form T by a unitary similarity transformation:
-* Q**H * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'N': do not form Q;
-* = 'V': form Q;
-* = 'U': update a matrix X, by forming X*Q.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* On exit, the diagonal elements of AB are overwritten by the
-* diagonal elements of the tridiagonal matrix T; if KD > 0, the
-* elements on the first superdiagonal (if UPLO = 'U') or the
-* first subdiagonal (if UPLO = 'L') are overwritten by the
-* off-diagonal elements of T; the rest of AB is overwritten by
-* values generated during the reduction.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T.
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
-* On entry, if VECT = 'U', then Q must contain an N-by-N
-* matrix X; if VECT = 'N' or 'V', then Q need not be set.
-*
-* On exit:
-* if VECT = 'V', Q contains the N-by-N unitary matrix Q;
-* if VECT = 'U', Q contains the product X*Q;
-* if VECT = 'N', the array Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Modified by Linda Kaufman, Bell Labs.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zhe.html b/doc/zhe.html
deleted file mode 100644
index c90c2bf..0000000
--- a/doc/zhe.html
+++ /dev/null
@@ -1,3230 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) Hermitian matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) Hermitian matrix</H1>
- <UL>
- <LI><A HREF="#zhecon">zhecon</A> : </LI>
- <LI><A HREF="#zheequb">zheequb</A> : </LI>
- <LI><A HREF="#zheev">zheev</A> : </LI>
- <LI><A HREF="#zheevd">zheevd</A> : </LI>
- <LI><A HREF="#zheevr">zheevr</A> : </LI>
- <LI><A HREF="#zheevx">zheevx</A> : </LI>
- <LI><A HREF="#zhegs2">zhegs2</A> : </LI>
- <LI><A HREF="#zhegst">zhegst</A> : </LI>
- <LI><A HREF="#zhegv">zhegv</A> : </LI>
- <LI><A HREF="#zhegvd">zhegvd</A> : </LI>
- <LI><A HREF="#zhegvx">zhegvx</A> : </LI>
- <LI><A HREF="#zherfs">zherfs</A> : </LI>
- <LI><A HREF="#zherfsx">zherfsx</A> : </LI>
- <LI><A HREF="#zhesv">zhesv</A> : </LI>
- <LI><A HREF="#zhesvx">zhesvx</A> : </LI>
- <LI><A HREF="#zhesvxx">zhesvxx</A> : </LI>
- <LI><A HREF="#zhetd2">zhetd2</A> : </LI>
- <LI><A HREF="#zhetf2">zhetf2</A> : </LI>
- <LI><A HREF="#zhetrd">zhetrd</A> : </LI>
- <LI><A HREF="#zhetrf">zhetrf</A> : </LI>
- <LI><A HREF="#zhetri">zhetri</A> : </LI>
- <LI><A HREF="#zhetrs">zhetrs</A> : </LI>
- <LI><A HREF="#zhetrs2">zhetrs2</A> : </LI>
- </UL>
-
- <A NAME="zhecon"></A>
- <H2>zhecon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zhecon( uplo, a, ipiv, anorm)
- or
- NumRu::Lapack.zhecon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHECON estimates the reciprocal of the condition number of a complex
-* Hermitian matrix A using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by ZHETRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHETRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zheequb"></A>
- <H2>zheequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.zheequb( uplo, a)
- or
- NumRu::Lapack.zheequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYEQUB computes row and column scalings intended to equilibrate a
-* symmetric matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The N-by-N symmetric matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zheev"></A>
- <H2>zheev</H2>
-
- <PRE>
-USAGE:
- w, work, info, a = NumRu::Lapack.zheev( jobz, uplo, a, lwork)
- or
- NumRu::Lapack.zheev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHEEV computes all eigenvalues and, optionally, eigenvectors of a
-* complex Hermitian matrix A.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N-1).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the blocksize for ZHETRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zheevd"></A>
- <H2>zheevd</H2>
-
- <PRE>
-USAGE:
- w, work, rwork, iwork, info, a = NumRu::Lapack.zheevd( jobz, uplo, a, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zheevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a
-* complex Hermitian matrix A. If eigenvectors are desired, it uses a
-* divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* orthonormal eigenvectors of the matrix A.
-* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
-* or the upper triangle (if UPLO='U') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.
-* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-* If N <= 1, LRWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LRWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
-* to converge; i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* if INFO = i and JOBZ = 'V', then the algorithm failed
-* to compute an eigenvalue while working on the submatrix
-* lying in rows and columns INFO/(N+1) through
-* mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-*
-* Modified description of INFO. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zheevr"></A>
- <H2>zheevr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.zheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zheevr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHEEVR computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
-* be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-* ZHEEVR first reduces the matrix A to tridiagonal form T with a call
-* to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute
-* eigenspectrum using Relatively Robust Representations. ZSTEMR
-* computes eigenvalues by the dqds algorithm, while orthogonal
-* eigenvectors are computed from various "good" L D L^T representations
-* (also known as Relatively Robust Representations). Gram-Schmidt
-* orthogonalization is avoided as far as possible. More specifically,
-* the various steps of the algorithm are as follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* The desired accuracy of the output can be specified by the input
-* parameter ABSTOL.
-*
-* For more details, see DSTEMR's documentation and:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-*
-* Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested
-* on machines which conform to the ieee-754 floating point standard.
-* ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and
-* when partial spectrum requests are made.
-*
-* Normal execution of ZSTEMR may create NaNs and infinities and
-* hence may abort due to a floating point exception in environments
-* which do not handle NaNs and infinities in the ieee standard default
-* manner.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
-********** ZSTEIN are called
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* If high relative accuracy is important, set ABSTOL to
-* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
-* eigenvalues are computed to high relative accuracy when
-* possible in future releases. The current code does not
-* make any guarantees about high relative accuracy, but
-* furutre releases will. See J. Barlow and J. Demmel,
-* "Computing Accurate Eigensystems of Scaled Diagonally
-* Dominant Matrices", LAPACK Working Note #7, for a discussion
-* of which matrices define their eigenvalues to high relative
-* accuracy.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ).
-********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the max of the blocksize for ZHETRD and for
-* ZUNMTR as returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the optimal
-* (and minimal) LRWORK.
-*
-* LRWORK (input) INTEGER
-* The length of the array RWORK. LRWORK >= max(1,24*N).
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal
-* (and minimal) LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N).
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: Internal error
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Ken Stanley, Computer Science Division, University of
-* California at Berkeley, USA
-* Jason Riedy, Computer Science Division, University of
-* California at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zheevx"></A>
- <H2>zheevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a = NumRu::Lapack.zheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)
- or
- NumRu::Lapack.zheevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* ZHEEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can
-* be selected by specifying either a range of values or a range of
-* indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= 1, when N <= 1;
-* otherwise 2*N.
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the max of the blocksize for ZHETRD and for
-* ZUNMTR as returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhegs2"></A>
- <H2>zhegs2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zhegs2( itype, uplo, a, b)
- or
- NumRu::Lapack.zhegs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZHEGS2 reduces a complex Hermitian-definite generalized
-* eigenproblem to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
-*
-* B must have been previously factorized as U'*U or L*L' by ZPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
-* = 2 or 3: compute U*A*U' or L'*A*L.
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored, and how B has been factorized.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by ZPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhegst"></A>
- <H2>zhegst</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zhegst( itype, uplo, a, b)
- or
- NumRu::Lapack.zhegst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZHEGST reduces a complex Hermitian-definite generalized
-* eigenproblem to standard form.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
-*
-* B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
-* = 2 or 3: compute U*A*U**H or L**H*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**H*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**H.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,N)
-* The triangular factor from the Cholesky factorization of B,
-* as returned by ZPOTRF.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhegv"></A>
- <H2>zhegv</H2>
-
- <PRE>
-USAGE:
- w, work, info, a, b = NumRu::Lapack.zhegv( itype, jobz, uplo, a, b, lwork)
- or
- NumRu::Lapack.zhegv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHEGV computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be Hermitian and B is also
-* positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the Hermitian positive definite matrix B.
-* If UPLO = 'U', the leading N-by-N upper triangular part of B
-* contains the upper triangular part of the matrix B.
-* If UPLO = 'L', the leading N-by-N lower triangular part of B
-* contains the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N-1).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the blocksize for ZHETRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: ZPOTRF or ZHEEV returned an error code:
-* <= N: if INFO = i, ZHEEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not converge to zero;
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhegvd"></A>
- <H2>zhegvd</H2>
-
- <PRE>
-USAGE:
- w, work, rwork, iwork, info, a, b = NumRu::Lapack.zhegvd( itype, jobz, uplo, a, b, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zhegvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian and B is also positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
-* matrix Z of eigenvectors. The eigenvectors are normalized
-* as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
-* or the lower triangle (if UPLO='L') of A, including the
-* diagonal, is destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the Hermitian matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= N + 1.
-* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-* If N <= 1, LRWORK >= 1.
-* If JOBZ = 'N' and N > 1, LRWORK >= N.
-* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If N <= 1, LIWORK >= 1.
-* If JOBZ = 'N' and N > 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: ZPOTRF or ZHEEVD returned an error code:
-* <= N: if INFO = i and JOBZ = 'N', then the algorithm
-* failed to converge; i off-diagonal elements of an
-* intermediate tridiagonal form did not converge to
-* zero;
-* if INFO = i and JOBZ = 'V', then the algorithm
-* failed to compute an eigenvalue while working on
-* the submatrix lying in rows and columns INFO/(N+1)
-* through mod(INFO,N+1);
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* Modified so that no backsubstitution is performed if ZHEEVD fails to
-* converge (NEIG in old code could be greater than N causing out of
-* bounds reference to A - reported by Ralf Meyer). Also corrected the
-* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhegvx"></A>
- <H2>zhegvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, work, ifail, info, a, b = NumRu::Lapack.zhegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, ldz, lwork)
- or
- NumRu::Lapack.zhegvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* ZHEGVX computes selected eigenvalues, and optionally, eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian and B is also positive definite.
-* Eigenvalues and eigenvectors can be selected by specifying either a
-* range of values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-**
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA, N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of A contains the
-* upper triangular part of the matrix A. If UPLO = 'L',
-* the leading N-by-N lower triangular part of A contains
-* the lower triangular part of the matrix A.
-*
-* On exit, the lower triangle (if UPLO='L') or the upper
-* triangle (if UPLO='U') of A, including the diagonal, is
-* destroyed.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB, N)
-* On entry, the Hermitian matrix B. If UPLO = 'U', the
-* leading N-by-N upper triangular part of B contains the
-* upper triangular part of the matrix B. If UPLO = 'L',
-* the leading N-by-N lower triangular part of B contains
-* the lower triangular part of the matrix B.
-*
-* On exit, if INFO <= N, the part of B containing the matrix is
-* overwritten by the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing A to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**T*B*Z = I;
-* if ITYPE = 3, Z**T*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of the array WORK. LWORK >= max(1,2*N).
-* For optimal efficiency, LWORK >= (NB+1)*N,
-* where NB is the blocksize for ZHETRD returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: ZPOTRF or ZHEEVX returned an error code:
-* <= N: if INFO = i, ZHEEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= N, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zherfs"></A>
- <H2>zherfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zherfs( uplo, a, af, ipiv, b, x)
- or
- NumRu::Lapack.zherfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHERFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian indefinite, and
-* provides error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**H or
-* A = L*D*L**H as computed by ZHETRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHETRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZHETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zherfsx"></A>
- <H2>zherfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zherfsx( uplo, equed, a, af, ipiv, s, b, x, params)
- or
- NumRu::Lapack.zherfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHERFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian indefinite, and
-* provides error bounds and backward error estimates for the
-* solution. In addition to normwise error bound, the code provides
-* maximum componentwise error bound if possible. See comments for
-* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or A =
-* L*D*L**T as computed by DSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhesv"></A>
- <H2>zhesv</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a, b = NumRu::Lapack.zhesv( uplo, a, b, lwork)
- or
- NumRu::Lapack.zhesv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHESV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
-* matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
-* used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the block diagonal matrix D and the
-* multipliers used to obtain the factor U or L from the
-* factorization A = U*D*U**H or A = L*D*L**H as computed by
-* ZHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by ZHETRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= 1, and for best performance
-* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
-* ZHETRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LWKOPT, NB
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZHETRF, ZHETRS2
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhesvx"></A>
- <H2>zhesvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zhesvx( fact, uplo, a, af, ipiv, b, lwork)
- or
- NumRu::Lapack.zhesvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHESVX uses the diagonal pivoting factorization to compute the
-* solution to a complex system of linear equations A * X = B,
-* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
-* The form of the factorization is
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AF and IPIV contain the factored form
-* of A. A, AF and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by ZHETRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by ZHETRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by ZHETRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= max(1,2*N), and for best
-* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
-* NB is the optimal blocksize for ZHETRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhesvxx"></A>
- <H2>zhesvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zhesvxx( fact, uplo, a, af, ipiv, equed, s, b, params)
- or
- NumRu::Lapack.zhesvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHESVXX uses the diagonal pivoting factorization to compute the
-* solution to a complex*16 system of linear equations A * X = B, where
-* A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. ZHESVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* ZHESVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* ZHESVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what ZHESVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 3. If some D(i,i)=0, so that D is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is
-* less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(R) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T as computed by DSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block
-* structure of D, as determined by ZHETRF. If IPIV(k) > 0,
-* then rows and columns k and IPIV(k) were interchanged and
-* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and
-* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and
-* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2
-* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,
-* then rows and columns k+1 and -IPIV(k) were interchanged
-* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block
-* structure of D, as determined by ZHETRF.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhetd2"></A>
- <H2>zhetd2</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, a = NumRu::Lapack.zhetd2( uplo, a)
- or
- NumRu::Lapack.zhetd2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* ZHETD2 reduces a complex Hermitian matrix A to real symmetric
-* tridiagonal form T by a unitary similarity transformation:
-* Q' * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the unitary
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the unitary matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) COMPLEX*16 array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhetf2"></A>
- <H2>zhetf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.zhetf2( uplo, a)
- or
- NumRu::Lapack.zhetf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZHETF2 computes the factorization of a complex Hermitian matrix A
-* using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U' or A = L*D*L'
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, U' is the conjugate transpose of U, and D is
-* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 09-29-06 - patch from
-* Bobby Cheng, MathWorks
-*
-* Replace l.210 and l.393
-* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
-* by
-* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
-*
-* 01-01-96 - Based on modifications by
-* J. Lewis, Boeing Computer Services Company
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhetrd"></A>
- <H2>zhetrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, work, info, a = NumRu::Lapack.zhetrd( uplo, a, lwork)
- or
- NumRu::Lapack.zhetrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHETRD reduces a complex Hermitian matrix A to real symmetric
-* tridiagonal form T by a unitary similarity transformation:
-* Q**H * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the unitary
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the unitary matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) COMPLEX*16 array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1.
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
-* A(1:i-1,i+1), and tau in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
-* and tau in TAU(i).
-*
-* The contents of A on exit are illustrated by the following examples
-* with n = 5:
-*
-* if UPLO = 'U': if UPLO = 'L':
-*
-* ( d e v2 v3 v4 ) ( d )
-* ( d e v3 v4 ) ( e d )
-* ( d e v4 ) ( v1 e d )
-* ( d e ) ( v1 v2 e d )
-* ( d ) ( v1 v2 v3 e d )
-*
-* where d and e denote diagonal and off-diagonal elements of T, and vi
-* denotes an element of the vector defining H(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhetrf"></A>
- <H2>zhetrf</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a = NumRu::Lapack.zhetrf( uplo, a, lwork)
- or
- NumRu::Lapack.zhetrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHETRF computes the factorization of a complex Hermitian matrix A
-* using the Bunch-Kaufman diagonal pivoting method. The form of the
-* factorization is
-*
-* A = U*D*U**H or A = L*D*L**H
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1. For best performance
-* LWORK >= N*NB, where NB is the block size returned by ILAENV.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER
- INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZHETF2, ZLAHEF
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhetri"></A>
- <H2>zhetri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zhetri( uplo, a, ipiv)
- or
- NumRu::Lapack.zhetri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHETRI computes the inverse of a complex Hermitian indefinite matrix
-* A using the factorization A = U*D*U**H or A = L*D*L**H computed by
-* ZHETRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by ZHETRF.
-*
-* On exit, if INFO = 0, the (Hermitian) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHETRF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhetrs"></A>
- <H2>zhetrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zhetrs( uplo, a, ipiv, b)
- or
- NumRu::Lapack.zhetrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZHETRS solves a system of linear equations A*X = B with a complex
-* Hermitian matrix A using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by ZHETRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHETRF.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhetrs2"></A>
- <H2>zhetrs2</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zhetrs2( uplo, a, ipiv, b)
- or
- NumRu::Lapack.zhetrs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHETRS2 solves a system of linear equations A*X = B with a real
-* Hermitian matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) DOUBLE COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZHETRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHETRF.
-*
-* B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zhg.html b/doc/zhg.html
deleted file mode 100644
index 48dd90d..0000000
--- a/doc/zhg.html
+++ /dev/null
@@ -1,203 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix) matrix</H1>
- <UL>
- <LI><A HREF="#zhgeqz">zhgeqz</A> : </LI>
- </UL>
-
- <A NAME="zhgeqz"></A>
- <H2>zhgeqz</H2>
-
- <PRE>
-USAGE:
- alpha, beta, work, info, h, t, q, z = NumRu::Lapack.zhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)
- or
- NumRu::Lapack.zhgeqz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),
-* where H is an upper Hessenberg matrix and T is upper triangular,
-* using the single-shift QZ method.
-* Matrix pairs of this type are produced by the reduction to
-* generalized upper Hessenberg form of a complex matrix pair (A,B):
-*
-* A = Q1*H*Z1**H, B = Q1*T*Z1**H,
-*
-* as computed by ZGGHRD.
-*
-* If JOB='S', then the Hessenberg-triangular pair (H,T) is
-* also reduced to generalized Schur form,
-*
-* H = Q*S*Z**H, T = Q*P*Z**H,
-*
-* where Q and Z are unitary matrices and S and P are upper triangular.
-*
-* Optionally, the unitary matrix Q from the generalized Schur
-* factorization may be postmultiplied into an input matrix Q1, and the
-* unitary matrix Z may be postmultiplied into an input matrix Z1.
-* If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced
-* the matrix pair (A,B) to generalized Hessenberg form, then the output
-* matrices Q1*Q and Z1*Z are the unitary factors from the generalized
-* Schur factorization of (A,B):
-*
-* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.
-*
-* To avoid overflow, eigenvalues of the matrix pair (H,T)
-* (equivalently, of (A,B)) are computed as a pair of complex values
-* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an
-* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)
-* A*x = lambda*B*x
-* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
-* alternate form of the GNEP
-* mu*A*y = B*y.
-* The values of alpha and beta for the i-th eigenvalue can be read
-* directly from the generalized Schur form: alpha = S(i,i),
-* beta = P(i,i).
-*
-* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
-* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
-* pp. 241--256.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': Compute eigenvalues only;
-* = 'S': Computer eigenvalues and the Schur form.
-*
-* COMPQ (input) CHARACTER*1
-* = 'N': Left Schur vectors (Q) are not computed;
-* = 'I': Q is initialized to the unit matrix and the matrix Q
-* of left Schur vectors of (H,T) is returned;
-* = 'V': Q must contain a unitary matrix Q1 on entry and
-* the product Q1*Q is returned.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Right Schur vectors (Z) are not computed;
-* = 'I': Q is initialized to the unit matrix and the matrix Z
-* of right Schur vectors of (H,T) is returned;
-* = 'V': Z must contain a unitary matrix Z1 on entry and
-* the product Z1*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrices H, T, Q, and Z. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI mark the rows and columns of H which are in
-* Hessenberg form. It is assumed that A is already upper
-* triangular in rows and columns 1:ILO-1 and IHI+1:N.
-* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
-*
-* H (input/output) COMPLEX*16 array, dimension (LDH, N)
-* On entry, the N-by-N upper Hessenberg matrix H.
-* On exit, if JOB = 'S', H contains the upper triangular
-* matrix S from the generalized Schur factorization.
-* If JOB = 'E', the diagonal of H matches that of S, but
-* the rest of H is unspecified.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max( 1, N ).
-*
-* T (input/output) COMPLEX*16 array, dimension (LDT, N)
-* On entry, the N-by-N upper triangular matrix T.
-* On exit, if JOB = 'S', T contains the upper triangular
-* matrix P from the generalized Schur factorization.
-* If JOB = 'E', the diagonal of T matches that of P, but
-* the rest of T is unspecified.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max( 1, N ).
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* The complex scalars alpha that define the eigenvalues of
-* GNEP. ALPHA(i) = S(i,i) in the generalized Schur
-* factorization.
-*
-* BETA (output) COMPLEX*16 array, dimension (N)
-* The real non-negative scalars beta that define the
-* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized
-* Schur factorization.
-*
-* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)
-* represent the j-th eigenvalue of the matrix pair (A,B), in
-* one of the forms lambda = alpha/beta or mu = beta/alpha.
-* Since either lambda or mu may overflow, they should not,
-* in general, be computed.
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDQ, N)
-* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the
-* reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the unitary matrix of left Schur
-* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
-* left Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If COMPQ='V' or 'I', then LDQ >= N.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the
-* reduction of (A,B) to generalized Hessenberg form.
-* On exit, if COMPZ = 'I', the unitary matrix of right Schur
-* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of
-* right Schur vectors of (A,B).
-* Not referenced if COMPZ = 'N'.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If COMPZ='V' or 'I', then LDZ >= N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1,...,N: the QZ iteration did not converge. (H,T) is not
-* in Schur form, but ALPHA(i) and BETA(i),
-* i=INFO+1,...,N should be correct.
-* = N+1,...,2*N: the shift calculation failed. (H,T) is not
-* in Schur form, but ALPHA(i) and BETA(i),
-* i=INFO-N+1,...,N should be correct.
-*
-
-* Further Details
-* ===============
-*
-* We assume that complex ABS works as long as its value is less than
-* overflow.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zhp.html b/doc/zhp.html
deleted file mode 100644
index c0a70db..0000000
--- a/doc/zhp.html
+++ /dev/null
@@ -1,1741 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) Hermitian, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) Hermitian, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#zhpcon">zhpcon</A> : </LI>
- <LI><A HREF="#zhpev">zhpev</A> : </LI>
- <LI><A HREF="#zhpevd">zhpevd</A> : </LI>
- <LI><A HREF="#zhpevx">zhpevx</A> : </LI>
- <LI><A HREF="#zhpgst">zhpgst</A> : </LI>
- <LI><A HREF="#zhpgv">zhpgv</A> : </LI>
- <LI><A HREF="#zhpgvd">zhpgvd</A> : </LI>
- <LI><A HREF="#zhpgvx">zhpgvx</A> : </LI>
- <LI><A HREF="#zhprfs">zhprfs</A> : </LI>
- <LI><A HREF="#zhpsv">zhpsv</A> : </LI>
- <LI><A HREF="#zhpsvx">zhpsvx</A> : </LI>
- <LI><A HREF="#zhptrd">zhptrd</A> : </LI>
- <LI><A HREF="#zhptrf">zhptrf</A> : </LI>
- <LI><A HREF="#zhptri">zhptri</A> : </LI>
- <LI><A HREF="#zhptrs">zhptrs</A> : </LI>
- </UL>
-
- <A NAME="zhpcon"></A>
- <H2>zhpcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zhpcon( uplo, ap, ipiv, anorm)
- or
- NumRu::Lapack.zhpcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPCON estimates the reciprocal of the condition number of a complex
-* Hermitian packed matrix A using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by ZHPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZHPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHPTRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpev"></A>
- <H2>zhpev</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap = NumRu::Lapack.zhpev( jobz, uplo, ap)
- or
- NumRu::Lapack.zhpev # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a
-* complex Hermitian matrix in packed storage.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpevd"></A>
- <H2>zhpevd</H2>
-
- <PRE>
-USAGE:
- w, z, work, rwork, iwork, info, ap = NumRu::Lapack.zhpevd( jobz, uplo, ap, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zhpevd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of
-* a complex Hermitian matrix A in packed storage. If eigenvectors are
-* desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
-* eigenvectors of the matrix A, with the i-th column of Z
-* holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of array WORK.
-* If N <= 1, LWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK must be at least 1.
-* If JOBZ = 'N' and N > 1, LRWORK must be at least N.
-* If JOBZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the algorithm failed to converge; i
-* off-diagonal elements of an intermediate tridiagonal
-* form did not converge to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpevx"></A>
- <H2>zhpevx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap = NumRu::Lapack.zhpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)
- or
- NumRu::Lapack.zhpevx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex Hermitian matrix A in packed storage.
-* Eigenvalues/vectors can be selected by specifying either a range of
-* values or a range of indices for the desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, AP is overwritten by values generated during the
-* reduction to tridiagonal form. If UPLO = 'U', the diagonal
-* and first superdiagonal of the tridiagonal matrix T overwrite
-* the corresponding elements of A, and if UPLO = 'L', the
-* diagonal and first subdiagonal of T overwrite the
-* corresponding elements of A.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* See "Computing Small Singular Values of Bidiagonal Matrices
-* with Guaranteed High Relative Accuracy," by Demmel and
-* Kahan, LAPACK Working Note #3.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the selected eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and
-* the index of the eigenvector is returned in IFAIL.
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge.
-* Their indices are stored in array IFAIL.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpgst"></A>
- <H2>zhpgst</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.zhpgst( itype, uplo, n, ap, bp)
- or
- NumRu::Lapack.zhpgst # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )
-
-* Purpose
-* =======
-*
-* ZHPGST reduces a complex Hermitian-definite generalized
-* eigenproblem to standard form, using packed storage.
-*
-* If ITYPE = 1, the problem is A*x = lambda*B*x,
-* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
-*
-* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
-* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
-*
-* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
-* = 2 or 3: compute U*A*U**H or L**H*A*L.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored and B is factored as
-* U**H*U;
-* = 'L': Lower triangle of A is stored and B is factored as
-* L*L**H.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, if INFO = 0, the transformed matrix, stored in the
-* same format as A.
-*
-* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The triangular factor from the Cholesky factorization of B,
-* stored in the same format as A, as returned by ZPPTRF.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpgv"></A>
- <H2>zhpgv</H2>
-
- <PRE>
-USAGE:
- w, z, info, ap, bp = NumRu::Lapack.zhpgv( itype, jobz, uplo, ap, bp)
- or
- NumRu::Lapack.zhpgv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPGV computes all the eigenvalues and, optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
-* Here A and B are assumed to be Hermitian, stored in packed format,
-* and B is also positive definite.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H, in the same storage
-* format as B.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: ZPPTRF or ZHPEV returned an error code:
-* <= N: if INFO = i, ZHPEV failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not convergeto zero;
-* > N: if INFO = N + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, WANTZ
- CHARACTER TRANS
- INTEGER J, NEIG
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZHPEV, ZHPGST, ZPPTRF, ZTPMV, ZTPSV
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpgvd"></A>
- <H2>zhpgvd</H2>
-
- <PRE>
-USAGE:
- w, z, iwork, info, ap, bp = NumRu::Lapack.zhpgvd( itype, jobz, uplo, ap, bp, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zhpgvd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian, stored in packed format, and B is also
-* positive definite.
-* If eigenvectors are desired, it uses a divide and conquer algorithm.
-*
-* The divide and conquer algorithm makes very mild assumptions about
-* floating point arithmetic. It will work on machines with a guard
-* digit in add/subtract, or on those binary machines without guard
-* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
-* Cray-2. It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H, in the same storage
-* format as B.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, the eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
-* eigenvectors. The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-* If JOBZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the required LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of array WORK.
-* If N <= 1, LWORK >= 1.
-* If JOBZ = 'N' and N > 1, LWORK >= N.
-* If JOBZ = 'V' and N > 1, LWORK >= 2*N.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the required sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
-* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of array RWORK.
-* If N <= 1, LRWORK >= 1.
-* If JOBZ = 'N' and N > 1, LRWORK >= N.
-* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of array IWORK.
-* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
-* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the required sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: ZPPTRF or ZHPEVD returned an error code:
-* <= N: if INFO = i, ZHPEVD failed to converge;
-* i off-diagonal elements of an intermediate
-* tridiagonal form did not convergeto zero;
-* > N: if INFO = N + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER, WANTZ
- CHARACTER TRANS
- INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZHPEVD, ZHPGST, ZPPTRF, ZTPMV, ZTPSV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DBLE, MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpgvx"></A>
- <H2>zhpgvx</H2>
-
- <PRE>
-USAGE:
- m, w, z, ifail, info, ap, bp = NumRu::Lapack.zhpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)
- or
- NumRu::Lapack.zhpgvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* ZHPGVX computes selected eigenvalues and, optionally, eigenvectors
-* of a complex generalized Hermitian-definite eigenproblem, of the form
-* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
-* B are assumed to be Hermitian, stored in packed format, and B is also
-* positive definite. Eigenvalues and eigenvectors can be selected by
-* specifying either a range of values or a range of indices for the
-* desired eigenvalues.
-*
-
-* Arguments
-* =========
-*
-* ITYPE (input) INTEGER
-* Specifies the problem type to be solved:
-* = 1: A*x = (lambda)*B*x
-* = 2: A*B*x = (lambda)*x
-* = 3: B*A*x = (lambda)*x
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found;
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found;
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangles of A and B are stored;
-* = 'L': Lower triangles of A and B are stored.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the contents of AP are destroyed.
-*
-* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* B, packed columnwise in a linear array. The j-th column of B
-* is stored in the array BP as follows:
-* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
-* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
-*
-* On exit, the triangular factor U or L from the Cholesky
-* factorization B = U**H*U or B = L*L**H, in the same storage
-* format as B.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* The absolute error tolerance for the eigenvalues.
-* An approximate eigenvalue is accepted as converged
-* when it is determined to lie in an interval [a,b]
-* of width less than or equal to
-*
-* ABSTOL + EPS * max( |a|,|b| ) ,
-*
-* where EPS is the machine precision. If ABSTOL is less than
-* or equal to zero, then EPS*|T| will be used in its place,
-* where |T| is the 1-norm of the tridiagonal matrix obtained
-* by reducing AP to tridiagonal form.
-*
-* Eigenvalues will be computed most accurately when ABSTOL is
-* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
-* If this routine returns with INFO>0, indicating that some
-* eigenvectors did not converge, try setting ABSTOL to
-* 2*DLAMCH('S').
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* On normal exit, the first M elements contain the selected
-* eigenvalues in ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, N)
-* If JOBZ = 'N', then Z is not referenced.
-* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix A
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* The eigenvectors are normalized as follows:
-* if ITYPE = 1 or 2, Z**H*B*Z = I;
-* if ITYPE = 3, Z**H*inv(B)*Z = I.
-*
-* If an eigenvector fails to converge, then that column of Z
-* contains the latest approximation to the eigenvector, and the
-* index of the eigenvector is returned in IFAIL.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', LDZ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)
-*
-* IWORK (workspace) INTEGER array, dimension (5*N)
-*
-* IFAIL (output) INTEGER array, dimension (N)
-* If JOBZ = 'V', then if INFO = 0, the first M elements of
-* IFAIL are zero. If INFO > 0, then IFAIL contains the
-* indices of the eigenvectors that failed to converge.
-* If JOBZ = 'N', then IFAIL is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: ZPPTRF or ZHPEVX returned an error code:
-* <= N: if INFO = i, ZHPEVX failed to converge;
-* i eigenvectors failed to converge. Their indices
-* are stored in array IFAIL.
-* > N: if INFO = N + i, for 1 <= i <= n, then the leading
-* minor of order i of B is not positive definite.
-* The factorization of B could not be completed and
-* no eigenvalues or eigenvectors were computed.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
- CHARACTER TRANS
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZHPEVX, ZHPGST, ZPPTRF, ZTPMV, ZTPSV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhprfs"></A>
- <H2>zhprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zhprfs( uplo, ap, afp, ipiv, b, x)
- or
- NumRu::Lapack.zhprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian indefinite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The factored form of the matrix A. AFP contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**H or
-* A = L*D*L**H as computed by ZHPTRF, stored as a packed
-* triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHPTRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZHPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpsv"></A>
- <H2>zhpsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap, b = NumRu::Lapack.zhpsv( uplo, ap, b)
- or
- NumRu::Lapack.zhpsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZHPSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian matrix stored in packed format and X
-* and B are N-by-NRHS matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, D is Hermitian and block diagonal with 1-by-1
-* and 2-by-2 diagonal blocks. The factored form of A is then used to
-* solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by ZHPTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be
-* computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZHPTRF, ZHPTRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhpsvx"></A>
- <H2>zhpsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zhpsvx( fact, uplo, ap, afp, ipiv, b)
- or
- NumRu::Lapack.zhpsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or
-* A = L*D*L**H to compute the solution to a complex system of linear
-* equations A * X = B, where A is an N-by-N Hermitian matrix stored
-* in packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
-* A = U * D * U**H, if UPLO = 'U', or
-* A = L * D * L**H, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AFP and IPIV contain the factored form of
-* A. AFP and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by ZHPTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by ZHPTRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhptrd"></A>
- <H2>zhptrd</H2>
-
- <PRE>
-USAGE:
- d, e, tau, info, ap = NumRu::Lapack.zhptrd( uplo, ap)
- or
- NumRu::Lapack.zhptrd # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )
-
-* Purpose
-* =======
-*
-* ZHPTRD reduces a complex Hermitian matrix A stored in packed form to
-* real symmetric tridiagonal form T by a unitary similarity
-* transformation: Q**H * A * Q = T.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* On exit, if UPLO = 'U', the diagonal and first superdiagonal
-* of A are overwritten by the corresponding elements of the
-* tridiagonal matrix T, and the elements above the first
-* superdiagonal, with the array TAU, represent the unitary
-* matrix Q as a product of elementary reflectors; if UPLO
-* = 'L', the diagonal and first subdiagonal of A are over-
-* written by the corresponding elements of the tridiagonal
-* matrix T, and the elements below the first subdiagonal, with
-* the array TAU, represent the unitary matrix Q as a product
-* of elementary reflectors. See Further Details.
-*
-* D (output) DOUBLE PRECISION array, dimension (N)
-* The diagonal elements of the tridiagonal matrix T:
-* D(i) = A(i,i).
-*
-* E (output) DOUBLE PRECISION array, dimension (N-1)
-* The off-diagonal elements of the tridiagonal matrix T:
-* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
-*
-* TAU (output) COMPLEX*16 array, dimension (N-1)
-* The scalar factors of the elementary reflectors (see Further
-* Details).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(n-1) . . . H(2) H(1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
-* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
-*
-* If UPLO = 'L', the matrix Q is represented as a product of elementary
-* reflectors
-*
-* Q = H(1) H(2) . . . H(n-1).
-*
-* Each H(i) has the form
-*
-* H(i) = I - tau * v * v'
-*
-* where tau is a complex scalar, and v is a complex vector with
-* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
-* overwriting A(i+2:n,i), and tau is stored in TAU(i).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhptrf"></A>
- <H2>zhptrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap = NumRu::Lapack.zhptrf( uplo, ap)
- or
- NumRu::Lapack.zhptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZHPTRF computes the factorization of a complex Hermitian packed
-* matrix A using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U**H or A = L*D*L**H
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is Hermitian and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L, stored as a packed triangular
-* matrix overwriting A (see below for further details).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhptri"></A>
- <H2>zhptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.zhptri( uplo, ap, ipiv)
- or
- NumRu::Lapack.zhptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHPTRI computes the inverse of a complex Hermitian indefinite matrix
-* A in packed storage using the factorization A = U*D*U**H or
-* A = L*D*L**H computed by ZHPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by ZHPTRF,
-* stored as a packed triangular matrix.
-*
-* On exit, if INFO = 0, the (Hermitian) inverse of the original
-* matrix, stored as a packed triangular matrix. The j-th column
-* of inv(A) is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
-* if UPLO = 'L',
-* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHPTRF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhptrs"></A>
- <H2>zhptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zhptrs( uplo, ap, ipiv, b)
- or
- NumRu::Lapack.zhptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZHPTRS solves a system of linear equations A*X = B with a complex
-* Hermitian matrix A stored in packed format using the factorization
-* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**H;
-* = 'L': Lower triangular, form is A = L*D*L**H.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZHPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZHPTRF.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zhs.html b/doc/zhs.html
deleted file mode 100644
index 090941d..0000000
--- a/doc/zhs.html
+++ /dev/null
@@ -1,391 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for upper Hessenberg matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for upper Hessenberg matrix</H1>
- <UL>
- <LI><A HREF="#zhsein">zhsein</A> : </LI>
- <LI><A HREF="#zhseqr">zhseqr</A> : </LI>
- </UL>
-
- <A NAME="zhsein"></A>
- <H2>zhsein</H2>
-
- <PRE>
-USAGE:
- m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.zhsein( side, eigsrc, initv, select, h, w, vl, vr)
- or
- NumRu::Lapack.zhsein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )
-
-* Purpose
-* =======
-*
-* ZHSEIN uses inverse iteration to find specified right and/or left
-* eigenvectors of a complex upper Hessenberg matrix H.
-*
-* The right eigenvector x and the left eigenvector y of the matrix H
-* corresponding to an eigenvalue w are defined by:
-*
-* H * x = w * x, y**h * H = w * y**h
-*
-* where y**h denotes the conjugate transpose of the vector y.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* EIGSRC (input) CHARACTER*1
-* Specifies the source of eigenvalues supplied in W:
-* = 'Q': the eigenvalues were found using ZHSEQR; thus, if
-* H has zero subdiagonal elements, and so is
-* block-triangular, then the j-th eigenvalue can be
-* assumed to be an eigenvalue of the block containing
-* the j-th row/column. This property allows ZHSEIN to
-* perform inverse iteration on just one diagonal block.
-* = 'N': no assumptions are made on the correspondence
-* between eigenvalues and diagonal blocks. In this
-* case, ZHSEIN must always perform inverse iteration
-* using the whole matrix H.
-*
-* INITV (input) CHARACTER*1
-* = 'N': no initial vectors are supplied;
-* = 'U': user-supplied initial vectors are stored in the arrays
-* VL and/or VR.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* Specifies the eigenvectors to be computed. To select the
-* eigenvector corresponding to the eigenvalue W(j),
-* SELECT(j) must be set to .TRUE..
-*
-* N (input) INTEGER
-* The order of the matrix H. N >= 0.
-*
-* H (input) COMPLEX*16 array, dimension (LDH,N)
-* The upper Hessenberg matrix H.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH >= max(1,N).
-*
-* W (input/output) COMPLEX*16 array, dimension (N)
-* On entry, the eigenvalues of H.
-* On exit, the real parts of W may have been altered since
-* close eigenvalues are perturbed slightly in searching for
-* independent eigenvectors.
-*
-* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
-* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
-* contain starting vectors for the inverse iteration for the
-* left eigenvectors; the starting vector for each eigenvector
-* must be in the same column in which the eigenvector will be
-* stored.
-* On exit, if SIDE = 'L' or 'B', the left eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VL, in the same order as their eigenvalues.
-* If SIDE = 'R', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
-*
-* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
-* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
-* contain starting vectors for the inverse iteration for the
-* right eigenvectors; the starting vector for each eigenvector
-* must be in the same column in which the eigenvector will be
-* stored.
-* On exit, if SIDE = 'R' or 'B', the right eigenvectors
-* specified by SELECT will be stored consecutively in the
-* columns of VR, in the same order as their eigenvalues.
-* If SIDE = 'L', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR required to
-* store the eigenvectors (= the number of .TRUE. elements in
-* SELECT).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* IFAILL (output) INTEGER array, dimension (MM)
-* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
-* eigenvector in the i-th column of VL (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
-* eigenvector converged satisfactorily.
-* If SIDE = 'R', IFAILL is not referenced.
-*
-* IFAILR (output) INTEGER array, dimension (MM)
-* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
-* eigenvector in the i-th column of VR (corresponding to the
-* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
-* eigenvector converged satisfactorily.
-* If SIDE = 'L', IFAILR is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, i is the number of eigenvectors which
-* failed to converge; see IFAILL and IFAILR for further
-* details.
-*
-
-* Further Details
-* ===============
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x|+|y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zhseqr"></A>
- <H2>zhseqr</H2>
-
- <PRE>
-USAGE:
- w, work, info, h, z = NumRu::Lapack.zhseqr( job, compz, ilo, ihi, h, z, ldz, lwork)
- or
- NumRu::Lapack.zhseqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZHSEQR computes the eigenvalues of a Hessenberg matrix H
-* and, optionally, the matrices T and Z from the Schur decomposition
-* H = Z T Z**H, where T is an upper triangular matrix (the
-* Schur form), and Z is the unitary matrix of Schur vectors.
-*
-* Optionally Z may be postmultiplied into an input unitary
-* matrix Q so that this routine can give the Schur factorization
-* of a matrix A which has been reduced to the Hessenberg form H
-* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* = 'E': compute eigenvalues only;
-* = 'S': compute eigenvalues and the Schur form T.
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': no Schur vectors are computed;
-* = 'I': Z is initialized to the unit matrix and the matrix Z
-* of Schur vectors of H is returned;
-* = 'V': Z must contain an unitary matrix Q on entry, and
-* the product Q*Z is returned.
-*
-* N (input) INTEGER
-* The order of the matrix H. N .GE. 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* It is assumed that H is already upper triangular in rows
-* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
-* set by a previous call to ZGEBAL, and then passed to ZGEHRD
-* when the matrix output by ZGEBAL is reduced to Hessenberg
-* form. Otherwise ILO and IHI should be set to 1 and N
-* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
-* If N = 0, then ILO = 1 and IHI = 0.
-*
-* H (input/output) COMPLEX*16 array, dimension (LDH,N)
-* On entry, the upper Hessenberg matrix H.
-* On exit, if INFO = 0 and JOB = 'S', H contains the upper
-* triangular matrix T from the Schur decomposition (the
-* Schur form). If INFO = 0 and JOB = 'E', the contents of
-* H are unspecified on exit. (The output value of H when
-* INFO.GT.0 is given under the description of INFO below.)
-*
-* Unlike earlier versions of ZHSEQR, this subroutine may
-* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
-* or j = IHI+1, IHI+2, ... N.
-*
-* LDH (input) INTEGER
-* The leading dimension of the array H. LDH .GE. max(1,N).
-*
-* W (output) COMPLEX*16 array, dimension (N)
-* The computed eigenvalues. If JOB = 'S', the eigenvalues are
-* stored in the same order as on the diagonal of the Schur
-* form returned in H, with W(i) = H(i,i).
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
-* If COMPZ = 'N', Z is not referenced.
-* If COMPZ = 'I', on entry Z need not be set and on exit,
-* if INFO = 0, Z contains the unitary matrix Z of the Schur
-* vectors of H. If COMPZ = 'V', on entry Z must contain an
-* N-by-N matrix Q, which is assumed to be equal to the unit
-* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
-* if INFO = 0, Z contains Q*Z.
-* Normally Q is the unitary matrix generated by ZUNGHR
-* after the call to ZGEHRD which formed the Hessenberg matrix
-* H. (The output value of Z when INFO.GT.0 is given under
-* the description of INFO below.)
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. if COMPZ = 'I' or
-* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns an estimate of
-* the optimal value for LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK .GE. max(1,N)
-* is sufficient and delivers very good and sometimes
-* optimal performance. However, LWORK as large as 11*N
-* may be required for optimal performance. A workspace
-* query is recommended to determine the optimal workspace
-* size.
-*
-* If LWORK = -1, then ZHSEQR does a workspace query.
-* In this case, ZHSEQR checks the input parameters and
-* estimates the optimal workspace size for the given
-* values of N, ILO and IHI. The estimate is returned
-* in WORK(1). No error message related to LWORK is
-* issued by XERBLA. Neither H nor Z are accessed.
-*
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* .LT. 0: if INFO = -i, the i-th argument had an illegal
-* value
-* .GT. 0: if INFO = i, ZHSEQR failed to compute all of
-* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
-* and WI contain those eigenvalues which have been
-* successfully computed. (Failures are rare.)
-*
-* If INFO .GT. 0 and JOB = 'E', then on exit, the
-* remaining unconverged eigenvalues are the eigen-
-* values of the upper Hessenberg matrix rows and
-* columns ILO through INFO of the final, output
-* value of H.
-*
-* If INFO .GT. 0 and JOB = 'S', then on exit
-*
-* (*) (initial value of H)*U = U*(final value of H)
-*
-* where U is a unitary matrix. The final
-* value of H is upper Hessenberg and triangular in
-* rows and columns INFO+1 through IHI.
-*
-* If INFO .GT. 0 and COMPZ = 'V', then on exit
-*
-* (final value of Z) = (initial value of Z)*U
-*
-* where U is the unitary matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'I', then on exit
-* (final value of Z) = U
-* where U is the unitary matrix in (*) (regard-
-* less of the value of JOB.)
-*
-* If INFO .GT. 0 and COMPZ = 'N', then Z is not
-* accessed.
-*
-
-* ================================================================
-* Default values supplied by
-* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
-* It is suggested that these defaults be adjusted in order
-* to attain best performance in each particular
-* computational environment.
-*
-* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.
-* Default: 75. (Must be at least 11.)
-*
-* ISPEC=13: Recommended deflation window size.
-* This depends on ILO, IHI and NS. NS is the
-* number of simultaneous shifts returned
-* by ILAENV(ISPEC=15). (See ISPEC=15 below.)
-* The default for (IHI-ILO+1).LE.500 is NS.
-* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
-*
-* ISPEC=14: Nibble crossover point. (See IPARMQ for
-* details.) Default: 14% of deflation window
-* size.
-*
-* ISPEC=15: Number of simultaneous shifts in a multishift
-* QR iteration.
-*
-* If IHI-ILO+1 is ...
-*
-* greater than ...but less ... the
-* or equal to ... than default is
-*
-* 1 30 NS = 2(+)
-* 30 60 NS = 4(+)
-* 60 150 NS = 10(+)
-* 150 590 NS = **
-* 590 3000 NS = 64
-* 3000 6000 NS = 128
-* 6000 infinity NS = 256
-*
-* (+) By default some or all matrices of this order
-* are passed to the implicit double shift routine
-* ZLAHQR and this parameter is ignored. See
-* ISPEC=12 above and comments in IPARMQ for
-* details.
-*
-* (**) The asterisks (**) indicate an ad-hoc
-* function of N increasing from 10 to 64.
-*
-* ISPEC=16: Select structured matrix multiply.
-* If the number of simultaneous shifts (specified
-* by ISPEC=15) is less than 14, then the default
-* for ISPEC=16 is 0. Otherwise the default for
-* ISPEC=16 is 2.
-*
-* ================================================================
-* Based on contributions by
-* Karen Braman and Ralph Byers, Department of Mathematics,
-* University of Kansas, USA
-*
-* ================================================================
-* References:
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
-* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
-* 929--947, 2002.
-*
-* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
-* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
-* of Matrix Analysis, volume 23, pages 948--973, 2002.
-*
-* ================================================================
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zpb.html b/doc/zpb.html
deleted file mode 100644
index fa65105..0000000
--- a/doc/zpb.html
+++ /dev/null
@@ -1,1020 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite band matrix</H1>
- <UL>
- <LI><A HREF="#zpbcon">zpbcon</A> : </LI>
- <LI><A HREF="#zpbequ">zpbequ</A> : </LI>
- <LI><A HREF="#zpbrfs">zpbrfs</A> : </LI>
- <LI><A HREF="#zpbstf">zpbstf</A> : </LI>
- <LI><A HREF="#zpbsv">zpbsv</A> : </LI>
- <LI><A HREF="#zpbsvx">zpbsvx</A> : </LI>
- <LI><A HREF="#zpbtf2">zpbtf2</A> : </LI>
- <LI><A HREF="#zpbtrf">zpbtrf</A> : </LI>
- <LI><A HREF="#zpbtrs">zpbtrs</A> : </LI>
- </UL>
-
- <A NAME="zpbcon"></A>
- <H2>zpbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zpbcon( uplo, kd, ab, anorm)
- or
- NumRu::Lapack.zpbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPBCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite band matrix using
-* the Cholesky factorization A = U**H*U or A = L*L**H computed by
-* ZPBTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm (or infinity-norm) of the Hermitian band matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbequ"></A>
- <H2>zpbequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.zpbequ( uplo, kd, ab)
- or
- NumRu::Lapack.zpbequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZPBEQU computes row and column scalings intended to equilibrate a
-* Hermitian positive definite band matrix A and reduce its condition
-* number (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular of A is stored;
-* = 'L': Lower triangular of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The upper or lower triangle of the Hermitian band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbrfs"></A>
- <H2>zpbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zpbrfs( uplo, kd, ab, afb, b, x)
- or
- NumRu::Lapack.zpbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPBRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite
-* and banded, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
-* The upper or lower triangle of the Hermitian band matrix A,
-* stored in the first KD+1 rows of the array. The j-th column
-* of A is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H of the band matrix A as computed by
-* ZPBTRF, in the same storage format as A (see AB).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZPBTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbstf"></A>
- <H2>zpbstf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.zpbstf( uplo, kd, ab)
- or
- NumRu::Lapack.zpbstf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* ZPBSTF computes a split Cholesky factorization of a complex
-* Hermitian positive definite band matrix A.
-*
-* This routine is designed to be used in conjunction with ZHBGST.
-*
-* The factorization has the form A = S**H*S where S is a band matrix
-* of the same bandwidth as A and the following structure:
-*
-* S = ( U )
-* ( M L )
-*
-* where U is upper triangular of order m = (n+kd)/2, and L is lower
-* triangular of order n-m.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first kd+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the factor S from the split Cholesky
-* factorization A = S**H*S. See Further Details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the factorization could not be completed,
-* because the updated element a(i,i) was negative; the
-* matrix A is not positive definite.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 7, KD = 2:
-*
-* S = ( s11 s12 s13 )
-* ( s22 s23 s24 )
-* ( s33 s34 )
-* ( s44 )
-* ( s53 s54 s55 )
-* ( s64 s65 s66 )
-* ( s75 s76 s77 )
-*
-* If UPLO = 'U', the array AB holds:
-*
-* on entry: on exit:
-*
-* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'
-* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-*
-* If UPLO = 'L', the array AB holds:
-*
-* on entry: on exit:
-*
-* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
-* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *
-* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *
-*
-* Array elements marked * are not used by the routine; s12' denotes
-* conjg(s12); the diagonal elements of S are real.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbsv"></A>
- <H2>zpbsv</H2>
-
- <PRE>
-USAGE:
- info, ab, b = NumRu::Lapack.zpbsv( uplo, kd, ab, b)
- or
- NumRu::Lapack.zpbsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPBSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix, with the same number of superdiagonals or
-* subdiagonals as A. The factored form of A is then used to solve the
-* system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**H*U or A = L*L**H of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZPBTRF, ZPBTRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbsvx"></A>
- <H2>zpbsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.zpbsvx( fact, uplo, kd, ab, afb, equed, s, b)
- or
- NumRu::Lapack.zpbsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
-* compute the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite band matrix and X
-* and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular band matrix, and L is a lower
-* triangular band matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFB contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AB and AFB will not
-* be modified.
-* = 'N': The matrix A will be copied to AFB and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFB and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right-hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array, except
-* if FACT = 'F' and EQUED = 'Y', then A must contain the
-* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
-* is stored in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
-* See below for further details.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array A. LDAB >= KD+1.
-*
-* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)
-* If FACT = 'F', then AFB is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the band matrix
-* A, in the same storage format as A (see AB). If EQUED = 'Y',
-* then AFB is the factored form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H.
-*
-* If FACT = 'E', then AFB is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAFB (input) INTEGER
-* The leading dimension of the array AFB. LDAFB >= KD+1.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13
-* a22 a23 a24
-* a33 a34 a35
-* a44 a45 a46
-* a55 a56
-* (aij=conjg(aji)) a66
-*
-* Band storage of the upper triangle of A:
-*
-* * * a13 a24 a35 a46
-* * a12 a23 a34 a45 a56
-* a11 a22 a33 a44 a55 a66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* a11 a22 a33 a44 a55 a66
-* a21 a32 a43 a54 a65 *
-* a31 a42 a53 a64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbtf2"></A>
- <H2>zpbtf2</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.zpbtf2( uplo, kd, ab)
- or
- NumRu::Lapack.zpbtf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* ZPBTF2 computes the Cholesky factorization of a complex Hermitian
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix, U' is the conjugate transpose
-* of U, and L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of super-diagonals of the matrix A if UPLO = 'U',
-* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U'*U or A = L*L' of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbtrf"></A>
- <H2>zpbtrf</H2>
-
- <PRE>
-USAGE:
- info, ab = NumRu::Lapack.zpbtrf( uplo, kd, ab)
- or
- NumRu::Lapack.zpbtrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )
-
-* Purpose
-* =======
-*
-* ZPBTRF computes the Cholesky factorization of a complex Hermitian
-* positive definite band matrix A.
-*
-* The factorization has the form
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)
-* On entry, the upper or lower triangle of the Hermitian band
-* matrix A, stored in the first KD+1 rows of the array. The
-* j-th column of A is stored in the j-th column of the array AB
-* as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**H*U or A = L*L**H of the band
-* matrix A, in the same storage format as A.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* N = 6, KD = 2, and UPLO = 'U':
-*
-* On entry: On exit:
-*
-* * * a13 a24 a35 a46 * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-*
-* Similarly, if UPLO = 'L' the format of A is as follows:
-*
-* On entry: On exit:
-*
-* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
-* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
-* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
-*
-* Array elements marked * are not used by the routine.
-*
-* Contributed by
-* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpbtrs"></A>
- <H2>zpbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zpbtrs( uplo, kd, ab, b)
- or
- NumRu::Lapack.zpbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPBTRS solves a system of linear equations A*X = B with a Hermitian
-* positive definite band matrix A using the Cholesky factorization
-* A = U**H*U or A = L*L**H computed by ZPBTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor stored in AB;
-* = 'L': Lower triangular factor stored in AB.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals of the matrix A if UPLO = 'U',
-* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H of the band matrix A, stored in the
-* first KD+1 rows of the array. The j-th column of U or L is
-* stored in the j-th column of the array AB as follows:
-* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER J
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZTBSV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zpo.html b/doc/zpo.html
deleted file mode 100644
index 2e4c4c8..0000000
--- a/doc/zpo.html
+++ /dev/null
@@ -1,1552 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite matrix</H1>
- <UL>
- <LI><A HREF="#zpocon">zpocon</A> : </LI>
- <LI><A HREF="#zpoequ">zpoequ</A> : </LI>
- <LI><A HREF="#zpoequb">zpoequb</A> : </LI>
- <LI><A HREF="#zporfs">zporfs</A> : </LI>
- <LI><A HREF="#zporfsx">zporfsx</A> : </LI>
- <LI><A HREF="#zposv">zposv</A> : </LI>
- <LI><A HREF="#zposvx">zposvx</A> : </LI>
- <LI><A HREF="#zposvxx">zposvxx</A> : </LI>
- <LI><A HREF="#zpotf2">zpotf2</A> : </LI>
- <LI><A HREF="#zpotrf">zpotrf</A> : </LI>
- <LI><A HREF="#zpotri">zpotri</A> : </LI>
- <LI><A HREF="#zpotrs">zpotrs</A> : </LI>
- </UL>
-
- <A NAME="zpocon"></A>
- <H2>zpocon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zpocon( uplo, a, anorm)
- or
- NumRu::Lapack.zpocon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPOCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite matrix using the
-* Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by ZPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm (or infinity-norm) of the Hermitian matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpoequ"></A>
- <H2>zpoequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.zpoequ( a)
- or
- NumRu::Lapack.zpoequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZPOEQU computes row and column scalings intended to equilibrate a
-* Hermitian positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The N-by-N Hermitian positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpoequb"></A>
- <H2>zpoequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.zpoequb( a)
- or
- NumRu::Lapack.zpoequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZPOEQUB computes row and column scalings intended to equilibrate a
-* symmetric positive definite matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The N-by-N symmetric positive definite matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zporfs"></A>
- <H2>zporfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zporfs( uplo, a, af, b, x)
- or
- NumRu::Lapack.zporfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPORFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite,
-* and provides error bounds and backward error estimates for the
-* solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by ZPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZPOTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zporfsx"></A>
- <H2>zporfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zporfsx( uplo, equed, a, af, s, b, x, params)
- or
- NumRu::Lapack.zporfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPORFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric positive
-* definite, and provides error bounds and backward error estimates
-* for the solution. In addition to normwise error bound, the code
-* provides maximum componentwise error bound if possible. See
-* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the
-* error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**T*U or A = L*L**T, as computed by DPOTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zposv"></A>
- <H2>zposv</H2>
-
- <PRE>
-USAGE:
- info, a, b = NumRu::Lapack.zposv( uplo, a, b)
- or
- NumRu::Lapack.zposv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPOSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**H* U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZPOTRF, ZPOTRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zposvx"></A>
- <H2>zposvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.zposvx( fact, uplo, a, af, equed, s, b)
- or
- NumRu::Lapack.zposvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
-* compute the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix and X and B
-* are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**H* U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. A and AF will not
-* be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A, except if FACT = 'F' and
-* EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored form
-* of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS righthand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zposvxx"></A>
- <H2>zposvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.zposvxx( fact, uplo, a, af, equed, s, b, params)
- or
- NumRu::Lapack.zposvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T
-* to compute the solution to a complex*16 system of linear equations
-* A * X = B, where A is an N-by-N symmetric positive definite matrix
-* and X and B are N-by-NRHS matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. ZPOSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* ZPOSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* ZPOSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what ZPOSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U**T* U, if UPLO = 'U', or
-* A = L * L**T, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A (see argument RCOND). If the reciprocal of the condition number
-* is less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF contains the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A and AF are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =
-* 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper
-* triangular part of A contains the upper triangular part of the
-* matrix A, and the strictly lower triangular part of A is not
-* referenced. If UPLO = 'L', the leading N-by-N lower triangular
-* part of A contains the lower triangular part of the matrix A, and
-* the strictly upper triangular part of A is not referenced. A is
-* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =
-* 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T, in the same storage
-* format as A. If EQUED .ne. 'N', then AF is the factored
-* form of the equilibrated matrix diag(S)*A*diag(S).
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the original
-* matrix A.
-*
-* If FACT = 'E', then AF is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**T*U or A = L*L**T of the equilibrated
-* matrix A (see the description of A for the form of the
-* equilibrated matrix).
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The row scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpotf2"></A>
- <H2>zpotf2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zpotf2( uplo, a)
- or
- NumRu::Lapack.zpotf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* ZPOTF2 computes the Cholesky factorization of a complex Hermitian
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U' * U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* Hermitian matrix A is stored.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* n by n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U'*U or A = L*L'.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpotrf"></A>
- <H2>zpotrf</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zpotrf( uplo, a)
- or
- NumRu::Lapack.zpotrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* ZPOTRF computes the Cholesky factorization of a complex Hermitian
-* positive definite matrix A.
-*
-* The factorization has the form
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-* This is the block version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the Hermitian matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpotri"></A>
- <H2>zpotri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zpotri( uplo, a)
- or
- NumRu::Lapack.zpotri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* ZPOTRI computes the inverse of a complex Hermitian positive definite
-* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
-* computed by ZPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, as computed by
-* ZPOTRF.
-* On exit, the upper or lower triangle of the (Hermitian)
-* inverse of A, overwriting the input factor U or L.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZLAUUM, ZTRTRI
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpotrs"></A>
- <H2>zpotrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zpotrs( uplo, a, b)
- or
- NumRu::Lapack.zpotrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPOTRS solves a system of linear equations A*X = B with a Hermitian
-* positive definite matrix A using the Cholesky factorization
-* A = U**H*U or A = L*L**H computed by ZPOTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by ZPOTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zpp.html b/doc/zpp.html
deleted file mode 100644
index 9f87da8..0000000
--- a/doc/zpp.html
+++ /dev/null
@@ -1,793 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#zppcon">zppcon</A> : </LI>
- <LI><A HREF="#zppequ">zppequ</A> : </LI>
- <LI><A HREF="#zpprfs">zpprfs</A> : </LI>
- <LI><A HREF="#zppsv">zppsv</A> : </LI>
- <LI><A HREF="#zppsvx">zppsvx</A> : </LI>
- <LI><A HREF="#zpptrf">zpptrf</A> : </LI>
- <LI><A HREF="#zpptri">zpptri</A> : </LI>
- <LI><A HREF="#zpptrs">zpptrs</A> : </LI>
- </UL>
-
- <A NAME="zppcon"></A>
- <H2>zppcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zppcon( uplo, ap, anorm)
- or
- NumRu::Lapack.zppcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite packed matrix using
-* the Cholesky factorization A = U**H*U or A = L*L**H computed by
-* ZPPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm (or infinity-norm) of the Hermitian matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zppequ"></A>
- <H2>zppequ</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.zppequ( uplo, ap)
- or
- NumRu::Lapack.zppequ # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
-
-* Purpose
-* =======
-*
-* ZPPEQU computes row and column scalings intended to equilibrate a
-* Hermitian positive definite matrix A in packed storage and reduce
-* its condition number (with respect to the two-norm). S contains the
-* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
-* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
-* This choice of S puts the condition number of B within a factor N of
-* the smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpprfs"></A>
- <H2>zpprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zpprfs( uplo, ap, afp, b, x)
- or
- NumRu::Lapack.zpprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the Hermitian matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,
-* packed columnwise in a linear array in the same format as A
-* (see AP).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZPPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zppsv"></A>
- <H2>zppsv</H2>
-
- <PRE>
-USAGE:
- info, ap, b = NumRu::Lapack.zppsv( uplo, n, ap, b)
- or
- NumRu::Lapack.zppsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPPSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* The Cholesky decomposition is used to factor A as
-* A = U**H* U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is a lower triangular
-* matrix. The factored form of A is then used to solve the system of
-* equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, in the same storage
-* format as A.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i of A is not
-* positive definite, so the factorization could not be
-* completed, and the solution has not been computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZPPTRF, ZPPTRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zppsvx"></A>
- <H2>zppsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.zppsvx( fact, uplo, ap, afp, equed, s, b)
- or
- NumRu::Lapack.zppsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to
-* compute the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N Hermitian positive definite matrix stored in
-* packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', real scaling factors are computed to equilibrate
-* the system:
-* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
-* factor the matrix A (after equilibration if FACT = 'E') as
-* A = U'* U , if UPLO = 'U', or
-* A = L * L', if UPLO = 'L',
-* where U is an upper triangular matrix, L is a lower triangular
-* matrix, and ' indicates conjugate transpose.
-*
-* 3. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(S) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AFP contains the factored form of A.
-* If EQUED = 'Y', the matrix A has been equilibrated
-* with scaling factors given by S. AP and AFP will not
-* be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array, except if FACT = 'F'
-* and EQUED = 'Y', then A must contain the equilibrated matrix
-* diag(S)*A*diag(S). The j-th column of A is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details. A is not modified if
-* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, in the same storage
-* format as A. If EQUED .ne. 'N', then AFP is the factored
-* form of the equilibrated matrix A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the original
-* matrix A.
-*
-* If FACT = 'E', then AFP is an output argument and on exit
-* returns the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H of the equilibrated
-* matrix A (see the description of AP for the form of the
-* equilibrated matrix).
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Equilibration was done, i.e., A has been replaced by
-* diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A; not accessed if EQUED = 'N'. S is
-* an input argument if FACT = 'F'; otherwise, S is an output
-* argument. If FACT = 'F' and EQUED = 'Y', each element of S
-* must be positive.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
-* B is overwritten by diag(S) * B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
-* the original system of equations. Note that if EQUED = 'Y',
-* A and B are modified on exit, and the solution to the
-* equilibrated system is inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A after equilibration (if done). If RCOND is less than the
-* machine precision (in particular, if RCOND = 0), the matrix
-* is singular to working precision. This condition is
-* indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpptrf"></A>
- <H2>zpptrf</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.zpptrf( uplo, n, ap)
- or
- NumRu::Lapack.zpptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* ZPPTRF computes the Cholesky factorization of a complex Hermitian
-* positive definite matrix A stored in packed format.
-*
-* The factorization has the form
-* A = U**H * U, if UPLO = 'U', or
-* A = L * L**H, if UPLO = 'L',
-* where U is an upper triangular matrix and L is lower triangular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the Hermitian matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, if INFO = 0, the triangular factor U or L from the
-* Cholesky factorization A = U**H*U or A = L*L**H, in the same
-* storage format as A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the factorization could not be
-* completed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the Hermitian matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = conjg(aji))
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpptri"></A>
- <H2>zpptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.zpptri( uplo, n, ap)
- or
- NumRu::Lapack.zpptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPTRI( UPLO, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* ZPPTRI computes the inverse of a complex Hermitian positive definite
-* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H
-* computed by ZPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular factor is stored in AP;
-* = 'L': Lower triangular factor is stored in AP.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the triangular factor U or L from the Cholesky
-* factorization A = U**H*U or A = L*L**H, packed columnwise as
-* a linear array. The j-th column of U or L is stored in the
-* array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* On exit, the upper or lower triangle of the (Hermitian)
-* inverse of A, overwriting the input factor U or L.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the (i,i) element of the factor U or L is
-* zero, and the inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpptrs"></A>
- <H2>zpptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zpptrs( uplo, n, ap, b)
- or
- NumRu::Lapack.zpptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPPTRS solves a system of linear equations A*X = B with a Hermitian
-* positive definite matrix A in packed storage using the Cholesky
-* factorization A = U**H*U or A = L*L**H computed by ZPPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The triangular factor U or L from the Cholesky factorization
-* A = U**H*U or A = L*L**H, packed columnwise in a linear
-* array. The j-th column of U or L is stored in the array AP
-* as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZTPSV
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zpt.html b/doc/zpt.html
deleted file mode 100644
index 9314048..0000000
--- a/doc/zpt.html
+++ /dev/null
@@ -1,729 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric or Hermitian positive definite tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#zptcon">zptcon</A> : </LI>
- <LI><A HREF="#zpteqr">zpteqr</A> : </LI>
- <LI><A HREF="#zptrfs">zptrfs</A> : </LI>
- <LI><A HREF="#zptsv">zptsv</A> : </LI>
- <LI><A HREF="#zptsvx">zptsvx</A> : </LI>
- <LI><A HREF="#zpttrf">zpttrf</A> : </LI>
- <LI><A HREF="#zpttrs">zpttrs</A> : </LI>
- <LI><A HREF="#zptts2">zptts2</A> : </LI>
- </UL>
-
- <A NAME="zptcon"></A>
- <H2>zptcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zptcon( d, e, anorm)
- or
- NumRu::Lapack.zptcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPTCON computes the reciprocal of the condition number (in the
-* 1-norm) of a complex Hermitian positive definite tridiagonal matrix
-* using the factorization A = L*D*L**H or A = U**H*D*U computed by
-* ZPTTRF.
-*
-* Norm(inv(A)) is computed by a direct method, and the reciprocal of
-* the condition number is computed as
-* RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization of A, as computed by ZPTTRF.
-*
-* E (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) off-diagonal elements of the unit bidiagonal factor
-* U or L from the factorization of A, as computed by ZPTTRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
-* 1-norm of inv(A) computed in this routine.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The method used is described in Nicholas J. Higham, "Efficient
-* Algorithms for Computing the Condition Number of a Tridiagonal
-* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpteqr"></A>
- <H2>zpteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.zpteqr( compz, d, e, z)
- or
- NumRu::Lapack.zpteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric positive definite tridiagonal matrix by first factoring the
-* matrix using DPTTRF and then calling ZBDSQR to compute the singular
-* values of the bidiagonal factor.
-*
-* This routine computes the eigenvalues of the positive definite
-* tridiagonal matrix to high relative accuracy. This means that if the
-* eigenvalues range over many orders of magnitude in size, then the
-* small eigenvalues and corresponding eigenvectors will be computed
-* more accurately than, for example, with the standard QR method.
-*
-* The eigenvectors of a full or band positive definite Hermitian matrix
-* can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to
-* reduce this matrix to tridiagonal form. (The reduction to
-* tridiagonal form, however, may preclude the possibility of obtaining
-* high relative accuracy in the small eigenvalues of the original
-* matrix, if these eigenvalues range over many orders of magnitude.)
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvectors of original Hermitian
-* matrix also. Array Z contains the unitary matrix
-* used to reduce the original matrix to tridiagonal
-* form.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix.
-* On normal exit, D contains the eigenvalues, in descending
-* order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', the unitary matrix used in the
-* reduction to tridiagonal form.
-* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
-* original Hermitian matrix;
-* if COMPZ = 'I', the orthonormal eigenvectors of the
-* tridiagonal matrix.
-* If INFO > 0 on exit, Z contains the eigenvectors associated
-* with only the stored eigenvalues.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* COMPZ = 'V' or 'I', LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: if INFO = i, and i is:
-* <= N the Cholesky factorization of the matrix could
-* not be performed because the i-th principal minor
-* was not positive definite.
-* > N the SVD algorithm failed to converge;
-* if INFO = N+i, i off-diagonal elements of the
-* bidiagonal factor did not converge to zero.
-*
-
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zptrfs"></A>
- <H2>zptrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zptrfs( uplo, d, e, df, ef, b, x)
- or
- NumRu::Lapack.zptrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPTRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is Hermitian positive definite
-* and tridiagonal, and provides error bounds and backward error
-* estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the superdiagonal or the subdiagonal of the
-* tridiagonal matrix A is stored and the form of the
-* factorization:
-* = 'U': E is the superdiagonal of A, and A = U**H*D*U;
-* = 'L': E is the subdiagonal of A, and A = L*D*L**H.
-* (The two forms are equivalent if A is real.)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n real diagonal elements of the tridiagonal matrix A.
-*
-* E (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) off-diagonal elements of the tridiagonal matrix A
-* (see UPLO).
-*
-* DF (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from
-* the factorization computed by ZPTTRF.
-*
-* EF (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) off-diagonal elements of the unit bidiagonal
-* factor U or L from the factorization computed by ZPTTRF
-* (see UPLO).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZPTTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zptsv"></A>
- <H2>zptsv</H2>
-
- <PRE>
-USAGE:
- info, d, e, b = NumRu::Lapack.zptsv( nrhs, d, e, b)
- or
- NumRu::Lapack.zptsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPTSV computes the solution to a complex system of linear equations
-* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal
-* matrix, and X and B are N-by-NRHS matrices.
-*
-* A is factored as A = L*D*L**H, and the factored form of A is then
-* used to solve the system of equations.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the factorization A = L*D*L**H.
-*
-* E (input/output) COMPLEX*16 array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L**H factorization of
-* A. E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U**H*D*U factorization of A.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the leading minor of order i is not
-* positive definite, and the solution has not been
-* computed. The factorization has not been completed
-* unless i = N.
-*
-
-* =====================================================================
-*
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZPTTRF, ZPTTRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zptsvx"></A>
- <H2>zptsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.zptsvx( fact, d, e, df, ef, b)
- or
- NumRu::Lapack.zptsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZPTSVX uses the factorization A = L*D*L**H to compute the solution
-* to a complex system of linear equations A*X = B, where A is an
-* N-by-N Hermitian positive definite tridiagonal matrix and X and B
-* are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L
-* is a unit lower bidiagonal matrix and D is diagonal. The
-* factorization can also be regarded as having the form
-* A = U**H*D*U.
-*
-* 2. If the leading i-by-i principal minor is not positive definite,
-* then the routine returns with INFO = i. Otherwise, the factored
-* form of A is used to estimate the condition number of the matrix
-* A. If the reciprocal of the condition number is less than machine
-* precision, INFO = N+1 is returned as a warning, but the routine
-* still goes on to solve for X and compute error bounds as
-* described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix
-* A is supplied on entry.
-* = 'F': On entry, DF and EF contain the factored form of A.
-* D, E, DF, and EF will not be modified.
-* = 'N': The matrix A will be copied to DF and EF and
-* factored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix A.
-*
-* E (input) COMPLEX*16 array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix A.
-*
-* DF (input or output) DOUBLE PRECISION array, dimension (N)
-* If FACT = 'F', then DF is an input argument and on entry
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**H factorization of A.
-* If FACT = 'N', then DF is an output argument and on exit
-* contains the n diagonal elements of the diagonal matrix D
-* from the L*D*L**H factorization of A.
-*
-* EF (input or output) COMPLEX*16 array, dimension (N-1)
-* If FACT = 'F', then EF is an input argument and on entry
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**H factorization of A.
-* If FACT = 'N', then EF is an output argument and on exit
-* contains the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the L*D*L**H factorization of A.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal condition number of the matrix A. If RCOND
-* is less than the machine precision (in particular, if
-* RCOND = 0), the matrix is singular to working precision.
-* This condition is indicated by a return code of INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j).
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in any
-* element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: the leading minor of order i of A is
-* not positive definite, so the factorization
-* could not be completed, and the solution has not
-* been computed. RCOND = 0 is returned.
-* = N+1: U is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpttrf"></A>
- <H2>zpttrf</H2>
-
- <PRE>
-USAGE:
- info, d, e = NumRu::Lapack.zpttrf( d, e)
- or
- NumRu::Lapack.zpttrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTTRF( N, D, E, INFO )
-
-* Purpose
-* =======
-*
-* ZPTTRF computes the L*D*L' factorization of a complex Hermitian
-* positive definite tridiagonal matrix A. The factorization may also
-* be regarded as having the form A = U'*D*U.
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the n diagonal elements of the tridiagonal matrix
-* A. On exit, the n diagonal elements of the diagonal matrix
-* D from the L*D*L' factorization of A.
-*
-* E (input/output) COMPLEX*16 array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix A. On exit, the (n-1) subdiagonal elements of the
-* unit bidiagonal factor L from the L*D*L' factorization of A.
-* E can also be regarded as the superdiagonal of the unit
-* bidiagonal factor U from the U'*D*U factorization of A.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, the leading minor of order k is not
-* positive definite; if k < N, the factorization could not
-* be completed, while if k = N, the factorization was
-* completed, but D(N) <= 0.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zpttrs"></A>
- <H2>zpttrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zpttrs( uplo, d, e, b)
- or
- NumRu::Lapack.zpttrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZPTTRS solves a tridiagonal system of the form
-* A * X = B
-* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.
-* D is a diagonal matrix specified in the vector D, U (or L) is a unit
-* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
-* the vector E, and X and B are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies the form of the factorization and whether the
-* vector E is the superdiagonal of the upper bidiagonal factor
-* U or the subdiagonal of the lower bidiagonal factor L.
-* = 'U': A = U'*D*U, E is the superdiagonal of U
-* = 'L': A = L*D*L', E is the subdiagonal of L
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization A = U'*D*U or A = L*D*L'.
-*
-* E (input) COMPLEX*16 array, dimension (N-1)
-* If UPLO = 'U', the (n-1) superdiagonal elements of the unit
-* bidiagonal factor U from the factorization A = U'*D*U.
-* If UPLO = 'L', the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the factorization A = L*D*L'.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER IUPLO, J, JB, NB
-* ..
-* .. External Functions ..
- INTEGER ILAENV
- EXTERNAL ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZPTTS2
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zptts2"></A>
- <H2>zptts2</H2>
-
- <PRE>
-USAGE:
- b = NumRu::Lapack.zptts2( iuplo, d, e, b)
- or
- NumRu::Lapack.zptts2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB )
-
-* Purpose
-* =======
-*
-* ZPTTS2 solves a tridiagonal system of the form
-* A * X = B
-* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.
-* D is a diagonal matrix specified in the vector D, U (or L) is a unit
-* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in
-* the vector E, and X and B are N by NRHS matrices.
-*
-
-* Arguments
-* =========
-*
-* IUPLO (input) INTEGER
-* Specifies the form of the factorization and whether the
-* vector E is the superdiagonal of the upper bidiagonal factor
-* U or the subdiagonal of the lower bidiagonal factor L.
-* = 1: A = U'*D*U, E is the superdiagonal of U
-* = 0: A = L*D*L', E is the subdiagonal of L
-*
-* N (input) INTEGER
-* The order of the tridiagonal matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the diagonal matrix D from the
-* factorization A = U'*D*U or A = L*D*L'.
-*
-* E (input) COMPLEX*16 array, dimension (N-1)
-* If IUPLO = 1, the (n-1) superdiagonal elements of the unit
-* bidiagonal factor U from the factorization A = U'*D*U.
-* If IUPLO = 0, the (n-1) subdiagonal elements of the unit
-* bidiagonal factor L from the factorization A = L*D*L'.
-*
-* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
-* On entry, the right hand side vectors B for the system of
-* linear equations.
-* On exit, the solution vectors, X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, J
-* ..
-* .. External Subroutines ..
- EXTERNAL ZDSCAL
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DCONJG
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zsp.html b/doc/zsp.html
deleted file mode 100644
index 41dde51..0000000
--- a/doc/zsp.html
+++ /dev/null
@@ -1,931 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#zspcon">zspcon</A> : </LI>
- <LI><A HREF="#zspmv">zspmv</A> : </LI>
- <LI><A HREF="#zspr">zspr</A> : </LI>
- <LI><A HREF="#zsprfs">zsprfs</A> : </LI>
- <LI><A HREF="#zspsv">zspsv</A> : </LI>
- <LI><A HREF="#zspsvx">zspsvx</A> : </LI>
- <LI><A HREF="#zsptrf">zsptrf</A> : </LI>
- <LI><A HREF="#zsptri">zsptri</A> : </LI>
- <LI><A HREF="#zsptrs">zsptrs</A> : </LI>
- </UL>
-
- <A NAME="zspcon"></A>
- <H2>zspcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zspcon( uplo, ap, ipiv, anorm)
- or
- NumRu::Lapack.zspcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSPCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex symmetric packed matrix A using the
-* factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSPTRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zspmv"></A>
- <H2>zspmv</H2>
-
- <PRE>
-USAGE:
- y = NumRu::Lapack.zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy)
- or
- NumRu::Lapack.zspmv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
-
-* Purpose
-* =======
-*
-* ZSPMV performs the matrix-vector operation
-*
-* y := alpha*A*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are n element vectors and
-* A is an n by n symmetric matrix, supplied in packed form.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the matrix A is supplied in the packed
-* array AP as follows:
-*
-* UPLO = 'U' or 'u' The upper triangular part of A is
-* supplied in AP.
-*
-* UPLO = 'L' or 'l' The lower triangular part of A is
-* supplied in AP.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX*16
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* AP (input) COMPLEX*16 array, dimension at least
-* ( ( N*( N + 1 ) )/2 ).
-* Before entry, with UPLO = 'U' or 'u', the array AP must
-* contain the upper triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
-* and a( 2, 2 ) respectively, and so on.
-* Before entry, with UPLO = 'L' or 'l', the array AP must
-* contain the lower triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
-* and a( 3, 1 ) respectively, and so on.
-* Unchanged on exit.
-*
-* X (input) COMPLEX*16 array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* BETA (input) COMPLEX*16
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y (input/output) COMPLEX*16 array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y. On exit, Y is overwritten by the updated
-* vector y.
-*
-* INCY (input) INTEGER
-* On entry, INCY specifies the increment for the elements of
-* Y. INCY must not be zero.
-* Unchanged on exit.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zspr"></A>
- <H2>zspr</H2>
-
- <PRE>
-USAGE:
- ap = NumRu::Lapack.zspr( uplo, n, alpha, x, incx, ap)
- or
- NumRu::Lapack.zspr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )
-
-* Purpose
-* =======
-*
-* ZSPR performs the symmetric rank 1 operation
-*
-* A := alpha*x*conjg( x' ) + A,
-*
-* where alpha is a complex scalar, x is an n element vector and A is an
-* n by n symmetric matrix, supplied in packed form.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the matrix A is supplied in the packed
-* array AP as follows:
-*
-* UPLO = 'U' or 'u' The upper triangular part of A is
-* supplied in AP.
-*
-* UPLO = 'L' or 'l' The lower triangular part of A is
-* supplied in AP.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX*16
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X (input) COMPLEX*16 array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* AP (input/output) COMPLEX*16 array, dimension at least
-* ( ( N*( N + 1 ) )/2 ).
-* Before entry, with UPLO = 'U' or 'u', the array AP must
-* contain the upper triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
-* and a( 2, 2 ) respectively, and so on. On exit, the array
-* AP is overwritten by the upper triangular part of the
-* updated matrix.
-* Before entry, with UPLO = 'L' or 'l', the array AP must
-* contain the lower triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
-* and a( 3, 1 ) respectively, and so on. On exit, the array
-* AP is overwritten by the lower triangular part of the
-* updated matrix.
-* Note that the imaginary parts of the diagonal elements need
-* not be set, they are assumed to be zero, and on exit they
-* are set to zero.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsprfs"></A>
- <H2>zsprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zsprfs( uplo, ap, afp, ipiv, b, x)
- or
- NumRu::Lapack.zsprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSPRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite
-* and packed, and provides error bounds and backward error estimates
-* for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The factored form of the matrix A. AFP contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by ZSPTRF, stored as a packed
-* triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSPTRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZSPTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zspsv"></A>
- <H2>zspsv</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap, b = NumRu::Lapack.zspsv( uplo, ap, b)
- or
- NumRu::Lapack.zspsv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZSPSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix stored in packed format and X
-* and B are N-by-NRHS matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, D is symmetric and block diagonal with 1-by-1
-* and 2-by-2 diagonal blocks. The factored form of A is then used to
-* solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by ZSPTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be
-* computed.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZSPTRF, ZSPTRS
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zspsvx"></A>
- <H2>zspsvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zspsvx( fact, uplo, ap, afp, ipiv, b)
- or
- NumRu::Lapack.zspsvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
-* A = L*D*L**T to compute the solution to a complex system of linear
-* equations A * X = B, where A is an N-by-N symmetric matrix stored
-* in packed format and X and B are N-by-NRHS matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AFP and IPIV contain the factored form
-* of A. AP, AFP and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AFP and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangle of the symmetric matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-*
-* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* If FACT = 'F', then AFP is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* If FACT = 'N', then AFP is an output argument and on exit
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as
-* a packed triangular matrix in the same storage format as A.
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by ZSPTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by ZSPTRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* Further Details
-* ===============
-*
-* The packed storage scheme is illustrated by the following example
-* when N = 4, UPLO = 'U':
-*
-* Two-dimensional storage of the symmetric matrix A:
-*
-* a11 a12 a13 a14
-* a22 a23 a24
-* a33 a34 (aij = aji)
-* a44
-*
-* Packed storage of the upper triangle of A:
-*
-* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsptrf"></A>
- <H2>zsptrf</H2>
-
- <PRE>
-USAGE:
- ipiv, info, ap = NumRu::Lapack.zsptrf( uplo, ap)
- or
- NumRu::Lapack.zsptrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZSPTRF computes the factorization of a complex symmetric matrix A
-* stored in packed format using the Bunch-Kaufman diagonal pivoting
-* method:
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangle of the symmetric matrix
-* A, packed columnwise in a linear array. The j-th column of A
-* is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L, stored as a packed triangular
-* matrix overwriting A (see below for further details).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsptri"></A>
- <H2>zsptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.zsptri( uplo, ap, ipiv)
- or
- NumRu::Lapack.zsptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSPTRI computes the inverse of a complex symmetric indefinite matrix
-* A in packed storage using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by ZSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by ZSPTRF,
-* stored as a packed triangular matrix.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix, stored as a packed triangular matrix. The j-th column
-* of inv(A) is stored in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
-* if UPLO = 'L',
-* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSPTRF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsptrs"></A>
- <H2>zsptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zsptrs( uplo, ap, ipiv, b)
- or
- NumRu::Lapack.zsptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZSPTRS solves a system of linear equations A*X = B with a complex
-* symmetric matrix A stored in packed format using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZSPTRF, stored as a
-* packed triangular matrix.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSPTRF.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zst.html b/doc/zst.html
deleted file mode 100644
index ba3f31b..0000000
--- a/doc/zst.html
+++ /dev/null
@@ -1,757 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for (real) symmetric tridiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for (real) symmetric tridiagonal matrix</H1>
- <UL>
- <LI><A HREF="#zstedc">zstedc</A> : </LI>
- <LI><A HREF="#zstegr">zstegr</A> : </LI>
- <LI><A HREF="#zstein">zstein</A> : </LI>
- <LI><A HREF="#zstemr">zstemr</A> : </LI>
- <LI><A HREF="#zsteqr">zsteqr</A> : </LI>
- </UL>
-
- <A NAME="zstedc"></A>
- <H2>zstedc</H2>
-
- <PRE>
-USAGE:
- work, rwork, iwork, info, d, e, z = NumRu::Lapack.zstedc( compz, d, e, z, lwork, lrwork, liwork)
- or
- NumRu::Lapack.zstedc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the divide and conquer method.
-* The eigenvectors of a full or band complex Hermitian matrix can also
-* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
-* matrix to tridiagonal form.
-*
-* This code makes very mild assumptions about floating point
-* arithmetic. It will work on machines with a guard digit in
-* add/subtract, or on those binary machines without guard digits
-* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
-* It could conceivably fail on hexadecimal or decimal machines
-* without guard digits, but we know of none. See DLAED3 for details.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'I': Compute eigenvectors of tridiagonal matrix also.
-* = 'V': Compute eigenvectors of original Hermitian matrix
-* also. On entry, Z contains the unitary matrix used
-* to reduce the original matrix to tridiagonal form.
-*
-* N (input) INTEGER
-* The dimension of the symmetric tridiagonal matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the subdiagonal elements of the tridiagonal matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
-* On entry, if COMPZ = 'V', then Z contains the unitary
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original Hermitian matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.
-* If COMPZ = 'V' and N > 1, LWORK must be at least N*N.
-* Note that for COMPZ = 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LWORK need
-* only be 1.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal sizes of the WORK, RWORK and
-* IWORK arrays, returns these values as the first entries of
-* the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* RWORK (workspace/output) DOUBLE PRECISION array,
-* dimension (LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.
-* If COMPZ = 'V' and N > 1, LRWORK must be at least
-* 1 + 3*N + 2*N*lg N + 3*N**2 ,
-* where lg( N ) = smallest integer k such
-* that 2**k >= N.
-* If COMPZ = 'I' and N > 1, LRWORK must be at least
-* 1 + 4*N + 2*N**2 .
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LRWORK
-* need only be max(1,2*(N-1)).
-*
-* If LRWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK.
-* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.
-* If COMPZ = 'V' or N > 1, LIWORK must be at least
-* 6 + 6*N + 5*N*lg N.
-* If COMPZ = 'I' or N > 1, LIWORK must be at least
-* 3 + 5*N .
-* Note that for COMPZ = 'I' or 'V', then if N is less than or
-* equal to the minimum divide size, usually 25, then LIWORK
-* need only be 1.
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal sizes of the WORK, RWORK
-* and IWORK arrays, returns these values as the first entries
-* of the WORK, RWORK and IWORK arrays, and no error message
-* related to LWORK or LRWORK or LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: The algorithm failed to compute an eigenvalue while
-* working on the submatrix lying in rows and columns
-* INFO/(N+1) through mod(INFO,N+1).
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Jeff Rutter, Computer Science Division, University of California
-* at Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zstegr"></A>
- <H2>zstegr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.zstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)
- or
- NumRu::Lapack.zstegr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSTEGR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* ZSTEGR is a compatability wrapper around the improved ZSTEMR routine.
-* See DSTEMR for further details.
-*
-* One important change is that the ABSTOL parameter no longer provides any
-* benefit and hence is no longer used.
-*
-* Note : ZSTEGR and ZSTEMR work only on machines which follow
-* IEEE-754 floating-point standard in their handling of infinities and
-* NaNs. Normal execution may create these exceptiona values and hence
-* may abort due to a floating point exception in environments which
-* do not conform to the IEEE-754 standard.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* ABSTOL (input) DOUBLE PRECISION
-* Unused. Was the absolute error tolerance for the
-* eigenvalues/eigenvectors in previous versions.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and an upper bound must be used.
-* Supplying N columns is always safe.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in DLARRE,
-* if INFO = 2X, internal error in ZLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by DLARRE or
-* ZLARRV, respectively.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Inderjit Dhillon, IBM Almaden, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, LBNL/NERSC, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL TRYRAC
-* ..
-* .. External Subroutines ..
- EXTERNAL ZSTEMR
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zstein"></A>
- <H2>zstein</H2>
-
- <PRE>
-USAGE:
- z, ifail, info = NumRu::Lapack.zstein( d, e, w, iblock, isplit)
- or
- NumRu::Lapack.zstein # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )
-
-* Purpose
-* =======
-*
-* ZSTEIN computes the eigenvectors of a real symmetric tridiagonal
-* matrix T corresponding to specified eigenvalues, using inverse
-* iteration.
-*
-* The maximum number of iterations allowed for each eigenvector is
-* specified by an internal parameter MAXITS (currently set to 5).
-*
-* Although the eigenvectors are real, they are stored in a complex
-* array, which may be passed to ZUNMTR or ZUPMTR for back
-* transformation to the eigenvectors of a complex Hermitian matrix
-* which was reduced to tridiagonal form.
-*
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input) DOUBLE PRECISION array, dimension (N)
-* The n diagonal elements of the tridiagonal matrix T.
-*
-* E (input) DOUBLE PRECISION array, dimension (N-1)
-* The (n-1) subdiagonal elements of the tridiagonal matrix
-* T, stored in elements 1 to N-1.
-*
-* M (input) INTEGER
-* The number of eigenvectors to be found. 0 <= M <= N.
-*
-* W (input) DOUBLE PRECISION array, dimension (N)
-* The first M elements of W contain the eigenvalues for
-* which eigenvectors are to be computed. The eigenvalues
-* should be grouped by split-off block and ordered from
-* smallest to largest within the block. ( The output array
-* W from DSTEBZ with ORDER = 'B' is expected here. )
-*
-* IBLOCK (input) INTEGER array, dimension (N)
-* The submatrix indices associated with the corresponding
-* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
-* the first submatrix from the top, =2 if W(i) belongs to
-* the second submatrix, etc. ( The output array IBLOCK
-* from DSTEBZ is expected here. )
-*
-* ISPLIT (input) INTEGER array, dimension (N)
-* The splitting points, at which T breaks up into submatrices.
-* The first submatrix consists of rows/columns 1 to
-* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
-* through ISPLIT( 2 ), etc.
-* ( The output array ISPLIT from DSTEBZ is expected here. )
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, M)
-* The computed eigenvectors. The eigenvector associated
-* with the eigenvalue W(i) is stored in the i-th column of
-* Z. Any vector which fails to converge is set to its current
-* iterate after MAXITS iterations.
-* The imaginary parts of the eigenvectors are set to zero.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
-*
-* IWORK (workspace) INTEGER array, dimension (N)
-*
-* IFAIL (output) INTEGER array, dimension (M)
-* On normal exit, all elements of IFAIL are zero.
-* If one or more eigenvectors fail to converge after
-* MAXITS iterations, then their indices are stored in
-* array IFAIL.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, then i eigenvectors failed to converge
-* in MAXITS iterations. Their indices are stored in
-* array IFAIL.
-*
-* Internal Parameters
-* ===================
-*
-* MAXITS INTEGER, default = 5
-* The maximum number of iterations performed.
-*
-* EXTRA INTEGER, default = 2
-* The number of iterations performed after norm growth
-* criterion is satisfied, should be at least 1.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zstemr"></A>
- <H2>zstemr</H2>
-
- <PRE>
-USAGE:
- m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.zstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)
- or
- NumRu::Lapack.zstemr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSTEMR computes selected eigenvalues and, optionally, eigenvectors
-* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
-* a well defined set of pairwise different real eigenvalues, the corresponding
-* real eigenvectors are pairwise orthogonal.
-*
-* The spectrum may be computed either completely or partially by specifying
-* either an interval (VL,VU] or a range of indices IL:IU for the desired
-* eigenvalues.
-*
-* Depending on the number of desired eigenvalues, these are computed either
-* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
-* computed by the use of various suitable L D L^T factorizations near clusters
-* of close eigenvalues (referred to as RRRs, Relatively Robust
-* Representations). An informal sketch of the algorithm follows.
-*
-* For each unreduced block (submatrix) of T,
-* (a) Compute T - sigma I = L D L^T, so that L and D
-* define all the wanted eigenvalues to high relative accuracy.
-* This means that small relative changes in the entries of D and L
-* cause only small relative changes in the eigenvalues and
-* eigenvectors. The standard (unfactored) representation of the
-* tridiagonal matrix T does not have this property in general.
-* (b) Compute the eigenvalues to suitable accuracy.
-* If the eigenvectors are desired, the algorithm attains full
-* accuracy of the computed eigenvalues only right before
-* the corresponding vectors have to be computed, see steps c) and d).
-* (c) For each cluster of close eigenvalues, select a new
-* shift close to the cluster, find a new factorization, and refine
-* the shifted eigenvalues to suitable accuracy.
-* (d) For each eigenvalue with a large enough relative separation compute
-* the corresponding eigenvector by forming a rank revealing twisted
-* factorization. Go back to (c) for any clusters that remain.
-*
-* For more details, see:
-* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
-* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
-* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
-* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
-* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
-* 2004. Also LAPACK Working Note 154.
-* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
-* tridiagonal eigenvalue/eigenvector problem",
-* Computer Science Division Technical Report No. UCB/CSD-97-971,
-* UC Berkeley, May 1997.
-*
-* Further Details
-* 1.ZSTEMR works only on machines which follow IEEE-754
-* floating-point standard in their handling of infinities and NaNs.
-* This permits the use of efficient inner loops avoiding a check for
-* zero divisors.
-*
-* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to
-* real symmetric tridiagonal form.
-*
-* (Any complex Hermitean tridiagonal matrix has real values on its diagonal
-* and potentially complex numbers on its off-diagonals. By applying a
-* similarity transform with an appropriate diagonal matrix
-* diag(1,e^{i \phy_1}, ... , e^{i \phy_{n-1}}), the complex Hermitean
-* matrix can be transformed into a real symmetric matrix and complex
-* arithmetic can be entirely avoided.)
-*
-* While the eigenvectors of the real symmetric tridiagonal matrix are real,
-* the eigenvectors of original complex Hermitean matrix have complex entries
-* in general.
-* Since LAPACK drivers overwrite the matrix data with the eigenvectors,
-* ZSTEMR accepts complex workspace to facilitate interoperability
-* with ZUNMTR or ZUPMTR.
-*
-
-* Arguments
-* =========
-*
-* JOBZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only;
-* = 'V': Compute eigenvalues and eigenvectors.
-*
-* RANGE (input) CHARACTER*1
-* = 'A': all eigenvalues will be found.
-* = 'V': all eigenvalues in the half-open interval (VL,VU]
-* will be found.
-* = 'I': the IL-th through IU-th eigenvalues will be found.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the N diagonal elements of the tridiagonal matrix
-* T. On exit, D is overwritten.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the (N-1) subdiagonal elements of the tridiagonal
-* matrix T in elements 1 to N-1 of E. E(N) need not be set on
-* input, but is used internally as workspace.
-* On exit, E is overwritten.
-*
-* VL (input) DOUBLE PRECISION
-* VU (input) DOUBLE PRECISION
-* If RANGE='V', the lower and upper bounds of the interval to
-* be searched for eigenvalues. VL < VU.
-* Not referenced if RANGE = 'A' or 'I'.
-*
-* IL (input) INTEGER
-* IU (input) INTEGER
-* If RANGE='I', the indices (in ascending order) of the
-* smallest and largest eigenvalues to be returned.
-* 1 <= IL <= IU <= N, if N > 0.
-* Not referenced if RANGE = 'A' or 'V'.
-*
-* M (output) INTEGER
-* The total number of eigenvalues found. 0 <= M <= N.
-* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
-*
-* W (output) DOUBLE PRECISION array, dimension (N)
-* The first M elements contain the selected eigenvalues in
-* ascending order.
-*
-* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )
-* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
-* contain the orthonormal eigenvectors of the matrix T
-* corresponding to the selected eigenvalues, with the i-th
-* column of Z holding the eigenvector associated with W(i).
-* If JOBZ = 'N', then Z is not referenced.
-* Note: the user must ensure that at least max(1,M) columns are
-* supplied in the array Z; if RANGE = 'V', the exact value of M
-* is not known in advance and can be computed with a workspace
-* query by setting NZC = -1, see below.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* JOBZ = 'V', then LDZ >= max(1,N).
-*
-* NZC (input) INTEGER
-* The number of eigenvectors to be held in the array Z.
-* If RANGE = 'A', then NZC >= max(1,N).
-* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
-* If RANGE = 'I', then NZC >= IU-IL+1.
-* If NZC = -1, then a workspace query is assumed; the
-* routine calculates the number of columns of the array Z that
-* are needed to hold the eigenvectors.
-* This value is returned as the first entry of the Z array, and
-* no error message related to NZC is issued by XERBLA.
-*
-* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
-* The support of the eigenvectors in Z, i.e., the indices
-* indicating the nonzero elements in Z. The i-th computed eigenvector
-* is nonzero only in elements ISUPPZ( 2*i-1 ) through
-* ISUPPZ( 2*i ). This is relevant in the case when the matrix
-* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
-*
-* TRYRAC (input/output) LOGICAL
-* If TRYRAC.EQ..TRUE., indicates that the code should check whether
-* the tridiagonal matrix defines its eigenvalues to high relative
-* accuracy. If so, the code uses relative-accuracy preserving
-* algorithms that might be (a bit) slower depending on the matrix.
-* If the matrix does not define its eigenvalues to high relative
-* accuracy, the code can uses possibly faster algorithms.
-* If TRYRAC.EQ..FALSE., the code is not required to guarantee
-* relatively accurate eigenvalues and can use the fastest possible
-* techniques.
-* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
-* does not define its eigenvalues to high relative accuracy.
-*
-* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
-* On exit, if INFO = 0, WORK(1) returns the optimal
-* (and minimal) LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,18*N)
-* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= max(1,10*N)
-* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
-* if only the eigenvalues are to be computed.
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* On exit, INFO
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = 1X, internal error in DLARRE,
-* if INFO = 2X, internal error in ZLARRV.
-* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
-* the nonzero error code returned by DLARRE or
-* ZLARRV, respectively.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Beresford Parlett, University of California, Berkeley, USA
-* Jim Demmel, University of California, Berkeley, USA
-* Inderjit Dhillon, University of Texas, Austin, USA
-* Osni Marques, LBNL/NERSC, USA
-* Christof Voemel, University of California, Berkeley, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsteqr"></A>
- <H2>zsteqr</H2>
-
- <PRE>
-USAGE:
- info, d, e, z = NumRu::Lapack.zsteqr( compz, d, e, z)
- or
- NumRu::Lapack.zsteqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a
-* symmetric tridiagonal matrix using the implicit QL or QR method.
-* The eigenvectors of a full or band complex Hermitian matrix can also
-* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this
-* matrix to tridiagonal form.
-*
-
-* Arguments
-* =========
-*
-* COMPZ (input) CHARACTER*1
-* = 'N': Compute eigenvalues only.
-* = 'V': Compute eigenvalues and eigenvectors of the original
-* Hermitian matrix. On entry, Z must contain the
-* unitary matrix used to reduce the original matrix
-* to tridiagonal form.
-* = 'I': Compute eigenvalues and eigenvectors of the
-* tridiagonal matrix. Z is initialized to the identity
-* matrix.
-*
-* N (input) INTEGER
-* The order of the matrix. N >= 0.
-*
-* D (input/output) DOUBLE PRECISION array, dimension (N)
-* On entry, the diagonal elements of the tridiagonal matrix.
-* On exit, if INFO = 0, the eigenvalues in ascending order.
-*
-* E (input/output) DOUBLE PRECISION array, dimension (N-1)
-* On entry, the (n-1) subdiagonal elements of the tridiagonal
-* matrix.
-* On exit, E has been destroyed.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)
-* On entry, if COMPZ = 'V', then Z contains the unitary
-* matrix used in the reduction to tridiagonal form.
-* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
-* orthonormal eigenvectors of the original Hermitian matrix,
-* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
-* of the symmetric tridiagonal matrix.
-* If COMPZ = 'N', then Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1, and if
-* eigenvectors are desired, then LDZ >= max(1,N).
-*
-* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
-* If COMPZ = 'N', then WORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: the algorithm has failed to find all the eigenvalues in
-* a total of 30*N iterations; if INFO = i, then i
-* elements of E have not converged to zero; on exit, D
-* and E contain the elements of a symmetric tridiagonal
-* matrix which is unitarily similar to the original
-* matrix.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zsy.html b/doc/zsy.html
deleted file mode 100644
index ffab8c4..0000000
--- a/doc/zsy.html
+++ /dev/null
@@ -1,2244 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for symmetric matrix</H1>
- <UL>
- <LI><A HREF="#zsycon">zsycon</A> : </LI>
- <LI><A HREF="#zsyconv">zsyconv</A> : </LI>
- <LI><A HREF="#zsyequb">zsyequb</A> : </LI>
- <LI><A HREF="#zsymv">zsymv</A> : </LI>
- <LI><A HREF="#zsyr">zsyr</A> : </LI>
- <LI><A HREF="#zsyrfs">zsyrfs</A> : </LI>
- <LI><A HREF="#zsyrfsx">zsyrfsx</A> : </LI>
- <LI><A HREF="#zsysv">zsysv</A> : </LI>
- <LI><A HREF="#zsysvx">zsysvx</A> : </LI>
- <LI><A HREF="#zsysvxx">zsysvxx</A> : </LI>
- <LI><A HREF="#zsyswapr">zsyswapr</A> : </LI>
- <LI><A HREF="#zsytf2">zsytf2</A> : </LI>
- <LI><A HREF="#zsytrf">zsytrf</A> : </LI>
- <LI><A HREF="#zsytri">zsytri</A> : </LI>
- <LI><A HREF="#zsytri2">zsytri2</A> : </LI>
- <LI><A HREF="#zsytri2x">zsytri2x</A> : </LI>
- <LI><A HREF="#zsytrs">zsytrs</A> : </LI>
- <LI><A HREF="#zsytrs2">zsytrs2</A> : </LI>
- </UL>
-
- <A NAME="zsycon"></A>
- <H2>zsycon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.zsycon( uplo, a, ipiv, anorm)
- or
- NumRu::Lapack.zsycon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYCON estimates the reciprocal of the condition number (in the
-* 1-norm) of a complex symmetric matrix A using the factorization
-* A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.
-*
-* An estimate is obtained for norm(inv(A)), and the reciprocal of the
-* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSYTRF.
-*
-* ANORM (input) DOUBLE PRECISION
-* The 1-norm of the original matrix A.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
-* estimate of the 1-norm of inv(A) computed in this routine.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsyconv"></A>
- <H2>zsyconv</H2>
-
- <PRE>
-USAGE:
- info = NumRu::Lapack.zsyconv( uplo, way, a, ipiv)
- or
- NumRu::Lapack.zsyconv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYCONV converts A given by ZHETRF into L and D or vice-versa.
-* Get nondiagonal elements of D (returned in workspace) and
-* apply or reverse permutation done in TRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* WAY (input) CHARACTER*1
-* = 'C': Convert
-* = 'R': Revert
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) DOUBLE COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSYTRF.
-*
-* WORK (workspace) DOUBLE COMPLEX array, dimension (N)
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1.
-* LWORK = N
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsyequb"></A>
- <H2>zsyequb</H2>
-
- <PRE>
-USAGE:
- s, scond, amax, info = NumRu::Lapack.zsyequb( uplo, a)
- or
- NumRu::Lapack.zsyequb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYEQUB computes row and column scalings intended to equilibrate a
-* symmetric matrix A and reduce its condition number
-* (with respect to the two-norm). S contains the scale factors,
-* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
-* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
-* choice of S puts the condition number of B within a factor N of the
-* smallest possible condition number over all possible diagonal
-* scalings.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The N-by-N symmetric matrix whose scaling
-* factors are to be computed. Only the diagonal elements of A
-* are referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* S (output) DOUBLE PRECISION array, dimension (N)
-* If INFO = 0, S contains the scale factors for A.
-*
-* SCOND (output) DOUBLE PRECISION
-* If INFO = 0, S contains the ratio of the smallest S(i) to
-* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
-* large nor too small, it is not worth scaling by S.
-*
-* AMAX (output) DOUBLE PRECISION
-* Absolute value of largest matrix element. If AMAX is very
-* close to overflow or very close to underflow, the matrix
-* should be scaled.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (3*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element is nonpositive.
-*
-
-* Further Details
-* ======= =======
-*
-* Reference: Livne, O.E. and Golub, G.H., "Scaling by Binormalization",
-* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.
-* DOI 10.1023/B:NUMA.0000016606.32820.69
-* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsymv"></A>
- <H2>zsymv</H2>
-
- <PRE>
-USAGE:
- y = NumRu::Lapack.zsymv( uplo, alpha, a, x, incx, beta, y, incy)
- or
- NumRu::Lapack.zsymv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )
-
-* Purpose
-* =======
-*
-* ZSYMV performs the matrix-vector operation
-*
-* y := alpha*A*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are n element vectors and
-* A is an n by n symmetric matrix.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the array A is to be referenced as
-* follows:
-*
-* UPLO = 'U' or 'u' Only the upper triangular part of A
-* is to be referenced.
-*
-* UPLO = 'L' or 'l' Only the lower triangular part of A
-* is to be referenced.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX*16
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A (input) COMPLEX*16 array, dimension ( LDA, N )
-* Before entry, with UPLO = 'U' or 'u', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular part of the symmetric matrix and the strictly
-* lower triangular part of A is not referenced.
-* Before entry, with UPLO = 'L' or 'l', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular part of the symmetric matrix and the strictly
-* upper triangular part of A is not referenced.
-* Unchanged on exit.
-*
-* LDA (input) INTEGER
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least
-* max( 1, N ).
-* Unchanged on exit.
-*
-* X (input) COMPLEX*16 array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* BETA (input) COMPLEX*16
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y (input/output) COMPLEX*16 array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y. On exit, Y is overwritten by the updated
-* vector y.
-*
-* INCY (input) INTEGER
-* On entry, INCY specifies the increment for the elements of
-* Y. INCY must not be zero.
-* Unchanged on exit.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsyr"></A>
- <H2>zsyr</H2>
-
- <PRE>
-USAGE:
- a = NumRu::Lapack.zsyr( uplo, alpha, x, incx, a)
- or
- NumRu::Lapack.zsyr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )
-
-* Purpose
-* =======
-*
-* ZSYR performs the symmetric rank 1 operation
-*
-* A := alpha*x*( x' ) + A,
-*
-* where alpha is a complex scalar, x is an n element vector and A is an
-* n by n symmetric matrix.
-*
-
-* Arguments
-* ==========
-*
-* UPLO (input) CHARACTER*1
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the array A is to be referenced as
-* follows:
-*
-* UPLO = 'U' or 'u' Only the upper triangular part of A
-* is to be referenced.
-*
-* UPLO = 'L' or 'l' Only the lower triangular part of A
-* is to be referenced.
-*
-* Unchanged on exit.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA (input) COMPLEX*16
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X (input) COMPLEX*16 array, dimension at least
-* ( 1 + ( N - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the N-
-* element vector x.
-* Unchanged on exit.
-*
-* INCX (input) INTEGER
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* A (input/output) COMPLEX*16 array, dimension ( LDA, N )
-* Before entry, with UPLO = 'U' or 'u', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular part of the symmetric matrix and the strictly
-* lower triangular part of A is not referenced. On exit, the
-* upper triangular part of the array A is overwritten by the
-* upper triangular part of the updated matrix.
-* Before entry, with UPLO = 'L' or 'l', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular part of the symmetric matrix and the strictly
-* upper triangular part of A is not referenced. On exit, the
-* lower triangular part of the array A is overwritten by the
-* lower triangular part of the updated matrix.
-*
-* LDA (input) INTEGER
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least
-* max( 1, N ).
-* Unchanged on exit.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsyrfs"></A>
- <H2>zsyrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info, x = NumRu::Lapack.zsyrfs( uplo, a, af, ipiv, b, x)
- or
- NumRu::Lapack.zsyrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYRFS improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the solution.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or
-* A = L*D*L**T as computed by ZSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSYTRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by ZSYTRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* Internal Parameters
-* ===================
-*
-* ITMAX is the maximum number of steps of iterative refinement.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsyrfsx"></A>
- <H2>zsyrfsx</H2>
-
- <PRE>
-USAGE:
- rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)
- or
- NumRu::Lapack.zsyrfsx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYRFSX improves the computed solution to a system of linear
-* equations when the coefficient matrix is symmetric indefinite, and
-* provides error bounds and backward error estimates for the
-* solution. In addition to normwise error bound, the code provides
-* maximum componentwise error bound if possible. See comments for
-* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.
-*
-* The original system of linear equations may have been equilibrated
-* before calling this routine, as described by arguments EQUED and S
-* below. In this case, the solution and error bounds returned are
-* for the original unequilibrated system.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* EQUED (input) CHARACTER*1
-* Specifies the form of equilibration that was done to A
-* before calling this routine. This is needed to compute
-* the solution and error bounds correctly.
-* = 'N': No equilibration
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* The right hand side B has been changed accordingly.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input) COMPLEX*16 array, dimension (LDAF,N)
-* The factored form of the matrix A. AF contains the block
-* diagonal matrix D and the multipliers used to obtain the
-* factor U or L from the factorization A = U*D*U**T or A =
-* L*D*L**T as computed by DSYTRF.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by DSYTRF.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)
-* On entry, the solution matrix X, as computed by DGETRS.
-* On exit, the improved solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the double-precision refinement algorithm,
-* possibly with doubled-single computations if the
-* compilation environment does not support DOUBLE
-* PRECISION.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsysv"></A>
- <H2>zsysv</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a, b = NumRu::Lapack.zsysv( uplo, a, b, lwork)
- or
- NumRu::Lapack.zsysv # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYSV computes the solution to a complex system of linear equations
-* A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* The diagonal pivoting method is used to factor A as
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
-* used to solve the system of equations A * X = B.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if INFO = 0, the block diagonal matrix D and the
-* multipliers used to obtain the factor U or L from the
-* factorization A = U*D*U**T or A = L*D*L**T as computed by
-* ZSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D, as
-* determined by ZSYTRF. If IPIV(k) > 0, then rows and columns
-* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
-* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
-* then rows and columns k-1 and -IPIV(k) were interchanged and
-* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
-* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
-* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
-* diagonal block.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= 1, and for best performance
-* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
-* ZSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, so the solution could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY
- INTEGER LWKOPT, NB
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZSYTRF, ZSYTRS2
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsysvx"></A>
- <H2>zsysvx</H2>
-
- <PRE>
-USAGE:
- x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zsysvx( fact, uplo, a, af, ipiv, b, lwork)
- or
- NumRu::Lapack.zsysvx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYSVX uses the diagonal pivoting factorization to compute the
-* solution to a complex system of linear equations A * X = B,
-* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* Error bounds on the solution and a condition estimate are also
-* provided.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
-* The form of the factorization is
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
-* returns with INFO = i. Otherwise, the factored form of A is used
-* to estimate the condition number of the matrix A. If the
-* reciprocal of the condition number is less than machine precision,
-* INFO = N+1 is returned as a warning, but the routine still goes on
-* to solve for X and compute error bounds as described below.
-*
-* 3. The system of equations is solved for X using the factored form
-* of A.
-*
-* 4. Iterative refinement is applied to improve the computed solution
-* matrix and calculate error bounds and backward error estimates
-* for it.
-*
-
-* Arguments
-* =========
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of A has been
-* supplied on entry.
-* = 'F': On entry, AF and IPIV contain the factored form
-* of A. A, AF and IPIV will not be modified.
-* = 'N': The matrix A will be copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular part
-* of the matrix A, and the strictly lower triangular part of A
-* is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of A contains the lower triangular part of
-* the matrix A, and the strictly upper triangular part of A is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L from the factorization
-* A = U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block structure
-* of D, as determined by ZSYTRF.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block structure
-* of D, as determined by ZSYTRF.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The N-by-NRHS right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The estimate of the reciprocal condition number of the matrix
-* A. If RCOND is less than the machine precision (in
-* particular, if RCOND = 0), the matrix is singular to working
-* precision. This condition is indicated by a return code of
-* INFO > 0.
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >= max(1,2*N), and for best
-* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where
-* NB is the optimal blocksize for ZSYTRF.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, and i is
-* <= N: D(i,i) is exactly zero. The factorization
-* has been completed but the factor D is exactly
-* singular, so the solution and error bounds could
-* not be computed. RCOND = 0 is returned.
-* = N+1: D is nonsingular, but RCOND is less than machine
-* precision, meaning that the matrix is singular
-* to working precision. Nevertheless, the
-* solution and error bounds are computed because
-* there are a number of situations where the
-* computed solution can be more accurate than the
-* value of RCOND would suggest.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsysvxx"></A>
- <H2>zsysvxx</H2>
-
- <PRE>
-USAGE:
- x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)
- or
- NumRu::Lapack.zsysvxx # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYSVXX uses the diagonal pivoting factorization to compute the
-* solution to a complex*16 system of linear equations A * X = B, where
-* A is an N-by-N symmetric matrix and X and B are N-by-NRHS
-* matrices.
-*
-* If requested, both normwise and maximum componentwise error bounds
-* are returned. ZSYSVXX will return a solution with a tiny
-* guaranteed error (O(eps) where eps is the working machine
-* precision) unless the matrix is very ill-conditioned, in which
-* case a warning is returned. Relevant condition numbers also are
-* calculated and returned.
-*
-* ZSYSVXX accepts user-provided factorizations and equilibration
-* factors; see the definitions of the FACT and EQUED options.
-* Solving with refinement and using a factorization from a previous
-* ZSYSVXX call will also produce a solution with either O(eps)
-* errors or warnings, but we cannot make that claim for general
-* user-provided factorizations and equilibration factors if they
-* differ from what ZSYSVXX would itself produce.
-*
-* Description
-* ===========
-*
-* The following steps are performed:
-*
-* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate
-* the system:
-*
-* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B
-*
-* Whether or not the system will be equilibrated depends on the
-* scaling of the matrix A, but if equilibration is used, A is
-* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
-*
-* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor
-* the matrix A (after equilibration if FACT = 'E') as
-*
-* A = U * D * U**T, if UPLO = 'U', or
-* A = L * D * L**T, if UPLO = 'L',
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* 1-by-1 and 2-by-2 diagonal blocks.
-*
-* 3. If some D(i,i)=0, so that D is exactly singular, then the
-* routine returns with INFO = i. Otherwise, the factored form of A
-* is used to estimate the condition number of the matrix A (see
-* argument RCOND). If the reciprocal of the condition number is
-* less than machine precision, the routine still goes on to solve
-* for X and compute error bounds as described below.
-*
-* 4. The system of equations is solved for X using the factored form
-* of A.
-*
-* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),
-* the routine will use iterative refinement to try to get a small
-* error and error bounds. Refinement calculates the residual to at
-* least twice the working precision.
-*
-* 6. If equilibration was used, the matrix X is premultiplied by
-* diag(R) so that it solves the original system before
-* equilibration.
-*
-
-* Arguments
-* =========
-*
-* Some optional parameters are bundled in the PARAMS array. These
-* settings determine how refinement is performed, but often the
-* defaults are acceptable. If the defaults are acceptable, users
-* can pass NPARAMS = 0 which prevents the source code from accessing
-* the PARAMS argument.
-*
-* FACT (input) CHARACTER*1
-* Specifies whether or not the factored form of the matrix A is
-* supplied on entry, and if not, whether the matrix A should be
-* equilibrated before it is factored.
-* = 'F': On entry, AF and IPIV contain the factored form of A.
-* If EQUED is not 'N', the matrix A has been
-* equilibrated with scaling factors given by S.
-* A, AF, and IPIV are not modified.
-* = 'N': The matrix A will be copied to AF and factored.
-* = 'E': The matrix A will be equilibrated if necessary, then
-* copied to AF and factored.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The number of linear equations, i.e., the order of the
-* matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of A contains the upper triangular
-* part of the matrix A, and the strictly lower triangular
-* part of A is not referenced. If UPLO = 'L', the leading
-* N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
-* diag(S)*A*diag(S).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)
-* If FACT = 'F', then AF is an input argument and on entry
-* contains the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T as computed by DSYTRF.
-*
-* If FACT = 'N', then AF is an output argument and on exit
-* returns the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L from the factorization A =
-* U*D*U**T or A = L*D*L**T.
-*
-* LDAF (input) INTEGER
-* The leading dimension of the array AF. LDAF >= max(1,N).
-*
-* IPIV (input or output) INTEGER array, dimension (N)
-* If FACT = 'F', then IPIV is an input argument and on entry
-* contains details of the interchanges and the block
-* structure of D, as determined by DSYTRF. If IPIV(k) > 0,
-* then rows and columns k and IPIV(k) were interchanged and
-* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and
-* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and
-* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2
-* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,
-* then rows and columns k+1 and -IPIV(k) were interchanged
-* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* If FACT = 'N', then IPIV is an output argument and on exit
-* contains details of the interchanges and the block
-* structure of D, as determined by DSYTRF.
-*
-* EQUED (input or output) CHARACTER*1
-* Specifies the form of equilibration that was done.
-* = 'N': No equilibration (always true if FACT = 'N').
-* = 'Y': Both row and column equilibration, i.e., A has been
-* replaced by diag(S) * A * diag(S).
-* EQUED is an input argument if FACT = 'F'; otherwise, it is an
-* output argument.
-*
-* S (input or output) DOUBLE PRECISION array, dimension (N)
-* The scale factors for A. If EQUED = 'Y', A is multiplied on
-* the left and right by diag(S). S is an input argument if FACT =
-* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED
-* = 'Y', each element of S must be positive. If S is output, each
-* element of S is a power of the radix. If S is input, each element
-* of S should be a power of the radix to ensure a reliable solution
-* and error estimates. Scaling by powers of the radix does not cause
-* rounding errors unless the result underflows or overflows.
-* Rounding errors during scaling lead to refining with a matrix that
-* is not equivalent to the input matrix, producing error estimates
-* that may not be reliable.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the N-by-NRHS right hand side matrix B.
-* On exit,
-* if EQUED = 'N', B is not modified;
-* if EQUED = 'Y', B is overwritten by diag(S)*B;
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (output) COMPLEX*16 array, dimension (LDX,NRHS)
-* If INFO = 0, the N-by-NRHS solution matrix X to the original
-* system of equations. Note that A and B are modified on exit if
-* EQUED .ne. 'N', and the solution to the equilibrated system is
-* inv(diag(S))*X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* Reciprocal scaled condition number. This is an estimate of the
-* reciprocal Skeel condition number of the matrix A after
-* equilibration (if done). If this is less than the machine
-* precision (in particular, if it is zero), the matrix is singular
-* to working precision. Note that the error may still be small even
-* if this number is very small and the matrix appears ill-
-* conditioned.
-*
-* RPVGRW (output) DOUBLE PRECISION
-* Reciprocal pivot growth. On exit, this contains the reciprocal
-* pivot growth factor norm(A)/norm(U). The "max absolute element"
-* norm is used. If this is much less than 1, then the stability of
-* the LU factorization of the (equilibrated) matrix A could be poor.
-* This also means that the solution X, estimated condition numbers,
-* and error bounds could be unreliable. If factorization fails with
-* 0<INFO<=N, then this contains the reciprocal pivot growth factor
-* for the leading INFO columns of A.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* Componentwise relative backward error. This is the
-* componentwise relative backward error of each solution vector X(j)
-* (i.e., the smallest relative change in any element of A or B that
-* makes X(j) an exact solution).
-*
-* N_ERR_BNDS (input) INTEGER
-* Number of error bounds to return for each right hand side
-* and each type (normwise or componentwise). See ERR_BNDS_NORM and
-* ERR_BNDS_COMP below.
-*
-* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* normwise relative error, which is defined as follows:
-*
-* Normwise relative error in the ith solution vector:
-* max_j (abs(XTRUE(j,i) - X(j,i)))
-* ------------------------------
-* max_j abs(X(j,i))
-*
-* The array is indexed by the type of error information as described
-* below. There currently are up to three pieces of information
-* returned.
-*
-* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_NORM(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated normwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*A, where S scales each row by a power of the
-* radix so all absolute row sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)
-* For each right-hand side, this array contains information about
-* various error bounds and condition numbers corresponding to the
-* componentwise relative error, which is defined as follows:
-*
-* Componentwise relative error in the ith solution vector:
-* abs(XTRUE(j,i) - X(j,i))
-* max_j ----------------------
-* abs(X(j,i))
-*
-* The array is indexed by the right-hand side i (on which the
-* componentwise relative error depends), and the type of error
-* information as described below. There currently are up to three
-* pieces of information returned for each right-hand side. If
-* componentwise accuracy is not requested (PARAMS(3) = 0.0), then
-* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most
-* the first (:,N_ERR_BNDS) entries are returned.
-*
-* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith
-* right-hand side.
-*
-* The second index in ERR_BNDS_COMP(:,err) contains the following
-* three fields:
-* err = 1 "Trust/don't trust" boolean. Trust the answer if the
-* reciprocal condition number is less than the threshold
-* sqrt(n) * dlamch('Epsilon').
-*
-* err = 2 "Guaranteed" error bound: The estimated forward error,
-* almost certainly within a factor of 10 of the true error
-* so long as the next entry is greater than the threshold
-* sqrt(n) * dlamch('Epsilon'). This error bound should only
-* be trusted if the previous boolean is true.
-*
-* err = 3 Reciprocal condition number: Estimated componentwise
-* reciprocal condition number. Compared with the threshold
-* sqrt(n) * dlamch('Epsilon') to determine if the error
-* estimate is "guaranteed". These reciprocal condition
-* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some
-* appropriately scaled matrix Z.
-* Let Z = S*(A*diag(x)), where x is the solution for the
-* current right-hand side and S scales each row of
-* A*diag(x) by a power of the radix so all absolute row
-* sums of Z are approximately 1.
-*
-* See Lapack Working Note 165 for further details and extra
-* cautions.
-*
-* NPARAMS (input) INTEGER
-* Specifies the number of parameters set in PARAMS. If .LE. 0, the
-* PARAMS array is never referenced and default values are used.
-*
-* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS
-* Specifies algorithm parameters. If an entry is .LT. 0.0, then
-* that entry will be filled with default value used for that
-* parameter. Only positions up to NPARAMS are accessed; defaults
-* are used for higher-numbered parameters.
-*
-* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative
-* refinement or not.
-* Default: 1.0D+0
-* = 0.0 : No refinement is performed, and no error bounds are
-* computed.
-* = 1.0 : Use the extra-precise refinement algorithm.
-* (other values are reserved for future use)
-*
-* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual
-* computations allowed for refinement.
-* Default: 10
-* Aggressive: Set to 100 to permit convergence using approximate
-* factorizations or factorizations other than LU. If
-* the factorization uses a technique other than
-* Gaussian elimination, the guarantees in
-* err_bnds_norm and err_bnds_comp may no longer be
-* trustworthy.
-*
-* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code
-* will attempt to find a solution with small componentwise
-* relative error in the double-precision algorithm. Positive
-* is true, 0.0 is false.
-* Default: 1.0 (attempt componentwise convergence)
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: Successful exit. The solution to every right-hand side is
-* guaranteed.
-* < 0: If INFO = -i, the i-th argument had an illegal value
-* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization
-* has been completed, but the factor U is exactly singular, so
-* the solution and error bounds could not be computed. RCOND = 0
-* is returned.
-* = N+J: The solution corresponding to the Jth right-hand side is
-* not guaranteed. The solutions corresponding to other right-
-* hand sides K with K > J may not be guaranteed as well, but
-* only the first such right-hand side is reported. If a small
-* componentwise error is not requested (PARAMS(3) = 0.0) then
-* the Jth right-hand side is the first with a normwise error
-* bound that is not guaranteed (the smallest J such
-* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)
-* the Jth right-hand side is the first with either a normwise or
-* componentwise error bound that is not guaranteed (the smallest
-* J such that either ERR_BNDS_NORM(J,1) = 0.0 or
-* ERR_BNDS_COMP(J,1) = 0.0). See the definition of
-* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information
-* about all of the right-hand sides check ERR_BNDS_NORM or
-* ERR_BNDS_COMP.
-*
-
-* ==================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsyswapr"></A>
- <H2>zsyswapr</H2>
-
- <PRE>
-USAGE:
- a = NumRu::Lapack.zsyswapr( uplo, a, i1, i2)
- or
- NumRu::Lapack.zsyswapr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYSWAPR( UPLO, N, A, I1, I2)
-
-* Purpose
-* =======
-*
-* ZSYSWAPR applies an elementary permutation on the rows and the columns of
-* a symmetric matrix.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by ZSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* I1 (input) INTEGER
-* Index of the first row to swap
-*
-* I2 (input) INTEGER
-* Index of the second row to swap
-*
-
-* =====================================================================
-*
-* ..
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER I
- DOUBLE COMPLEX TMP
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL ZSWAP
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsytf2"></A>
- <H2>zsytf2</H2>
-
- <PRE>
-USAGE:
- ipiv, info, a = NumRu::Lapack.zsytf2( uplo, a)
- or
- NumRu::Lapack.zsytf2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )
-
-* Purpose
-* =======
-*
-* ZSYTF2 computes the factorization of a complex symmetric matrix A
-* using the Bunch-Kaufman diagonal pivoting method:
-*
-* A = U*D*U' or A = L*D*L'
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, U' is the transpose of U, and D is symmetric and
-* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the upper or lower triangular part of the
-* symmetric matrix A is stored:
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* n-by-n upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n-by-n lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* 09-29-06 - patch from
-* Bobby Cheng, MathWorks
-*
-* Replace l.209 and l.377
-* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
-* by
-* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
-*
-* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
-* Company
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsytrf"></A>
- <H2>zsytrf</H2>
-
- <PRE>
-USAGE:
- ipiv, work, info, a = NumRu::Lapack.zsytrf( uplo, a, lwork)
- or
- NumRu::Lapack.zsytrf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYTRF computes the factorization of a complex symmetric matrix A
-* using the Bunch-Kaufman diagonal pivoting method. The form of the
-* factorization is
-*
-* A = U*D*U**T or A = L*D*L**T
-*
-* where U (or L) is a product of permutation and unit upper (lower)
-* triangular matrices, and D is symmetric and block diagonal with
-* with 1-by-1 and 2-by-2 diagonal blocks.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A is stored;
-* = 'L': Lower triangle of A is stored.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the symmetric matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* On exit, the block diagonal matrix D and the multipliers used
-* to obtain the factor U or L (see below for further details).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (output) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D.
-* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
-* interchanged and D(k,k) is a 1-by-1 diagonal block.
-* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
-* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
-* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
-* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
-* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The length of WORK. LWORK >=1. For best performance
-* LWORK >= N*NB, where NB is the block size returned by ILAENV.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
-* has been completed, but the block diagonal matrix D is
-* exactly singular, and division by zero will occur if it
-* is used to solve a system of equations.
-*
-
-* Further Details
-* ===============
-*
-* If UPLO = 'U', then A = U*D*U', where
-* U = P(n)*U(n)* ... *P(k)U(k)* ...,
-* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
-* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I v 0 ) k-s
-* U(k) = ( 0 I 0 ) s
-* ( 0 0 I ) n-k
-* k-s s n-k
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
-* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
-* and A(k,k), and v overwrites A(1:k-2,k-1:k).
-*
-* If UPLO = 'L', then A = L*D*L', where
-* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
-* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
-* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
-* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
-* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
-* that if the diagonal block D(k) is of order s (s = 1 or 2), then
-*
-* ( I 0 0 ) k-1
-* L(k) = ( 0 I 0 ) s
-* ( 0 v I ) n-k-s+1
-* k-1 s n-k-s+1
-*
-* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
-* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
-* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LQUERY, UPPER
- INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZLASYF, ZSYTF2
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsytri"></A>
- <H2>zsytri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zsytri( uplo, a, ipiv)
- or
- NumRu::Lapack.zsytri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYTRI computes the inverse of a complex symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* ZSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the block diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by ZSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSYTRF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsytri2"></A>
- <H2>zsytri2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zsytri2( uplo, a, ipiv)
- or
- NumRu::Lapack.zsytri2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYTRI2 computes the inverse of a complex symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* ZSYTRF. ZSYTRI2 sets the LEADING DIMENSION of the workspace
-* before calling ZSYTRI2X that actually computes the inverse.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)
-* On entry, the NB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by ZSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NB structure of D
-* as determined by ZSYTRF.
-*
-* WORK (workspace) DOUBLE COMPLEX array, dimension (N+NB+1)*(NB+3)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* WORK is size >= (N+NB+1)*(NB+3)
-* If LDWORK = -1, then a workspace query is assumed; the routine
-* calculates:
-* - the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array,
-* - and no error message related to LDWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL UPPER, LQUERY
- INTEGER MINSIZE, NBMAX
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL ZSYTRI2X
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsytri2x"></A>
- <H2>zsytri2x</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zsytri2x( uplo, a, ipiv, nb)
- or
- NumRu::Lapack.zsytri2x # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )
-
-* Purpose
-* =======
-*
-* ZSYTRI2X computes the inverse of a complex symmetric indefinite matrix
-* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
-* ZSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)
-* On entry, the NNB diagonal matrix D and the multipliers
-* used to obtain the factor U or L as computed by ZSYTRF.
-*
-* On exit, if INFO = 0, the (symmetric) inverse of the original
-* matrix. If UPLO = 'U', the upper triangular part of the
-* inverse is formed and the part of A below the diagonal is not
-* referenced; if UPLO = 'L' the lower triangular part of the
-* inverse is formed and the part of A above the diagonal is
-* not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the NNB structure of D
-* as determined by ZSYTRF.
-*
-* WORK (workspace) DOUBLE COMPLEX array, dimension (N+NNB+1,NNB+3)
-*
-* NB (input) INTEGER
-* Block size
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
-* inverse could not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsytrs"></A>
- <H2>zsytrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zsytrs( uplo, a, ipiv, b)
- or
- NumRu::Lapack.zsytrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZSYTRS solves a system of linear equations A*X = B with a complex
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by ZSYTRF.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSYTRF.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zsytrs2"></A>
- <H2>zsytrs2</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.zsytrs2( uplo, a, ipiv, b)
- or
- NumRu::Lapack.zsytrs2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZSYTRS2 solves a system of linear equations A*X = B with a real
-* symmetric matrix A using the factorization A = U*D*U**T or
-* A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the details of the factorization are stored
-* as an upper or lower triangular matrix.
-* = 'U': Upper triangular, form is A = U*D*U**T;
-* = 'L': Lower triangular, form is A = L*D*L**T.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) DOUBLE COMPLEX array, dimension (LDA,N)
-* The block diagonal matrix D and the multipliers used to
-* obtain the factor U or L as computed by ZSYTRF.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* IPIV (input) INTEGER array, dimension (N)
-* Details of the interchanges and the block structure of D
-* as determined by ZSYTRF.
-*
-* B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* WORK (workspace) REAL array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ztb.html b/doc/ztb.html
deleted file mode 100644
index 933c82c..0000000
--- a/doc/ztb.html
+++ /dev/null
@@ -1,292 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for triangular band matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for triangular band matrix</H1>
- <UL>
- <LI><A HREF="#ztbcon">ztbcon</A> : </LI>
- <LI><A HREF="#ztbrfs">ztbrfs</A> : </LI>
- <LI><A HREF="#ztbtrs">ztbtrs</A> : </LI>
- </UL>
-
- <A NAME="ztbcon"></A>
- <H2>ztbcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.ztbcon( norm, uplo, diag, kd, ab)
- or
- NumRu::Lapack.ztbcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTBCON estimates the reciprocal of the condition number of a
-* triangular band matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztbrfs"></A>
- <H2>ztbrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.ztbrfs( uplo, trans, diag, kd, ab, b, x)
- or
- NumRu::Lapack.ztbrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTBRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular band
-* coefficient matrix.
-*
-* The solution matrix X must be computed by ZTBTRS or some other
-* means before entering this routine. ZTBRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of the array. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) COMPLEX*16 array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztbtrs"></A>
- <H2>ztbtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ztbtrs( uplo, trans, diag, kd, ab, b)
- or
- NumRu::Lapack.ztbtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZTBTRS solves a triangular system of the form
-*
-* A * X = B, A**T * X = B, or A**H * X = B,
-*
-* where A is a triangular band matrix of order N, and B is an
-* N-by-NRHS matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KD (input) INTEGER
-* The number of superdiagonals or subdiagonals of the
-* triangular band matrix A. KD >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) COMPLEX*16 array, dimension (LDAB,N)
-* The upper or lower triangular band matrix A, stored in the
-* first kd+1 rows of AB. The j-th column of A is stored
-* in the j-th column of the array AB as follows:
-* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
-* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= KD+1.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ztg.html b/doc/ztg.html
deleted file mode 100644
index 4cbc814..0000000
--- a/doc/ztg.html
+++ /dev/null
@@ -1,1567 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for triangular matrices, generalized problem (i.e., a pair of triangular matrices) matrix</H1>
- <UL>
- <LI><A HREF="#ztgevc">ztgevc</A> : </LI>
- <LI><A HREF="#ztgex2">ztgex2</A> : </LI>
- <LI><A HREF="#ztgexc">ztgexc</A> : </LI>
- <LI><A HREF="#ztgsen">ztgsen</A> : </LI>
- <LI><A HREF="#ztgsja">ztgsja</A> : </LI>
- <LI><A HREF="#ztgsna">ztgsna</A> : </LI>
- <LI><A HREF="#ztgsy2">ztgsy2</A> : </LI>
- <LI><A HREF="#ztgsyl">ztgsyl</A> : </LI>
- </UL>
-
- <A NAME="ztgevc"></A>
- <H2>ztgevc</H2>
-
- <PRE>
-USAGE:
- m, info, vl, vr = NumRu::Lapack.ztgevc( side, howmny, select, s, p, vl, vr)
- or
- NumRu::Lapack.ztgevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTGEVC computes some or all of the right and/or left eigenvectors of
-* a pair of complex matrices (S,P), where S and P are upper triangular.
-* Matrix pairs of this type are produced by the generalized Schur
-* factorization of a complex matrix pair (A,B):
-*
-* A = Q*S*Z**H, B = Q*P*Z**H
-*
-* as computed by ZGGHRD + ZHGEQZ.
-*
-* The right eigenvector x and the left eigenvector y of (S,P)
-* corresponding to an eigenvalue w are defined by:
-*
-* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
-*
-* where y**H denotes the conjugate tranpose of y.
-* The eigenvalues are not input to this routine, but are computed
-* directly from the diagonal elements of S and P.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
-* where Z and Q are input matrices.
-* If Q and Z are the unitary factors from the generalized Schur
-* factorization of a matrix pair (A,B), then Z*X and Q*Y
-* are the matrices of right and left eigenvectors of (A,B).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed by the matrices in VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* specified by the logical array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY='S', SELECT specifies the eigenvectors to be
-* computed. The eigenvector corresponding to the j-th
-* eigenvalue is computed if SELECT(j) = .TRUE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrices S and P. N >= 0.
-*
-* S (input) COMPLEX*16 array, dimension (LDS,N)
-* The upper triangular matrix S from a generalized Schur
-* factorization, as computed by ZHGEQZ.
-*
-* LDS (input) INTEGER
-* The leading dimension of array S. LDS >= max(1,N).
-*
-* P (input) COMPLEX*16 array, dimension (LDP,N)
-* The upper triangular matrix P from a generalized Schur
-* factorization, as computed by ZHGEQZ. P must have real
-* diagonal elements.
-*
-* LDP (input) INTEGER
-* The leading dimension of array P. LDP >= max(1,N).
-*
-* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the unitary matrix Q
-* of left Schur vectors returned by ZHGEQZ).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
-* SELECT, stored consecutively in the columns of
-* VL, in the same order as their eigenvalues.
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.
-*
-* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Q (usually the unitary matrix Z
-* of right Schur vectors returned by ZHGEQZ).
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
-* if HOWMNY = 'B', the matrix Z*X;
-* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by
-* SELECT, stored consecutively in the columns of
-* VR, in the same order as their eigenvalues.
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B', LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
-* is set to N. Each selected eigenvector occupies one column.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztgex2"></A>
- <H2>ztgex2</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z = NumRu::Lapack.ztgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1)
- or
- NumRu::Lapack.ztgex2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )
-
-* Purpose
-* =======
-*
-* ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)
-* in an upper triangular matrix pair (A, B) by an unitary equivalence
-* transformation.
-*
-* (A, B) must be in generalized Schur canonical form, that is, A and
-* B are both upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 arrays, dimensions (LDA,N)
-* On entry, the matrix A in the pair (A, B).
-* On exit, the updated matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 arrays, dimensions (LDB,N)
-* On entry, the matrix B in the pair (A, B).
-* On exit, the updated matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDZ,N)
-* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,
-* the updated matrix Q.
-* Not referenced if WANTQ = .FALSE..
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1;
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
-* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,
-* the updated matrix Z.
-* Not referenced if WANTZ = .FALSE..
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1;
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* J1 (input) INTEGER
-* The index to the first block (A11, B11).
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* =1: The transformed matrix pair (A, B) would be too far
-* from generalized Schur form; the problem is ill-
-* conditioned.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* In the current code both weak and strong stability tests are
-* performed. The user can omit the strong stability test by changing
-* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
-* details.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report UMINF-94.04,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, 1994. Also as LAPACK Working Note 87. To appear in
-* Numerical Algorithms, 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztgexc"></A>
- <H2>ztgexc</H2>
-
- <PRE>
-USAGE:
- info, a, b, q, z, ilst = NumRu::Lapack.ztgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst)
- or
- NumRu::Lapack.ztgexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )
-
-* Purpose
-* =======
-*
-* ZTGEXC reorders the generalized Schur decomposition of a complex
-* matrix pair (A,B), using an unitary equivalence transformation
-* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with
-* row index IFST is moved to row ILST.
-*
-* (A, B) must be in generalized Schur canonical form, that is, A and
-* B are both upper triangular.
-*
-* Optionally, the matrices Q and Z of generalized Schur vectors are
-* updated.
-*
-* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
-* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
-*
-
-* Arguments
-* =========
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the upper triangular matrix A in the pair (A, B).
-* On exit, the updated matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the upper triangular matrix B in the pair (A, B).
-* On exit, the updated matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDZ,N)
-* On entry, if WANTQ = .TRUE., the unitary matrix Q.
-* On exit, the updated matrix Q.
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1;
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., the unitary matrix Z.
-* On exit, the updated matrix Z.
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1;
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* IFST (input) INTEGER
-* ILST (input/output) INTEGER
-* Specify the reordering of the diagonal blocks of (A, B).
-* The block with row index IFST is moved to row ILST, by a
-* sequence of swapping between adjacent blocks.
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* <0: if INFO = -i, the i-th argument had an illegal value.
-* =1: The transformed matrix pair (A, B) would be too far
-* from generalized Schur form; the problem is ill-
-* conditioned. (A, B) may have been partially reordered,
-* and ILST points to the first row of the current
-* position of the block being moved.
-*
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report
-* UMINF - 94.04, Department of Computing Science, Umea University,
-* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
-* To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
-* 1996.
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER HERE
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZTGEX2
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztgsen"></A>
- <H2>ztgsen</H2>
-
- <PRE>
-USAGE:
- alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ztgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)
- or
- NumRu::Lapack.ztgsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTGSEN reorders the generalized Schur decomposition of a complex
-* matrix pair (A, B) (in terms of an unitary equivalence trans-
-* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
-* appears in the leading diagonal blocks of the pair (A,B). The leading
-* columns of Q and Z form unitary bases of the corresponding left and
-* right eigenspaces (deflating subspaces). (A, B) must be in
-* generalized Schur canonical form, that is, A and B are both upper
-* triangular.
-*
-* ZTGSEN also computes the generalized eigenvalues
-*
-* w(j)= ALPHA(j) / BETA(j)
-*
-* of the reordered matrix pair (A, B).
-*
-* Optionally, the routine computes estimates of reciprocal condition
-* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
-* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
-* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
-* the selected cluster and the eigenvalues outside the cluster, resp.,
-* and norms of "projections" onto left and right eigenspaces w.r.t.
-* the selected cluster in the (1,1)-block.
-*
-*
-
-* Arguments
-* =========
-*
-* IJOB (input) integer
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (PL and PR) or the deflating subspaces
-* (Difu and Difl):
-* =0: Only reorder w.r.t. SELECT. No extras.
-* =1: Reciprocal of norms of "projections" onto left and right
-* eigenspaces w.r.t. the selected cluster (PL and PR).
-* =2: Upper bounds on Difu and Difl. F-norm-based estimate
-* (DIF(1:2)).
-* =3: Estimate of Difu and Difl. 1-norm-based estimate
-* (DIF(1:2)).
-* About 5 times as expensive as IJOB = 2.
-* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
-* version to get it all.
-* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
-*
-* WANTQ (input) LOGICAL
-* .TRUE. : update the left transformation matrix Q;
-* .FALSE.: do not update Q.
-*
-* WANTZ (input) LOGICAL
-* .TRUE. : update the right transformation matrix Z;
-* .FALSE.: do not update Z.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster. To
-* select an eigenvalue w(j), SELECT(j) must be set to
-* .TRUE..
-*
-* N (input) INTEGER
-* The order of the matrices A and B. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension(LDA,N)
-* On entry, the upper triangular matrix A, in generalized
-* Schur canonical form.
-* On exit, A is overwritten by the reordered matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension(LDB,N)
-* On entry, the upper triangular matrix B, in generalized
-* Schur canonical form.
-* On exit, B is overwritten by the reordered matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* ALPHA (output) COMPLEX*16 array, dimension (N)
-* BETA (output) COMPLEX*16 array, dimension (N)
-* The diagonal elements of A and B, respectively,
-* when the pair (A,B) has been reduced to generalized Schur
-* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized
-* eigenvalues.
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
-* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
-* On exit, Q has been postmultiplied by the left unitary
-* transformation matrix which reorder (A, B); The leading M
-* columns of Q form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTQ = .FALSE., Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= 1.
-* If WANTQ = .TRUE., LDQ >= N.
-*
-* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)
-* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
-* On exit, Z has been postmultiplied by the left unitary
-* transformation matrix which reorder (A, B); The leading M
-* columns of Z form orthonormal bases for the specified pair of
-* left eigenspaces (deflating subspaces).
-* If WANTZ = .FALSE., Z is not referenced.
-*
-* LDZ (input) INTEGER
-* The leading dimension of the array Z. LDZ >= 1.
-* If WANTZ = .TRUE., LDZ >= N.
-*
-* M (output) INTEGER
-* The dimension of the specified pair of left and right
-* eigenspaces, (deflating subspaces) 0 <= M <= N.
-*
-* PL (output) DOUBLE PRECISION
-* PR (output) DOUBLE PRECISION
-* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
-* reciprocal of the norm of "projections" onto left and right
-* eigenspace with respect to the selected cluster.
-* 0 < PL, PR <= 1.
-* If M = 0 or M = N, PL = PR = 1.
-* If IJOB = 0, 2 or 3 PL, PR are not referenced.
-*
-* DIF (output) DOUBLE PRECISION array, dimension (2).
-* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
-* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
-* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
-* estimates of Difu and Difl, computed using reversed
-* communication with ZLACN2.
-* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
-* If IJOB = 0 or 1, DIF is not referenced.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= 1
-* If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)
-* If IJOB = 3 or 5, LWORK >= 4*M*(N-M)
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
-* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
-*
-* LIWORK (input) INTEGER
-* The dimension of the array IWORK. LIWORK >= 1.
-* If IJOB = 1, 2 or 4, LIWORK >= N+2;
-* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));
-*
-* If LIWORK = -1, then a workspace query is assumed; the
-* routine only calculates the optimal size of the IWORK array,
-* returns this value as the first entry of the IWORK array, and
-* no error message related to LIWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* =0: Successful exit.
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* =1: Reordering of (A, B) failed because the transformed
-* matrix pair (A, B) would be too far from generalized
-* Schur form; the problem is very ill-conditioned.
-* (A, B) may have been partially reordered.
-* If requested, 0 is returned in DIF(*), PL and PR.
-*
-*
-
-* Further Details
-* ===============
-*
-* ZTGSEN first collects the selected eigenvalues by computing unitary
-* U and W that move them to the top left corner of (A, B). In other
-* words, the selected eigenvalues are the eigenvalues of (A11, B11) in
-*
-* U'*(A, B)*W = (A11 A12) (B11 B12) n1
-* ( 0 A22),( 0 B22) n2
-* n1 n2 n1 n2
-*
-* where N = n1+n2 and U' means the conjugate transpose of U. The first
-* n1 columns of U and W span the specified pair of left and right
-* eigenspaces (deflating subspaces) of (A, B).
-*
-* If (A, B) has been obtained from the generalized real Schur
-* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
-* reordered generalized Schur form of (C, D) is given by
-*
-* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
-*
-* and the first n1 columns of Q*U and Z*W span the corresponding
-* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
-*
-* Note that if the selected eigenvalue is sufficiently ill-conditioned,
-* then its value may differ significantly from its value before
-* reordering.
-*
-* The reciprocal condition numbers of the left and right eigenspaces
-* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
-* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
-*
-* The Difu and Difl are defined as:
-*
-* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
-* and
-* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
-*
-* where sigma-min(Zu) is the smallest singular value of the
-* (2*n1*n2)-by-(2*n1*n2) matrix
-*
-* Zu = [ kron(In2, A11) -kron(A22', In1) ]
-* [ kron(In2, B11) -kron(B22', In1) ].
-*
-* Here, Inx is the identity matrix of size nx and A22' is the
-* transpose of A22. kron(X, Y) is the Kronecker product between
-* the matrices X and Y.
-*
-* When DIF(2) is small, small changes in (A, B) can cause large changes
-* in the deflating subspace. An approximate (asymptotic) bound on the
-* maximum angular error in the computed deflating subspaces is
-*
-* EPS * norm((A, B)) / DIF(2),
-*
-* where EPS is the machine precision.
-*
-* The reciprocal norm of the projectors on the left and right
-* eigenspaces associated with (A11, B11) may be returned in PL and PR.
-* They are computed as follows. First we compute L and R so that
-* P*(A, B)*Q is block diagonal, where
-*
-* P = ( I -L ) n1 Q = ( I R ) n1
-* ( 0 I ) n2 and ( 0 I ) n2
-* n1 n2 n1 n2
-*
-* and (L, R) is the solution to the generalized Sylvester equation
-*
-* A11*R - L*A22 = -A12
-* B11*R - L*B22 = -B12
-*
-* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
-* An approximate (asymptotic) bound on the average absolute error of
-* the selected eigenvalues is
-*
-* EPS * norm((A, B)) / PL.
-*
-* There are also global error bounds which valid for perturbations up
-* to a certain restriction: A lower bound (x) on the smallest
-* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
-* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
-* (i.e. (A + E, B + F), is
-*
-* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
-*
-* An approximate bound on x can be computed from DIF(1:2), PL and PR.
-*
-* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
-* (L', R') and unperturbed (L, R) left and right deflating subspaces
-* associated with the selected cluster in the (1,1)-blocks can be
-* bounded as
-*
-* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
-* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
-*
-* See LAPACK User's Guide section 4.11 or the following references
-* for more information.
-*
-* Note that if the default method for computing the Frobenius-norm-
-* based estimate DIF is not wanted (see ZLATDF), then the parameter
-* IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF
-* (IJOB = 2 will be used)). See ZTGSYL for more details.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report
-* UMINF - 94.04, Department of Computing Science, Umea University,
-* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
-* To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
-* 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztgsja"></A>
- <H2>ztgsja</H2>
-
- <PRE>
-USAGE:
- alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ztgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)
- or
- NumRu::Lapack.ztgsja # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )
-
-* Purpose
-* =======
-*
-* ZTGSJA computes the generalized singular value decomposition (GSVD)
-* of two complex upper triangular (or trapezoidal) matrices A and B.
-*
-* On entry, it is assumed that matrices A and B have the following
-* forms, which may be obtained by the preprocessing subroutine ZGGSVP
-* from a general M-by-N matrix A and P-by-N matrix B:
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L >= 0;
-* L ( 0 0 A23 )
-* M-K-L ( 0 0 0 )
-*
-* N-K-L K L
-* A = K ( 0 A12 A13 ) if M-K-L < 0;
-* M-K ( 0 0 A23 )
-*
-* N-K-L K L
-* B = L ( 0 0 B13 )
-* P-L ( 0 0 0 )
-*
-* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
-* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
-* otherwise A23 is (M-K)-by-L upper trapezoidal.
-*
-* On exit,
-*
-* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
-*
-* where U, V and Q are unitary matrices, Z' denotes the conjugate
-* transpose of Z, R is a nonsingular upper triangular matrix, and D1
-* and D2 are ``diagonal'' matrices, which are of the following
-* structures:
-*
-* If M-K-L >= 0,
-*
-* K L
-* D1 = K ( I 0 )
-* L ( 0 C )
-* M-K-L ( 0 0 )
-*
-* K L
-* D2 = L ( 0 S )
-* P-L ( 0 0 )
-*
-* N-K-L K L
-* ( 0 R ) = K ( 0 R11 R12 ) K
-* L ( 0 0 R22 ) L
-*
-* where
-*
-* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
-* S = diag( BETA(K+1), ... , BETA(K+L) ),
-* C**2 + S**2 = I.
-*
-* R is stored in A(1:K+L,N-K-L+1:N) on exit.
-*
-* If M-K-L < 0,
-*
-* K M-K K+L-M
-* D1 = K ( I 0 0 )
-* M-K ( 0 C 0 )
-*
-* K M-K K+L-M
-* D2 = M-K ( 0 S 0 )
-* K+L-M ( 0 0 I )
-* P-L ( 0 0 0 )
-*
-* N-K-L K M-K K+L-M
-* ( 0 R ) = K ( 0 R11 R12 R13 )
-* M-K ( 0 0 R22 R23 )
-* K+L-M ( 0 0 0 R33 )
-*
-* where
-* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
-* S = diag( BETA(K+1), ... , BETA(M) ),
-* C**2 + S**2 = I.
-*
-* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
-* ( 0 R22 R23 )
-* in B(M-K+1:L,N+M-K-L+1:N) on exit.
-*
-* The computation of the unitary transformation matrices U, V or Q
-* is optional. These matrices may either be formed explicitly, or they
-* may be postmultiplied into input matrices U1, V1, or Q1.
-*
-
-* Arguments
-* =========
-*
-* JOBU (input) CHARACTER*1
-* = 'U': U must contain a unitary matrix U1 on entry, and
-* the product U1*U is returned;
-* = 'I': U is initialized to the unit matrix, and the
-* unitary matrix U is returned;
-* = 'N': U is not computed.
-*
-* JOBV (input) CHARACTER*1
-* = 'V': V must contain a unitary matrix V1 on entry, and
-* the product V1*V is returned;
-* = 'I': V is initialized to the unit matrix, and the
-* unitary matrix V is returned;
-* = 'N': V is not computed.
-*
-* JOBQ (input) CHARACTER*1
-* = 'Q': Q must contain a unitary matrix Q1 on entry, and
-* the product Q1*Q is returned;
-* = 'I': Q is initialized to the unit matrix, and the
-* unitary matrix Q is returned;
-* = 'N': Q is not computed.
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* P (input) INTEGER
-* The number of rows of the matrix B. P >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrices A and B. N >= 0.
-*
-* K (input) INTEGER
-* L (input) INTEGER
-* K and L specify the subblocks in the input matrices A and B:
-* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)
-* of A and B, whose GSVD is going to be computed by ZTGSJA.
-* See Further Details.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the M-by-N matrix A.
-* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
-* matrix R or part of R. See Purpose for details.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,N)
-* On entry, the P-by-N matrix B.
-* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
-* a part of R. See Purpose for details.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,P).
-*
-* TOLA (input) DOUBLE PRECISION
-* TOLB (input) DOUBLE PRECISION
-* TOLA and TOLB are the convergence criteria for the Jacobi-
-* Kogbetliantz iteration procedure. Generally, they are the
-* same as used in the preprocessing step, say
-* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
-* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
-*
-* ALPHA (output) DOUBLE PRECISION array, dimension (N)
-* BETA (output) DOUBLE PRECISION array, dimension (N)
-* On exit, ALPHA and BETA contain the generalized singular
-* value pairs of A and B;
-* ALPHA(1:K) = 1,
-* BETA(1:K) = 0,
-* and if M-K-L >= 0,
-* ALPHA(K+1:K+L) = diag(C),
-* BETA(K+1:K+L) = diag(S),
-* or if M-K-L < 0,
-* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
-* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
-* Furthermore, if K+L < N,
-* ALPHA(K+L+1:N) = 0
-* BETA(K+L+1:N) = 0.
-*
-* U (input/output) COMPLEX*16 array, dimension (LDU,M)
-* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
-* the unitary matrix returned by ZGGSVP).
-* On exit,
-* if JOBU = 'I', U contains the unitary matrix U;
-* if JOBU = 'U', U contains the product U1*U.
-* If JOBU = 'N', U is not referenced.
-*
-* LDU (input) INTEGER
-* The leading dimension of the array U. LDU >= max(1,M) if
-* JOBU = 'U'; LDU >= 1 otherwise.
-*
-* V (input/output) COMPLEX*16 array, dimension (LDV,P)
-* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
-* the unitary matrix returned by ZGGSVP).
-* On exit,
-* if JOBV = 'I', V contains the unitary matrix V;
-* if JOBV = 'V', V contains the product V1*V.
-* If JOBV = 'N', V is not referenced.
-*
-* LDV (input) INTEGER
-* The leading dimension of the array V. LDV >= max(1,P) if
-* JOBV = 'V'; LDV >= 1 otherwise.
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
-* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
-* the unitary matrix returned by ZGGSVP).
-* On exit,
-* if JOBQ = 'I', Q contains the unitary matrix Q;
-* if JOBQ = 'Q', Q contains the product Q1*Q.
-* If JOBQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N) if
-* JOBQ = 'Q'; LDQ >= 1 otherwise.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* NCYCLE (output) INTEGER
-* The number of cycles required for convergence.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* = 1: the procedure does not converge after MAXIT cycles.
-*
-* Internal Parameters
-* ===================
-*
-* MAXIT INTEGER
-* MAXIT specifies the total loops that the iterative procedure
-* may take. If after MAXIT cycles, the routine fails to
-* converge, we return INFO = 1.
-*
-
-* Further Details
-* ===============
-*
-* ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
-* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
-* matrix B13 to the form:
-*
-* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
-*
-* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate
-* transpose of Z. C1 and S1 are diagonal matrices satisfying
-*
-* C1**2 + S1**2 = I,
-*
-* and R1 is an L-by-L nonsingular upper triangular matrix.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztgsna"></A>
- <H2>ztgsna</H2>
-
- <PRE>
-USAGE:
- s, dif, m, work, info = NumRu::Lapack.ztgsna( job, howmny, select, a, b, vl, vr, lwork)
- or
- NumRu::Lapack.ztgsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTGSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or eigenvectors of a matrix pair (A, B).
-*
-* (A, B) must be in generalized Schur canonical form, that is, A and
-* B are both upper triangular.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (DIF):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (DIF);
-* = 'B': for both eigenvalues and eigenvectors (S and DIF).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the corresponding j-th eigenvalue and/or eigenvector,
-* SELECT(j) must be set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the square matrix pair (A, B). N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The upper triangular matrix A in the pair (A,B).
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,N)
-* The upper triangular matrix B in the pair (A, B).
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* VL (input) COMPLEX*16 array, dimension (LDVL,M)
-* IF JOB = 'E' or 'B', VL must contain left eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns of VL, as returned by ZTGEVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1; and
-* If JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) COMPLEX*16 array, dimension (LDVR,M)
-* IF JOB = 'E' or 'B', VR must contain right eigenvectors of
-* (A, B), corresponding to the eigenpairs specified by HOWMNY
-* and SELECT. The eigenvectors must be stored in consecutive
-* columns of VR, as returned by ZTGEVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1;
-* If JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array.
-* If JOB = 'V', S is not referenced.
-*
-* DIF (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array.
-* If the eigenvalues cannot be reordered to compute DIF(j),
-* DIF(j) is set to 0; this can only occur when the true value
-* would be very small anyway.
-* For each eigenvalue/vector specified by SELECT, DIF stores
-* a Frobenius norm-based estimate of Difl.
-* If JOB = 'E', DIF is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S and DIF. MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and DIF used to store
-* the specified condition numbers; for each selected eigenvalue
-* one element is used. If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).
-*
-* IWORK (workspace) INTEGER array, dimension (N+2)
-* If JOB = 'E', IWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: Successful exit
-* < 0: If INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of the i-th generalized
-* eigenvalue w = (a, b) is defined as
-*
-* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))
-*
-* where u and v are the right and left eigenvectors of (A, B)
-* corresponding to w; |z| denotes the absolute value of the complex
-* number, and norm(u) denotes the 2-norm of the vector u. The pair
-* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the
-* matrix pair (A, B). If both a and b equal zero, then (A,B) is
-* singular and S(I) = -1 is returned.
-*
-* An approximate error bound on the chordal distance between the i-th
-* computed generalized eigenvalue w and the corresponding exact
-* eigenvalue lambda is
-*
-* chord(w, lambda) <= EPS * norm(A, B) / S(I),
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number of the right eigenvector u
-* and left eigenvector v corresponding to the generalized eigenvalue w
-* is defined as follows. Suppose
-*
-* (A, B) = ( a * ) ( b * ) 1
-* ( 0 A22 ),( 0 B22 ) n-1
-* 1 n-1 1 n-1
-*
-* Then the reciprocal condition number DIF(I) is
-*
-* Difl[(a, b), (A22, B22)] = sigma-min( Zl )
-*
-* where sigma-min(Zl) denotes the smallest singular value of
-*
-* Zl = [ kron(a, In-1) -kron(1, A22) ]
-* [ kron(b, In-1) -kron(1, B22) ].
-*
-* Here In-1 is the identity matrix of size n-1 and X' is the conjugate
-* transpose of X. kron(X, Y) is the Kronecker product between the
-* matrices X and Y.
-*
-* We approximate the smallest singular value of Zl with an upper
-* bound. This is done by ZLATDF.
-*
-* An approximate error bound for a computed eigenvector VL(i) or
-* VR(i) is given by
-*
-* EPS * norm(A, B) / DIF(i).
-*
-* See ref. [2-3] for more details and further references.
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* References
-* ==========
-*
-* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
-* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
-* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
-* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
-*
-* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
-* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
-* Estimation: Theory, Algorithms and Software, Report
-* UMINF - 94.04, Department of Computing Science, Umea University,
-* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.
-* To appear in Numerical Algorithms, 1996.
-*
-* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75.
-* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztgsy2"></A>
- <H2>ztgsy2</H2>
-
- <PRE>
-USAGE:
- scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ztgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)
- or
- NumRu::Lapack.ztgsy2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )
-
-* Purpose
-* =======
-*
-* ZTGSY2 solves the generalized Sylvester equation
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F
-*
-* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,
-* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
-* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular
-* (i.e., (A,D) and (B,E) in generalized Schur form).
-*
-* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
-* scaling factor chosen to avoid overflow.
-*
-* In matrix notation solving equation (1) corresponds to solve
-* Zx = scale * b, where Z is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ],
-*
-* Ik is the identity matrix of size k and X' is the transpose of X.
-* kron(X, Y) is the Kronecker product between the matrices X and Y.
-*
-* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b
-* is solved for, which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * -F
-*
-* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
-* = sigma_min(Z) using reverse communicaton with ZLACON.
-*
-* ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL
-* of an upper bound on the separation between to matrix pairs. Then
-* the input (A, D), (B, E) are sub-pencils of two matrix pairs in
-* ZTGSYL.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N', solve the generalized Sylvester equation (1).
-* = 'T': solve the 'transposed' system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* =0: solve (1) only.
-* =1: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (look ahead strategy is used).
-* =2: A contribution from this subsystem to a Frobenius
-* norm-based estimate of the separation between two matrix
-* pairs is computed. (DGECON on sub-systems is used.)
-* Not referenced if TRANS = 'T'.
-*
-* M (input) INTEGER
-* On entry, M specifies the order of A and D, and the row
-* dimension of C, F, R and L.
-*
-* N (input) INTEGER
-* On entry, N specifies the order of B and E, and the column
-* dimension of C, F, R and L.
-*
-* A (input) COMPLEX*16 array, dimension (LDA, M)
-* On entry, A contains an upper triangular matrix.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1, M).
-*
-* B (input) COMPLEX*16 array, dimension (LDB, N)
-* On entry, B contains an upper triangular matrix.
-*
-* LDB (input) INTEGER
-* The leading dimension of the matrix B. LDB >= max(1, N).
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1).
-* On exit, if IJOB = 0, C has been overwritten by the solution
-* R.
-*
-* LDC (input) INTEGER
-* The leading dimension of the matrix C. LDC >= max(1, M).
-*
-* D (input) COMPLEX*16 array, dimension (LDD, M)
-* On entry, D contains an upper triangular matrix.
-*
-* LDD (input) INTEGER
-* The leading dimension of the matrix D. LDD >= max(1, M).
-*
-* E (input) COMPLEX*16 array, dimension (LDE, N)
-* On entry, E contains an upper triangular matrix.
-*
-* LDE (input) INTEGER
-* The leading dimension of the matrix E. LDE >= max(1, N).
-*
-* F (input/output) COMPLEX*16 array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1).
-* On exit, if IJOB = 0, F has been overwritten by the solution
-* L.
-*
-* LDF (input) INTEGER
-* The leading dimension of the matrix F. LDF >= max(1, M).
-*
-* SCALE (output) DOUBLE PRECISION
-* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
-* R and L (C and F on entry) will hold the solutions to a
-* slightly perturbed system but the input matrices A, B, D and
-* E have not been changed. If SCALE = 0, R and L will hold the
-* solutions to the homogeneous system with C = F = 0.
-* Normally, SCALE = 1.
-*
-* RDSUM (input/output) DOUBLE PRECISION
-* On entry, the sum of squares of computed contributions to
-* the Dif-estimate under computation by ZTGSYL, where the
-* scaling factor RDSCAL (see below) has been factored out.
-* On exit, the corresponding sum of squares updated with the
-* contributions from the current sub-system.
-* If TRANS = 'T' RDSUM is not touched.
-* NOTE: RDSUM only makes sense when ZTGSY2 is called by
-* ZTGSYL.
-*
-* RDSCAL (input/output) DOUBLE PRECISION
-* On entry, scaling factor used to prevent overflow in RDSUM.
-* On exit, RDSCAL is updated w.r.t. the current contributions
-* in RDSUM.
-* If TRANS = 'T', RDSCAL is not touched.
-* NOTE: RDSCAL only makes sense when ZTGSY2 is called by
-* ZTGSYL.
-*
-* INFO (output) INTEGER
-* On exit, if INFO is set to
-* =0: Successful exit
-* <0: If INFO = -i, input argument number i is illegal.
-* >0: The matrix pairs (A, D) and (B, E) have common or very
-* close eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztgsyl"></A>
- <H2>ztgsyl</H2>
-
- <PRE>
-USAGE:
- scale, dif, work, info, c, f = NumRu::Lapack.ztgsyl( trans, ijob, a, b, c, d, e, f, lwork)
- or
- NumRu::Lapack.ztgsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTGSYL solves the generalized Sylvester equation:
-*
-* A * R - L * B = scale * C (1)
-* D * R - L * E = scale * F
-*
-* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
-* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
-* respectively, with complex entries. A, B, D and E are upper
-* triangular (i.e., (A,D) and (B,E) in generalized Schur form).
-*
-* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1
-* is an output scaling factor chosen to avoid overflow.
-*
-* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z
-* is defined as
-*
-* Z = [ kron(In, A) -kron(B', Im) ] (2)
-* [ kron(In, D) -kron(E', Im) ],
-*
-* Here Ix is the identity matrix of size x and X' is the conjugate
-* transpose of X. Kron(X, Y) is the Kronecker product between the
-* matrices X and Y.
-*
-* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b
-* is solved for, which is equivalent to solve for R and L in
-*
-* A' * R + D' * L = scale * C (3)
-* R * B' + L * E' = scale * -F
-*
-* This case (TRANS = 'C') is used to compute an one-norm-based estimate
-* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
-* and (B,E), using ZLACON.
-*
-* If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of
-* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
-* reciprocal of the smallest singular value of Z.
-*
-* This is a level-3 BLAS algorithm.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* = 'N': solve the generalized sylvester equation (1).
-* = 'C': solve the "conjugate transposed" system (3).
-*
-* IJOB (input) INTEGER
-* Specifies what kind of functionality to be performed.
-* =0: solve (1) only.
-* =1: The functionality of 0 and 3.
-* =2: The functionality of 0 and 4.
-* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* (look ahead strategy is used).
-* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
-* (ZGECON on sub-systems is used).
-* Not referenced if TRANS = 'C'.
-*
-* M (input) INTEGER
-* The order of the matrices A and D, and the row dimension of
-* the matrices C, F, R and L.
-*
-* N (input) INTEGER
-* The order of the matrices B and E, and the column dimension
-* of the matrices C, F, R and L.
-*
-* A (input) COMPLEX*16 array, dimension (LDA, M)
-* The upper triangular matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1, M).
-*
-* B (input) COMPLEX*16 array, dimension (LDB, N)
-* The upper triangular matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1, N).
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC, N)
-* On entry, C contains the right-hand-side of the first matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
-* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1, M).
-*
-* D (input) COMPLEX*16 array, dimension (LDD, M)
-* The upper triangular matrix D.
-*
-* LDD (input) INTEGER
-* The leading dimension of the array D. LDD >= max(1, M).
-*
-* E (input) COMPLEX*16 array, dimension (LDE, N)
-* The upper triangular matrix E.
-*
-* LDE (input) INTEGER
-* The leading dimension of the array E. LDE >= max(1, N).
-*
-* F (input/output) COMPLEX*16 array, dimension (LDF, N)
-* On entry, F contains the right-hand-side of the second matrix
-* equation in (1) or (3).
-* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
-* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
-* the solution achieved during the computation of the
-* Dif-estimate.
-*
-* LDF (input) INTEGER
-* The leading dimension of the array F. LDF >= max(1, M).
-*
-* DIF (output) DOUBLE PRECISION
-* On exit DIF is the reciprocal of a lower bound of the
-* reciprocal of the Dif-function, i.e. DIF is an upper bound of
-* Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).
-* IF IJOB = 0 or TRANS = 'C', DIF is not referenced.
-*
-* SCALE (output) DOUBLE PRECISION
-* On exit SCALE is the scaling factor in (1) or (3).
-* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
-* to a slightly perturbed system but the input matrices A, B,
-* D and E have not been changed. If SCALE = 0, R and L will
-* hold the solutions to the homogenious system with C = F = 0.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK > = 1.
-* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M+N+2)
-*
-* INFO (output) INTEGER
-* =0: successful exit
-* <0: If INFO = -i, the i-th argument had an illegal value.
-* >0: (A, D) and (B, E) have common or very close
-* eigenvalues.
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
-* Umea University, S-901 87 Umea, Sweden.
-*
-* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
-* for Solving the Generalized Sylvester Equation and Estimating the
-* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
-* Department of Computing Science, Umea University, S-901 87 Umea,
-* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
-* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
-* No 1, 1996.
-*
-* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
-* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
-* Appl., 15(4):1045-1060, 1994.
-*
-* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
-* Condition Estimators for Solving the Generalized Sylvester
-* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
-* July 1989, pp 745-751.
-*
-* =====================================================================
-* Replaced various illegal calls to CCOPY by calls to CLASET.
-* Sven Hammarling, 1/5/02.
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ztp.html b/doc/ztp.html
deleted file mode 100644
index f75e97e..0000000
--- a/doc/ztp.html
+++ /dev/null
@@ -1,570 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for triangular, packed storage matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for triangular, packed storage matrix</H1>
- <UL>
- <LI><A HREF="#ztpcon">ztpcon</A> : </LI>
- <LI><A HREF="#ztprfs">ztprfs</A> : </LI>
- <LI><A HREF="#ztptri">ztptri</A> : </LI>
- <LI><A HREF="#ztptrs">ztptrs</A> : </LI>
- <LI><A HREF="#ztpttf">ztpttf</A> : </LI>
- <LI><A HREF="#ztpttr">ztpttr</A> : </LI>
- </UL>
-
- <A NAME="ztpcon"></A>
- <H2>ztpcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.ztpcon( norm, uplo, diag, ap)
- or
- NumRu::Lapack.ztpcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTPCON estimates the reciprocal of the condition number of a packed
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztprfs"></A>
- <H2>ztprfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.ztprfs( uplo, trans, diag, ap, b, x)
- or
- NumRu::Lapack.ztprfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTPRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular packed
-* coefficient matrix.
-*
-* The solution matrix X must be computed by ZTPTRS or some other
-* means before entering this routine. ZTPRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-* If DIAG = 'U', the diagonal elements of A are not referenced
-* and are assumed to be 1.
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) COMPLEX*16 array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztptri"></A>
- <H2>ztptri</H2>
-
- <PRE>
-USAGE:
- info, ap = NumRu::Lapack.ztptri( uplo, diag, n, ap)
- or
- NumRu::Lapack.ztptri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO )
-
-* Purpose
-* =======
-*
-* ZTPTRI computes the inverse of a complex upper or lower triangular
-* matrix A stored in packed format.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)
-* On entry, the upper or lower triangular matrix A, stored
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
-* See below for further details.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same packed storage format.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* Further Details
-* ===============
-*
-* A triangular matrix A can be transferred to packed storage using one
-* of the following program segments:
-*
-* UPLO = 'U': UPLO = 'L':
-*
-* JC = 1 JC = 1
-* DO 2 J = 1, N DO 2 J = 1, N
-* DO 1 I = 1, J DO 1 I = J, N
-* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
-* 1 CONTINUE 1 CONTINUE
-* JC = JC + J JC = JC + N - J + 1
-* 2 CONTINUE 2 CONTINUE
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztptrs"></A>
- <H2>ztptrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ztptrs( uplo, trans, diag, n, ap, b)
- or
- NumRu::Lapack.ztptrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZTPTRS solves a triangular system of the form
-*
-* A * X = B, A**T * X = B, or A**H * X = B,
-*
-* where A is a triangular matrix of order N stored in packed format,
-* and B is an N-by-NRHS matrix. A check is made to verify that A is
-* nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The upper or lower triangular matrix A, packed columnwise in
-* a linear array. The j-th column of A is stored in the array
-* AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the
-* solutions X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztpttf"></A>
- <H2>ztpttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.ztpttf( transr, uplo, n, ap)
- or
- NumRu::Lapack.ztpttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )
-
-* Purpose
-* =======
-*
-* ZTPTTF copies a triangular matrix A from standard packed format (TP)
-* to rectangular full packed format (TF).
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal format is wanted;
-* = 'C': ARF in Conjugate-transpose format is wanted.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A stored in
-* RFP format. For a further discussion see Notes below.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Standard Packed Format when N is even.
-* We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* conjugate-transpose of the first three columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* conjugate-transpose of the last three columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N even and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* -- -- --
-* 03 04 05 33 43 53
-* -- --
-* 13 14 15 00 44 54
-* --
-* 23 24 25 10 11 55
-*
-* 33 34 35 20 21 22
-* --
-* 00 44 45 30 31 32
-* -- --
-* 01 11 55 40 41 42
-* -- -- --
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- -- --
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* -- -- -- -- -- -- -- -- -- --
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We next consider Standard Packed Format when N is odd.
-* We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = 'N'. RFP holds AP as follows:
-* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* conjugate-transpose of the first two columns of AP upper.
-* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* conjugate-transpose of the last two columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N odd and TRANSR = 'N'.
-*
-* RFP A RFP A
-*
-* -- --
-* 02 03 04 00 33 43
-* --
-* 12 13 14 10 11 44
-*
-* 22 23 24 20 21 22
-* --
-* 00 33 34 30 31 32
-* -- --
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- --
-* 02 12 22 00 01 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- --
-* 03 13 23 33 11 33 11 21 31 41 51
-* -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztpttr"></A>
- <H2>ztpttr</H2>
-
- <PRE>
-USAGE:
- a, info = NumRu::Lapack.ztpttr( uplo, ap)
- or
- NumRu::Lapack.ztpttr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* ZTPTTR copies a triangular matrix A from standard packed format (TP)
-* to standard full format (TR).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular.
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),
-* On entry, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* A (output) COMPLEX*16 array, dimension ( LDA, N )
-* On exit, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ztr.html b/doc/ztr.html
deleted file mode 100644
index 11efa1a..0000000
--- a/doc/ztr.html
+++ /dev/null
@@ -1,1316 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for triangular (or in some cases quasi-triangular) matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for triangular (or in some cases quasi-triangular) matrix</H1>
- <UL>
- <LI><A HREF="#ztrcon">ztrcon</A> : </LI>
- <LI><A HREF="#ztrevc">ztrevc</A> : </LI>
- <LI><A HREF="#ztrexc">ztrexc</A> : </LI>
- <LI><A HREF="#ztrrfs">ztrrfs</A> : </LI>
- <LI><A HREF="#ztrsen">ztrsen</A> : </LI>
- <LI><A HREF="#ztrsna">ztrsna</A> : </LI>
- <LI><A HREF="#ztrsyl">ztrsyl</A> : </LI>
- <LI><A HREF="#ztrti2">ztrti2</A> : </LI>
- <LI><A HREF="#ztrtri">ztrtri</A> : </LI>
- <LI><A HREF="#ztrtrs">ztrtrs</A> : </LI>
- <LI><A HREF="#ztrttf">ztrttf</A> : </LI>
- <LI><A HREF="#ztrttp">ztrttp</A> : </LI>
- </UL>
-
- <A NAME="ztrcon"></A>
- <H2>ztrcon</H2>
-
- <PRE>
-USAGE:
- rcond, info = NumRu::Lapack.ztrcon( norm, uplo, diag, a)
- or
- NumRu::Lapack.ztrcon # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTRCON estimates the reciprocal of the condition number of a
-* triangular matrix A, in either the 1-norm or the infinity-norm.
-*
-* The norm of A is computed and an estimate is obtained for
-* norm(inv(A)), then the reciprocal of the condition number is
-* computed as
-* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
-*
-
-* Arguments
-* =========
-*
-* NORM (input) CHARACTER*1
-* Specifies whether the 1-norm condition number or the
-* infinity-norm condition number is required:
-* = '1' or 'O': 1-norm;
-* = 'I': Infinity-norm.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* RCOND (output) DOUBLE PRECISION
-* The reciprocal of the condition number of the matrix A,
-* computed as RCOND = 1/(norm(A) * norm(inv(A))).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrevc"></A>
- <H2>ztrevc</H2>
-
- <PRE>
-USAGE:
- m, info, t, vl, vr = NumRu::Lapack.ztrevc( side, howmny, select, t, vl, vr)
- or
- NumRu::Lapack.ztrevc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTREVC computes some or all of the right and/or left eigenvectors of
-* a complex upper triangular matrix T.
-* Matrices of this type are produced by the Schur factorization of
-* a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.
-*
-* The right eigenvector x and the left eigenvector y of T corresponding
-* to an eigenvalue w are defined by:
-*
-* T*x = w*x, (y**H)*T = w*(y**H)
-*
-* where y**H denotes the conjugate transpose of the vector y.
-* The eigenvalues are not input to this routine, but are read directly
-* from the diagonal of T.
-*
-* This routine returns the matrices X and/or Y of right and left
-* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
-* input matrix. If Q is the unitary factor that reduces a matrix A to
-* Schur form T, then Q*X and Q*Y are the matrices of right and left
-* eigenvectors of A.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'R': compute right eigenvectors only;
-* = 'L': compute left eigenvectors only;
-* = 'B': compute both right and left eigenvectors.
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute all right and/or left eigenvectors;
-* = 'B': compute all right and/or left eigenvectors,
-* backtransformed using the matrices supplied in
-* VR and/or VL;
-* = 'S': compute selected right and/or left eigenvectors,
-* as indicated by the logical array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
-* computed.
-* The eigenvector corresponding to the j-th eigenvalue is
-* computed if SELECT(j) = .TRUE..
-* Not referenced if HOWMNY = 'A' or 'B'.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) COMPLEX*16 array, dimension (LDT,N)
-* The upper triangular matrix T. T is modified, but restored
-* on exit.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)
-* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
-* contain an N-by-N matrix Q (usually the unitary matrix Q of
-* Schur vectors returned by ZHSEQR).
-* On exit, if SIDE = 'L' or 'B', VL contains:
-* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*Y;
-* if HOWMNY = 'S', the left eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VL, in the same order as their
-* eigenvalues.
-* Not referenced if SIDE = 'R'.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL. LDVL >= 1, and if
-* SIDE = 'L' or 'B', LDVL >= N.
-*
-* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)
-* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
-* contain an N-by-N matrix Q (usually the unitary matrix Q of
-* Schur vectors returned by ZHSEQR).
-* On exit, if SIDE = 'R' or 'B', VR contains:
-* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
-* if HOWMNY = 'B', the matrix Q*X;
-* if HOWMNY = 'S', the right eigenvectors of T specified by
-* SELECT, stored consecutively in the columns
-* of VR, in the same order as their
-* eigenvalues.
-* Not referenced if SIDE = 'L'.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR. LDVR >= 1, and if
-* SIDE = 'R' or 'B'; LDVR >= N.
-*
-* MM (input) INTEGER
-* The number of columns in the arrays VL and/or VR. MM >= M.
-*
-* M (output) INTEGER
-* The number of columns in the arrays VL and/or VR actually
-* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
-* is set to N. Each selected eigenvector occupies one
-* column.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The algorithm used in this program is basically backward (forward)
-* substitution, with scaling to make the the code robust against
-* possible overflow.
-*
-* Each eigenvector is normalized so that the element of largest
-* magnitude has magnitude 1; here the magnitude of a complex number
-* (x,y) is taken to be |x| + |y|.
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrexc"></A>
- <H2>ztrexc</H2>
-
- <PRE>
-USAGE:
- info, t, q = NumRu::Lapack.ztrexc( compq, t, q, ifst, ilst)
- or
- NumRu::Lapack.ztrexc # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )
-
-* Purpose
-* =======
-*
-* ZTREXC reorders the Schur factorization of a complex matrix
-* A = Q*T*Q**H, so that the diagonal element of T with row index IFST
-* is moved to row ILST.
-*
-* The Schur form T is reordered by a unitary similarity transformation
-* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by
-* postmultplying it with Z.
-*
-
-* Arguments
-* =========
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) COMPLEX*16 array, dimension (LDT,N)
-* On entry, the upper triangular matrix T.
-* On exit, the reordered upper triangular matrix.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* unitary transformation matrix Z which reorders T.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* IFST (input) INTEGER
-* ILST (input) INTEGER
-* Specify the reordering of the diagonal elements of T:
-* The element with row index IFST is moved to row ILST by a
-* sequence of transpositions between adjacent elements.
-* 1 <= IFST <= N; 1 <= ILST <= N.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL WANTQ
- INTEGER K, M1, M2, M3
- DOUBLE PRECISION CS
- COMPLEX*16 SN, T11, T22, TEMP
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARTG, ZROT
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DCONJG, MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrrfs"></A>
- <H2>ztrrfs</H2>
-
- <PRE>
-USAGE:
- ferr, berr, info = NumRu::Lapack.ztrrfs( uplo, trans, diag, a, b, x)
- or
- NumRu::Lapack.ztrrfs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTRRFS provides error bounds and backward error estimates for the
-* solution to a system of linear equations with a triangular
-* coefficient matrix.
-*
-* The solution matrix X must be computed by ZTRTRS or some other
-* means before entering this routine. ZTRRFS does not do iterative
-* refinement because doing so cannot improve the backward error.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrices B and X. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,NRHS)
-* The right hand side matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* X (input) COMPLEX*16 array, dimension (LDX,NRHS)
-* The solution matrix X.
-*
-* LDX (input) INTEGER
-* The leading dimension of the array X. LDX >= max(1,N).
-*
-* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The estimated forward error bound for each solution vector
-* X(j) (the j-th column of the solution matrix X).
-* If XTRUE is the true solution corresponding to X(j), FERR(j)
-* is an estimated upper bound for the magnitude of the largest
-* element in (X(j) - XTRUE) divided by the magnitude of the
-* largest element in X(j). The estimate is as reliable as
-* the estimate for RCOND, and is almost always a slight
-* overestimate of the true error.
-*
-* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
-* The componentwise relative backward error of each solution
-* vector X(j) (i.e., the smallest relative change in
-* any element of A or B that makes X(j) an exact solution).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (2*N)
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrsen"></A>
- <H2>ztrsen</H2>
-
- <PRE>
-USAGE:
- w, m, s, sep, work, info, t, q = NumRu::Lapack.ztrsen( job, compq, select, t, q, lwork)
- or
- NumRu::Lapack.ztrsen # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTRSEN reorders the Schur factorization of a complex matrix
-* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in
-* the leading positions on the diagonal of the upper triangular matrix
-* T, and the leading columns of Q form an orthonormal basis of the
-* corresponding right invariant subspace.
-*
-* Optionally the routine computes the reciprocal condition numbers of
-* the cluster of eigenvalues and/or the invariant subspace.
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for the
-* cluster of eigenvalues (S) or the invariant subspace (SEP):
-* = 'N': none;
-* = 'E': for eigenvalues only (S);
-* = 'V': for invariant subspace only (SEP);
-* = 'B': for both eigenvalues and invariant subspace (S and
-* SEP).
-*
-* COMPQ (input) CHARACTER*1
-* = 'V': update the matrix Q of Schur vectors;
-* = 'N': do not update Q.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* SELECT specifies the eigenvalues in the selected cluster. To
-* select the j-th eigenvalue, SELECT(j) must be set to .TRUE..
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input/output) COMPLEX*16 array, dimension (LDT,N)
-* On entry, the upper triangular matrix T.
-* On exit, T is overwritten by the reordered matrix T, with the
-* selected eigenvalues as the leading diagonal elements.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)
-* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
-* On exit, if COMPQ = 'V', Q has been postmultiplied by the
-* unitary transformation matrix which reorders T; the leading M
-* columns of Q form an orthonormal basis for the specified
-* invariant subspace.
-* If COMPQ = 'N', Q is not referenced.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q.
-* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
-*
-* W (output) COMPLEX*16 array, dimension (N)
-* The reordered eigenvalues of T, in the same order as they
-* appear on the diagonal of T.
-*
-* M (output) INTEGER
-* The dimension of the specified invariant subspace.
-* 0 <= M <= N.
-*
-* S (output) DOUBLE PRECISION
-* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
-* condition number for the selected cluster of eigenvalues.
-* S cannot underestimate the true reciprocal condition number
-* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
-* If JOB = 'N' or 'V', S is not referenced.
-*
-* SEP (output) DOUBLE PRECISION
-* If JOB = 'V' or 'B', SEP is the estimated reciprocal
-* condition number of the specified invariant subspace. If
-* M = 0 or N, SEP = norm(T).
-* If JOB = 'N' or 'E', SEP is not referenced.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If JOB = 'N', LWORK >= 1;
-* if JOB = 'E', LWORK = max(1,M*(N-M));
-* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* ZTRSEN first collects the selected eigenvalues by computing a unitary
-* transformation Z to move them to the top left corner of T. In other
-* words, the selected eigenvalues are the eigenvalues of T11 in:
-*
-* Z'*T*Z = ( T11 T12 ) n1
-* ( 0 T22 ) n2
-* n1 n2
-*
-* where N = n1+n2 and Z' means the conjugate transpose of Z. The first
-* n1 columns of Z span the specified invariant subspace of T.
-*
-* If T has been obtained from the Schur factorization of a matrix
-* A = Q*T*Q', then the reordered Schur factorization of A is given by
-* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the
-* corresponding invariant subspace of A.
-*
-* The reciprocal condition number of the average of the eigenvalues of
-* T11 may be returned in S. S lies between 0 (very badly conditioned)
-* and 1 (very well conditioned). It is computed as follows. First we
-* compute R so that
-*
-* P = ( I R ) n1
-* ( 0 0 ) n2
-* n1 n2
-*
-* is the projector on the invariant subspace associated with T11.
-* R is the solution of the Sylvester equation:
-*
-* T11*R - R*T22 = T12.
-*
-* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
-* the two-norm of M. Then S is computed as the lower bound
-*
-* (1 + F-norm(R)**2)**(-1/2)
-*
-* on the reciprocal of 2-norm(P), the true reciprocal condition number.
-* S cannot underestimate 1 / 2-norm(P) by more than a factor of
-* sqrt(N).
-*
-* An approximate error bound for the computed average of the
-* eigenvalues of T11 is
-*
-* EPS * norm(T) / S
-*
-* where EPS is the machine precision.
-*
-* The reciprocal condition number of the right invariant subspace
-* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
-* SEP is defined as the separation of T11 and T22:
-*
-* sep( T11, T22 ) = sigma-min( C )
-*
-* where sigma-min(C) is the smallest singular value of the
-* n1*n2-by-n1*n2 matrix
-*
-* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
-*
-* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
-* product. We estimate sigma-min(C) by the reciprocal of an estimate of
-* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
-* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
-*
-* When SEP is small, small changes in T can cause large changes in
-* the invariant subspace. An approximate bound on the maximum angular
-* error in the computed right invariant subspace is
-*
-* EPS * norm(T) / SEP
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrsna"></A>
- <H2>ztrsna</H2>
-
- <PRE>
-USAGE:
- s, sep, m, info = NumRu::Lapack.ztrsna( job, howmny, select, t, vl, vr, ldwork)
- or
- NumRu::Lapack.ztrsna # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTRSNA estimates reciprocal condition numbers for specified
-* eigenvalues and/or right eigenvectors of a complex upper triangular
-* matrix T (or of any matrix Q*T*Q**H with Q unitary).
-*
-
-* Arguments
-* =========
-*
-* JOB (input) CHARACTER*1
-* Specifies whether condition numbers are required for
-* eigenvalues (S) or eigenvectors (SEP):
-* = 'E': for eigenvalues only (S);
-* = 'V': for eigenvectors only (SEP);
-* = 'B': for both eigenvalues and eigenvectors (S and SEP).
-*
-* HOWMNY (input) CHARACTER*1
-* = 'A': compute condition numbers for all eigenpairs;
-* = 'S': compute condition numbers for selected eigenpairs
-* specified by the array SELECT.
-*
-* SELECT (input) LOGICAL array, dimension (N)
-* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
-* condition numbers are required. To select condition numbers
-* for the j-th eigenpair, SELECT(j) must be set to .TRUE..
-* If HOWMNY = 'A', SELECT is not referenced.
-*
-* N (input) INTEGER
-* The order of the matrix T. N >= 0.
-*
-* T (input) COMPLEX*16 array, dimension (LDT,N)
-* The upper triangular matrix T.
-*
-* LDT (input) INTEGER
-* The leading dimension of the array T. LDT >= max(1,N).
-*
-* VL (input) COMPLEX*16 array, dimension (LDVL,M)
-* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
-* (or of any Q*T*Q**H with Q unitary), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VL, as returned by
-* ZHSEIN or ZTREVC.
-* If JOB = 'V', VL is not referenced.
-*
-* LDVL (input) INTEGER
-* The leading dimension of the array VL.
-* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
-*
-* VR (input) COMPLEX*16 array, dimension (LDVR,M)
-* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
-* (or of any Q*T*Q**H with Q unitary), corresponding to the
-* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
-* must be stored in consecutive columns of VR, as returned by
-* ZHSEIN or ZTREVC.
-* If JOB = 'V', VR is not referenced.
-*
-* LDVR (input) INTEGER
-* The leading dimension of the array VR.
-* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
-*
-* S (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'E' or 'B', the reciprocal condition numbers of the
-* selected eigenvalues, stored in consecutive elements of the
-* array. Thus S(j), SEP(j), and the j-th columns of VL and VR
-* all correspond to the same eigenpair (but not in general the
-* j-th eigenpair, unless all eigenpairs are selected).
-* If JOB = 'V', S is not referenced.
-*
-* SEP (output) DOUBLE PRECISION array, dimension (MM)
-* If JOB = 'V' or 'B', the estimated reciprocal condition
-* numbers of the selected eigenvectors, stored in consecutive
-* elements of the array.
-* If JOB = 'E', SEP is not referenced.
-*
-* MM (input) INTEGER
-* The number of elements in the arrays S (if JOB = 'E' or 'B')
-* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
-*
-* M (output) INTEGER
-* The number of elements of the arrays S and/or SEP actually
-* used to store the estimated condition numbers.
-* If HOWMNY = 'A', M is set to N.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+6)
-* If JOB = 'E', WORK is not referenced.
-*
-* LDWORK (input) INTEGER
-* The leading dimension of the array WORK.
-* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension (N)
-* If JOB = 'E', RWORK is not referenced.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The reciprocal of the condition number of an eigenvalue lambda is
-* defined as
-*
-* S(lambda) = |v'*u| / (norm(u)*norm(v))
-*
-* where u and v are the right and left eigenvectors of T corresponding
-* to lambda; v' denotes the conjugate transpose of v, and norm(u)
-* denotes the Euclidean norm. These reciprocal condition numbers always
-* lie between zero (very badly conditioned) and one (very well
-* conditioned). If n = 1, S(lambda) is defined to be 1.
-*
-* An approximate error bound for a computed eigenvalue W(i) is given by
-*
-* EPS * norm(T) / S(i)
-*
-* where EPS is the machine precision.
-*
-* The reciprocal of the condition number of the right eigenvector u
-* corresponding to lambda is defined as follows. Suppose
-*
-* T = ( lambda c )
-* ( 0 T22 )
-*
-* Then the reciprocal condition number is
-*
-* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
-*
-* where sigma-min denotes the smallest singular value. We approximate
-* the smallest singular value by the reciprocal of an estimate of the
-* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
-* defined to be abs(T(1,1)).
-*
-* An approximate error bound for a computed right eigenvector VR(i)
-* is given by
-*
-* EPS * norm(T) / SEP(i)
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrsyl"></A>
- <H2>ztrsyl</H2>
-
- <PRE>
-USAGE:
- scale, info, c = NumRu::Lapack.ztrsyl( trana, tranb, isgn, a, b, c)
- or
- NumRu::Lapack.ztrsyl # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )
-
-* Purpose
-* =======
-*
-* ZTRSYL solves the complex Sylvester matrix equation:
-*
-* op(A)*X + X*op(B) = scale*C or
-* op(A)*X - X*op(B) = scale*C,
-*
-* where op(A) = A or A**H, and A and B are both upper triangular. A is
-* M-by-M and B is N-by-N; the right hand side C and the solution X are
-* M-by-N; and scale is an output scale factor, set <= 1 to avoid
-* overflow in X.
-*
-
-* Arguments
-* =========
-*
-* TRANA (input) CHARACTER*1
-* Specifies the option op(A):
-* = 'N': op(A) = A (No transpose)
-* = 'C': op(A) = A**H (Conjugate transpose)
-*
-* TRANB (input) CHARACTER*1
-* Specifies the option op(B):
-* = 'N': op(B) = B (No transpose)
-* = 'C': op(B) = B**H (Conjugate transpose)
-*
-* ISGN (input) INTEGER
-* Specifies the sign in the equation:
-* = +1: solve op(A)*X + X*op(B) = scale*C
-* = -1: solve op(A)*X - X*op(B) = scale*C
-*
-* M (input) INTEGER
-* The order of the matrix A, and the number of rows in the
-* matrices X and C. M >= 0.
-*
-* N (input) INTEGER
-* The order of the matrix B, and the number of columns in the
-* matrices X and C. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,M)
-* The upper triangular matrix A.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* B (input) COMPLEX*16 array, dimension (LDB,N)
-* The upper triangular matrix B.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N right hand side matrix C.
-* On exit, C is overwritten by the solution matrix X.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M)
-*
-* SCALE (output) DOUBLE PRECISION
-* The scale factor, scale, set <= 1 to avoid overflow in X.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* = 1: A and B have common or very close eigenvalues; perturbed
-* values were used to solve the equation (but the matrices
-* A and B are unchanged).
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrti2"></A>
- <H2>ztrti2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ztrti2( uplo, diag, a)
- or
- NumRu::Lapack.ztrti2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* ZTRTI2 computes the inverse of a complex upper or lower triangular
-* matrix.
-*
-* This is the Level 2 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* Specifies whether the matrix A is upper or lower triangular.
-* = 'U': Upper triangular
-* = 'L': Lower triangular
-*
-* DIAG (input) CHARACTER*1
-* Specifies whether or not the matrix A is unit triangular.
-* = 'N': Non-unit triangular
-* = 'U': Unit triangular
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading n by n upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading n by n lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-*
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -k, the k-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrtri"></A>
- <H2>ztrtri</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.ztrtri( uplo, diag, a)
- or
- NumRu::Lapack.ztrtri # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )
-
-* Purpose
-* =======
-*
-* ZTRTRI computes the inverse of a complex upper or lower triangular
-* matrix A.
-*
-* This is the Level 3 BLAS version of the algorithm.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced. If DIAG = 'U', the
-* diagonal elements of A are also not referenced and are
-* assumed to be 1.
-* On exit, the (triangular) inverse of the original matrix, in
-* the same storage format.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-* matrix is singular and its inverse can not be computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrtrs"></A>
- <H2>ztrtrs</H2>
-
- <PRE>
-USAGE:
- info, b = NumRu::Lapack.ztrtrs( uplo, trans, diag, a, b)
- or
- NumRu::Lapack.ztrtrs # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )
-
-* Purpose
-* =======
-*
-* ZTRTRS solves a triangular system of the form
-*
-* A * X = B, A**T * X = B, or A**H * X = B,
-*
-* where A is a triangular matrix of order N, and B is an N-by-NRHS
-* matrix. A check is made to verify that A is nonsingular.
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations:
-* = 'N': A * X = B (No transpose)
-* = 'T': A**T * X = B (Transpose)
-* = 'C': A**H * X = B (Conjugate transpose)
-*
-* DIAG (input) CHARACTER*1
-* = 'N': A is non-unit triangular;
-* = 'U': A is unit triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* The triangular matrix A. If UPLO = 'U', the leading N-by-N
-* upper triangular part of the array A contains the upper
-* triangular matrix, and the strictly lower triangular part of
-* A is not referenced. If UPLO = 'L', the leading N-by-N lower
-* triangular part of the array A contains the lower triangular
-* matrix, and the strictly upper triangular part of A is not
-* referenced. If DIAG = 'U', the diagonal elements of A are
-* also not referenced and are assumed to be 1.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, if INFO = 0, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = i, the i-th diagonal element of A is zero,
-* indicating that the matrix is singular and the solutions
-* X have not been computed.
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrttf"></A>
- <H2>ztrttf</H2>
-
- <PRE>
-USAGE:
- arf, info = NumRu::Lapack.ztrttf( transr, uplo, a)
- or
- NumRu::Lapack.ztrttf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )
-
-* Purpose
-* =======
-*
-* ZTRTTF copies a triangular matrix A from standard full format (TR)
-* to rectangular full packed format (TF) .
-*
-
-* Arguments
-* =========
-*
-* TRANSR (input) CHARACTER*1
-* = 'N': ARF in Normal mode is wanted;
-* = 'C': ARF in Conjugate Transpose mode is wanted;
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension ( LDA, N )
-* On entry, the triangular matrix A. If UPLO = 'U', the
-* leading N-by-N upper triangular part of the array A contains
-* the upper triangular matrix, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of the array A contains
-* the lower triangular matrix, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the matrix A. LDA >= max(1,N).
-*
-* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A stored in
-* RFP format. For a further discussion see Notes below.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* We first consider Standard Packed Format when N is even.
-* We give an example where N = 6.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 05 00
-* 11 12 13 14 15 10 11
-* 22 23 24 25 20 21 22
-* 33 34 35 30 31 32 33
-* 44 45 40 41 42 43 44
-* 55 50 51 52 53 54 55
-*
-*
-* Let TRANSR = `N'. RFP holds AP as follows:
-* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(4:6,0:2) consists of
-* conjugate-transpose of the first three columns of AP upper.
-* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:2,0:2) consists of
-* conjugate-transpose of the last three columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N even and TRANSR = `N'.
-*
-* RFP A RFP A
-*
-* -- -- --
-* 03 04 05 33 43 53
-* -- --
-* 13 14 15 00 44 54
-* --
-* 23 24 25 10 11 55
-*
-* 33 34 35 20 21 22
-* --
-* 00 44 45 30 31 32
-* -- --
-* 01 11 55 40 41 42
-* -- -- --
-* 02 12 22 50 51 52
-*
-* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- -- --
-* 03 13 23 33 00 01 02 33 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 11 12 43 44 11 21 31 41 51
-* -- -- -- -- -- -- -- -- -- --
-* 05 15 25 35 45 55 22 53 54 55 22 32 42 52
-*
-*
-* We next consider Standard Packed Format when N is odd.
-* We give an example where N = 5.
-*
-* AP is Upper AP is Lower
-*
-* 00 01 02 03 04 00
-* 11 12 13 14 10 11
-* 22 23 24 20 21 22
-* 33 34 30 31 32 33
-* 44 40 41 42 43 44
-*
-*
-* Let TRANSR = `N'. RFP holds AP as follows:
-* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last
-* three columns of AP upper. The lower triangle A(3:4,0:1) consists of
-* conjugate-transpose of the first two columns of AP upper.
-* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first
-* three columns of AP lower. The upper triangle A(0:1,1:2) consists of
-* conjugate-transpose of the last two columns of AP lower.
-* To denote conjugate we place -- above the element. This covers the
-* case N odd and TRANSR = `N'.
-*
-* RFP A RFP A
-*
-* -- --
-* 02 03 04 00 33 43
-* --
-* 12 13 14 10 11 44
-*
-* 22 23 24 20 21 22
-* --
-* 00 33 34 30 31 32
-* -- --
-* 01 11 44 40 41 42
-*
-* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-
-* transpose of RFP A above. One therefore gets:
-*
-*
-* RFP A RFP A
-*
-* -- -- -- -- -- -- -- -- --
-* 02 12 22 00 01 00 10 20 30 40 50
-* -- -- -- -- -- -- -- -- --
-* 03 13 23 33 11 33 11 21 31 41 51
-* -- -- -- -- -- -- -- -- --
-* 04 14 24 34 44 43 44 22 32 42 52
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztrttp"></A>
- <H2>ztrttp</H2>
-
- <PRE>
-USAGE:
- ap, info = NumRu::Lapack.ztrttp( uplo, a)
- or
- NumRu::Lapack.ztrttp # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO )
-
-* Purpose
-* =======
-*
-* ZTRTTP copies a triangular matrix A from full format (TR) to standard
-* packed format (TP).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': A is upper triangular;
-* = 'L': A is lower triangular.
-*
-* N (input) INTEGER
-* The order of the matrices AP and A. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the triangular matrix A. If UPLO = 'U', the leading
-* N-by-N upper triangular part of A contains the upper
-* triangular part of the matrix A, and the strictly lower
-* triangular part of A is not referenced. If UPLO = 'L', the
-* leading N-by-N lower triangular part of A contains the lower
-* triangular part of the matrix A, and the strictly upper
-* triangular part of A is not referenced.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),
-* On exit, the upper or lower triangular matrix A, packed
-* columnwise in a linear array. The j-th column of A is stored
-* in the array AP as follows:
-* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
-* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/ztz.html b/doc/ztz.html
deleted file mode 100644
index 39faeca..0000000
--- a/doc/ztz.html
+++ /dev/null
@@ -1,216 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for trapezoidal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for trapezoidal matrix</H1>
- <UL>
- <LI><A HREF="#ztzrqf">ztzrqf</A> : </LI>
- <LI><A HREF="#ztzrzf">ztzrzf</A> : </LI>
- </UL>
-
- <A NAME="ztzrqf"></A>
- <H2>ztzrqf</H2>
-
- <PRE>
-USAGE:
- tau, info, a = NumRu::Lapack.ztzrqf( a)
- or
- NumRu::Lapack.ztzrqf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO )
-
-* Purpose
-* =======
-*
-* This routine is deprecated and has been replaced by routine ZTZRZF.
-*
-* ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
-* to upper triangular form by means of unitary transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N unitary matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* unitary matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), whose conjugate transpose is used to
-* introduce zeros into the (m - k + 1)th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="ztzrzf"></A>
- <H2>ztzrzf</H2>
-
- <PRE>
-USAGE:
- tau, work, info, a = NumRu::Lapack.ztzrzf( a, lwork)
- or
- NumRu::Lapack.ztzrzf # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
-* to upper triangular form by means of unitary transformations.
-*
-* The upper trapezoidal matrix A is factored as
-*
-* A = ( R 0 ) * Z,
-*
-* where Z is an N-by-N unitary matrix and R is an M-by-M upper
-* triangular matrix.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= M.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the leading M-by-N upper trapezoidal part of the
-* array A must contain the matrix to be factorized.
-* On exit, the leading M-by-M upper triangular part of A
-* contains the upper triangular matrix R, and elements M+1 to
-* N of the first M rows of A, with the array TAU, represent the
-* unitary matrix Z as a product of M elementary reflectors.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,M).
-*
-* TAU (output) COMPLEX*16 array, dimension (M)
-* The scalar factors of the elementary reflectors.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* The factorization is obtained by Householder's method. The kth
-* transformation matrix, Z( k ), which is used to introduce zeros into
-* the ( m - k + 1 )th row of A, is given in the form
-*
-* Z( k ) = ( I 0 ),
-* ( 0 T( k ) )
-*
-* where
-*
-* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
-* ( 0 )
-* ( z( k ) )
-*
-* tau is a scalar and z( k ) is an ( n - m ) element vector.
-* tau and z( k ) are chosen to annihilate the elements of the kth row
-* of X.
-*
-* The scalar tau is returned in the kth element of TAU and the vector
-* u( k ) in the kth row of A, such that the elements of z( k ) are
-* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
-* the upper triangular part of A.
-*
-* Z is given by
-*
-* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zun.html b/doc/zun.html
deleted file mode 100644
index 59887d7..0000000
--- a/doc/zun.html
+++ /dev/null
@@ -1,2630 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) unitary matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) unitary matrix</H1>
- <UL>
- <LI><A HREF="#zunbdb">zunbdb</A> : </LI>
- <LI><A HREF="#zuncsd">zuncsd</A> : </LI>
- <LI><A HREF="#zung2l">zung2l</A> : </LI>
- <LI><A HREF="#zung2r">zung2r</A> : </LI>
- <LI><A HREF="#zungbr">zungbr</A> : </LI>
- <LI><A HREF="#zunghr">zunghr</A> : </LI>
- <LI><A HREF="#zungl2">zungl2</A> : </LI>
- <LI><A HREF="#zunglq">zunglq</A> : </LI>
- <LI><A HREF="#zungql">zungql</A> : </LI>
- <LI><A HREF="#zungqr">zungqr</A> : </LI>
- <LI><A HREF="#zungr2">zungr2</A> : </LI>
- <LI><A HREF="#zungrq">zungrq</A> : </LI>
- <LI><A HREF="#zungtr">zungtr</A> : </LI>
- <LI><A HREF="#zunm2l">zunm2l</A> : </LI>
- <LI><A HREF="#zunm2r">zunm2r</A> : </LI>
- <LI><A HREF="#zunmbr">zunmbr</A> : </LI>
- <LI><A HREF="#zunmhr">zunmhr</A> : </LI>
- <LI><A HREF="#zunml2">zunml2</A> : </LI>
- <LI><A HREF="#zunmlq">zunmlq</A> : </LI>
- <LI><A HREF="#zunmql">zunmql</A> : </LI>
- <LI><A HREF="#zunmqr">zunmqr</A> : </LI>
- <LI><A HREF="#zunmr2">zunmr2</A> : </LI>
- <LI><A HREF="#zunmr3">zunmr3</A> : </LI>
- <LI><A HREF="#zunmrq">zunmrq</A> : </LI>
- <LI><A HREF="#zunmrz">zunmrz</A> : </LI>
- <LI><A HREF="#zunmtr">zunmtr</A> : </LI>
- </UL>
-
- <A NAME="zunbdb"></A>
- <H2>zunbdb</H2>
-
- <PRE>
-USAGE:
- theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.zunbdb( trans, signs, m, x11, x12, x21, x22, lwork)
- or
- NumRu::Lapack.zunbdb # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M
-* partitioned unitary matrix X:
-*
-* [ B11 | B12 0 0 ]
-* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H
-* X = [-----------] = [---------] [----------------] [---------] .
-* [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]
-* [ 0 | 0 0 I ]
-*
-* X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is
-* not the case, then X must be transposed and/or permuted. This can be
-* done in constant time using the TRANS and SIGNS options. See ZUNCSD
-* for details.)
-*
-* The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-
-* (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are
-* represented implicitly by Householder vectors.
-*
-* B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented
-* implicitly by angles THETA, PHI.
-*
-
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <=
-* MIN(P,M-P,M-Q).
-*
-* X11 (input/output) COMPLEX*16 array, dimension (LDX11,Q)
-* On entry, the top-left block of the unitary matrix to be
-* reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X11) specify reflectors for P1,
-* the rows of triu(X11,1) specify reflectors for Q1;
-* else TRANS = 'T', and
-* the rows of triu(X11) specify reflectors for P1,
-* the columns of tril(X11,-1) specify reflectors for Q1.
-*
-* LDX11 (input) INTEGER
-* The leading dimension of X11. If TRANS = 'N', then LDX11 >=
-* P; else LDX11 >= Q.
-*
-* X12 (input/output) COMPLEX*16 array, dimension (LDX12,M-Q)
-* On entry, the top-right block of the unitary matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X12) specify the first P reflectors for
-* Q2;
-* else TRANS = 'T', and
-* the columns of tril(X12) specify the first P reflectors
-* for Q2.
-*
-* LDX12 (input) INTEGER
-* The leading dimension of X12. If TRANS = 'N', then LDX12 >=
-* P; else LDX11 >= M-Q.
-*
-* X21 (input/output) COMPLEX*16 array, dimension (LDX21,Q)
-* On entry, the bottom-left block of the unitary matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the columns of tril(X21) specify reflectors for P2;
-* else TRANS = 'T', and
-* the rows of triu(X21) specify reflectors for P2.
-*
-* LDX21 (input) INTEGER
-* The leading dimension of X21. If TRANS = 'N', then LDX21 >=
-* M-P; else LDX21 >= Q.
-*
-* X22 (input/output) COMPLEX*16 array, dimension (LDX22,M-Q)
-* On entry, the bottom-right block of the unitary matrix to
-* be reduced. On exit, the form depends on TRANS:
-* If TRANS = 'N', then
-* the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last
-* M-P-Q reflectors for Q2,
-* else TRANS = 'T', and
-* the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last
-* M-P-Q reflectors for P2.
-*
-* LDX22 (input) INTEGER
-* The leading dimension of X22. If TRANS = 'N', then LDX22 >=
-* M-P; else LDX22 >= M-Q.
-*
-* THETA (output) DOUBLE PRECISION array, dimension (Q)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* PHI (output) DOUBLE PRECISION array, dimension (Q-1)
-* The entries of the bidiagonal blocks B11, B12, B21, B22 can
-* be computed from the angles THETA and PHI. See Further
-* Details.
-*
-* TAUP1 (output) COMPLEX*16 array, dimension (P)
-* The scalar factors of the elementary reflectors that define
-* P1.
-*
-* TAUP2 (output) COMPLEX*16 array, dimension (M-P)
-* The scalar factors of the elementary reflectors that define
-* P2.
-*
-* TAUQ1 (output) COMPLEX*16 array, dimension (Q)
-* The scalar factors of the elementary reflectors that define
-* Q1.
-*
-* TAUQ2 (output) COMPLEX*16 array, dimension (M-Q)
-* The scalar factors of the elementary reflectors that define
-* Q2.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (LWORK)
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= M-Q.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-*
-
-* Further Details
-* ===============
-*
-* The bidiagonal blocks B11, B12, B21, and B22 are represented
-* implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,
-* PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are
-* lower bidiagonal. Every entry in each bidiagonal band is a product
-* of a sine or cosine of a THETA with a sine or cosine of a PHI. See
-* [1] or ZUNCSD for details.
-*
-* P1, P2, Q1, and Q2 are represented as products of elementary
-* reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2
-* using ZUNGQR and ZUNGLQ.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-* ====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zuncsd"></A>
- <H2>zuncsd</H2>
-
- <PRE>
-USAGE:
- theta, u1, u2, v1t, v2t, info = NumRu::Lapack.zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, ldu1, ldu2, ldv1t, ldv2t, lwork, lrwork)
- or
- NumRu::Lapack.zuncsd # print help
-
-
-FORTRAN MANUAL
- RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNCSD computes the CS decomposition of an M-by-M partitioned
-* unitary matrix X:
-*
-* [ I 0 0 | 0 0 0 ]
-* [ 0 C 0 | 0 -S 0 ]
-* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H
-* X = [-----------] = [---------] [---------------------] [---------] .
-* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]
-* [ 0 S 0 | 0 C 0 ]
-* [ 0 0 I | 0 0 0 ]
-*
-* X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
-* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
-* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
-* which R = MIN(P,M-P,Q,M-Q).
-*
-
-* Arguments
-* =========
-*
-* JOBU1 (input) CHARACTER
-* = 'Y': U1 is computed;
-* otherwise: U1 is not computed.
-*
-* JOBU2 (input) CHARACTER
-* = 'Y': U2 is computed;
-* otherwise: U2 is not computed.
-*
-* JOBV1T (input) CHARACTER
-* = 'Y': V1T is computed;
-* otherwise: V1T is not computed.
-*
-* JOBV2T (input) CHARACTER
-* = 'Y': V2T is computed;
-* otherwise: V2T is not computed.
-*
-* TRANS (input) CHARACTER
-* = 'T': X, U1, U2, V1T, and V2T are stored in row-major
-* order;
-* otherwise: X, U1, U2, V1T, and V2T are stored in column-
-* major order.
-*
-* SIGNS (input) CHARACTER
-* = 'O': The lower-left block is made nonpositive (the
-* "other" convention);
-* otherwise: The upper-right block is made nonpositive (the
-* "default" convention).
-*
-* M (input) INTEGER
-* The number of rows and columns in X.
-*
-* P (input) INTEGER
-* The number of rows in X11 and X12. 0 <= P <= M.
-*
-* Q (input) INTEGER
-* The number of columns in X11 and X21. 0 <= Q <= M.
-*
-* X (input/workspace) COMPLEX*16 array, dimension (LDX,M)
-* On entry, the unitary matrix whose CSD is desired.
-*
-* LDX (input) INTEGER
-* The leading dimension of X. LDX >= MAX(1,M).
-*
-* THETA (output) DOUBLE PRECISION array, dimension (R), in which R =
-* MIN(P,M-P,Q,M-Q).
-* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
-* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
-*
-* U1 (output) COMPLEX*16 array, dimension (P)
-* If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
-*
-* LDU1 (input) INTEGER
-* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
-* MAX(1,P).
-*
-* U2 (output) COMPLEX*16 array, dimension (M-P)
-* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
-* matrix U2.
-*
-* LDU2 (input) INTEGER
-* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
-* MAX(1,M-P).
-*
-* V1T (output) COMPLEX*16 array, dimension (Q)
-* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
-* matrix V1**H.
-*
-* LDV1T (input) INTEGER
-* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
-* MAX(1,Q).
-*
-* V2T (output) COMPLEX*16 array, dimension (M-Q)
-* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary
-* matrix V2**H.
-*
-* LDV2T (input) INTEGER
-* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=
-* MAX(1,M-Q).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the work array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* RWORK (workspace) DOUBLE PRECISION array, dimension MAX(1,LRWORK)
-* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
-* If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
-* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
-* define the matrix in intermediate bidiagonal-block form
-* remaining after nonconvergence. INFO specifies the number
-* of nonzero PHI's.
-*
-* LRWORK (input) INTEGER
-* The dimension of the array RWORK.
-*
-* If LRWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the RWORK array, returns
-* this value as the first entry of the work array, and no error
-* message related to LRWORK is issued by XERBLA.
-*
-* IWORK (workspace) INTEGER array, dimension (M-Q)
-*
-* INFO (output) INTEGER
-* = 0: successful exit.
-* < 0: if INFO = -i, the i-th argument had an illegal value.
-* > 0: ZBBCSD did not converge. See the description of RWORK
-* above for details.
-*
-* Reference
-* =========
-*
-* [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
-* Algorithms, 50(1):33-65, 2009.
-*
-
-* ===================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zung2l"></A>
- <H2>zung2l</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zung2l( m, a, tau)
- or
- NumRu::Lapack.zung2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNG2L generates an m by n complex matrix Q with orthonormal columns,
-* which is defined as the last n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by ZGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by ZGEQLF in the last k columns of its array
-* argument A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQLF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zung2r"></A>
- <H2>zung2r</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zung2r( m, a, tau)
- or
- NumRu::Lapack.zung2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNG2R generates an m by n complex matrix Q with orthonormal columns,
-* which is defined as the first n columns of a product of k elementary
-* reflectors of order m
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by ZGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by ZGEQRF in the first k columns of its array
-* argument A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQRF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zungbr"></A>
- <H2>zungbr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zungbr( vect, m, k, a, tau, lwork)
- or
- NumRu::Lapack.zungbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGBR generates one of the complex unitary matrices Q or P**H
-* determined by ZGEBRD when reducing a complex matrix A to bidiagonal
-* form: A = Q * B * P**H. Q and P**H are defined as products of
-* elementary reflectors H(i) or G(i) respectively.
-*
-* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
-* is of order M:
-* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n
-* columns of Q, where m >= n >= k;
-* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an
-* M-by-M matrix.
-*
-* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H
-* is of order N:
-* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m
-* rows of P**H, where n >= m >= k;
-* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as
-* an N-by-N matrix.
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* Specifies whether the matrix Q or the matrix P**H is
-* required, as defined in the transformation applied by ZGEBRD:
-* = 'Q': generate Q;
-* = 'P': generate P**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q or P**H to be returned.
-* M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q or P**H to be returned.
-* N >= 0.
-* If VECT = 'Q', M >= N >= min(M,K);
-* if VECT = 'P', N >= M >= min(N,K).
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original M-by-K
-* matrix reduced by ZGEBRD.
-* If VECT = 'P', the number of rows in the original K-by-N
-* matrix reduced by ZGEBRD.
-* K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by ZGEBRD.
-* On exit, the M-by-N matrix Q or P**H.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= M.
-*
-* TAU (input) COMPLEX*16 array, dimension
-* (min(M,K)) if VECT = 'Q'
-* (min(N,K)) if VECT = 'P'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i), which determines Q or P**H, as
-* returned by ZGEBRD in its array argument TAUQ or TAUP.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,min(M,N)).
-* For optimum performance LWORK >= min(M,N)*NB, where NB
-* is the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunghr"></A>
- <H2>zunghr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zunghr( ilo, ihi, a, tau, lwork)
- or
- NumRu::Lapack.zunghr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGHR generates a complex unitary matrix Q which is defined as the
-* product of IHI-ILO elementary reflectors of order N, as returned by
-* ZGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of ZGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by ZGEHRD.
-* On exit, the N-by-N unitary matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,N).
-*
-* TAU (input) COMPLEX*16 array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEHRD.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= IHI-ILO.
-* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zungl2"></A>
- <H2>zungl2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zungl2( a, tau)
- or
- NumRu::Lapack.zungl2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,
-* which is defined as the first m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by ZGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by ZGELQF in the first k rows of its array argument A.
-* On exit, the m by n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGELQF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunglq"></A>
- <H2>zunglq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zunglq( m, a, tau, lwork)
- or
- NumRu::Lapack.zunglq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
-* which is defined as the first M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by ZGELQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the i-th row must contain the vector which defines
-* the elementary reflector H(i), for i = 1,2,...,k, as returned
-* by ZGELQF in the first k rows of its array argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGELQF.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit;
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zungql"></A>
- <H2>zungql</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zungql( m, a, tau, lwork)
- or
- NumRu::Lapack.zungql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,
-* which is defined as the last N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by ZGEQLF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the (n-k+i)-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by ZGEQLF in the last k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQLF.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zungqr"></A>
- <H2>zungqr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zungqr( m, a, tau, lwork)
- or
- NumRu::Lapack.zungqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,
-* which is defined as the first N columns of a product of K elementary
-* reflectors of order M
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by ZGEQRF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. M >= N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. N >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the i-th column must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by ZGEQRF in the first k columns of its array
-* argument A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQRF.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,N).
-* For optimum performance LWORK >= N*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zungr2"></A>
- <H2>zungr2</H2>
-
- <PRE>
-USAGE:
- info, a = NumRu::Lapack.zungr2( a, tau)
- or
- NumRu::Lapack.zungr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,
-* which is defined as the last m rows of a product of k elementary
-* reflectors of order n
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by ZGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by ZGERQF in the last k rows of its array argument
-* A.
-* On exit, the m-by-n matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGERQF.
-*
-* WORK (workspace) COMPLEX*16 array, dimension (M)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zungrq"></A>
- <H2>zungrq</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zungrq( m, a, tau, lwork)
- or
- NumRu::Lapack.zungrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,
-* which is defined as the last M rows of a product of K elementary
-* reflectors of order N
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by ZGERQF.
-*
-
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix Q. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix Q. N >= M.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines the
-* matrix Q. M >= K >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the (m-k+i)-th row must contain the vector which
-* defines the elementary reflector H(i), for i = 1,2,...,k, as
-* returned by ZGERQF in the last k rows of its array argument
-* A.
-* On exit, the M-by-N matrix Q.
-*
-* LDA (input) INTEGER
-* The first dimension of the array A. LDA >= max(1,M).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGERQF.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= max(1,M).
-* For optimum performance LWORK >= M*NB, where NB is the
-* optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument has an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zungtr"></A>
- <H2>zungtr</H2>
-
- <PRE>
-USAGE:
- work, info, a = NumRu::Lapack.zungtr( uplo, a, tau, lwork)
- or
- NumRu::Lapack.zungtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNGTR generates a complex unitary matrix Q which is defined as the
-* product of n-1 elementary reflectors of order N, as returned by
-* ZHETRD:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from ZHETRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from ZHETRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* A (input/output) COMPLEX*16 array, dimension (LDA,N)
-* On entry, the vectors which define the elementary reflectors,
-* as returned by ZHETRD.
-* On exit, the N-by-N unitary matrix Q.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= N.
-*
-* TAU (input) COMPLEX*16 array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZHETRD.
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK. LWORK >= N-1.
-* For optimum performance LWORK >= (N-1)*NB, where NB is
-* the optimal blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunm2l"></A>
- <H2>zunm2l</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.zunm2l( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.zunm2l # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNM2L overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQLF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX*16 array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunm2r"></A>
- <H2>zunm2r</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.zunm2r( side, trans, m, a, tau, c)
- or
- NumRu::Lapack.zunm2r # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNM2R overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQRF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX*16 array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmbr"></A>
- <H2>zunmbr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmbr( vect, side, trans, m, k, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmbr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C
-* with
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': P * C C * P
-* TRANS = 'C': P**H * C C * P**H
-*
-* Here Q and P**H are the unitary matrices determined by ZGEBRD when
-* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q
-* and P**H are defined as products of elementary reflectors H(i) and
-* G(i) respectively.
-*
-* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
-* order of the unitary matrix Q or P**H that is applied.
-*
-* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
-* if nq >= k, Q = H(1) H(2) . . . H(k);
-* if nq < k, Q = H(1) H(2) . . . H(nq-1).
-*
-* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
-* if k < nq, P = G(1) G(2) . . . G(k);
-* if k >= nq, P = G(1) G(2) . . . G(nq-1).
-*
-
-* Arguments
-* =========
-*
-* VECT (input) CHARACTER*1
-* = 'Q': apply Q or Q**H;
-* = 'P': apply P or P**H.
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q, Q**H, P or P**H from the Left;
-* = 'R': apply Q, Q**H, P or P**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q or P;
-* = 'C': Conjugate transpose, apply Q**H or P**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* If VECT = 'Q', the number of columns in the original
-* matrix reduced by ZGEBRD.
-* If VECT = 'P', the number of rows in the original
-* matrix reduced by ZGEBRD.
-* K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,min(nq,K)) if VECT = 'Q'
-* (LDA,nq) if VECT = 'P'
-* The vectors which define the elementary reflectors H(i) and
-* G(i), whose products determine the matrices Q and P, as
-* returned by ZGEBRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If VECT = 'Q', LDA >= max(1,nq);
-* if VECT = 'P', LDA >= max(1,min(nq,K)).
-*
-* TAU (input) COMPLEX*16 array, dimension (min(nq,K))
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i) or G(i) which determines Q or P, as returned
-* by ZGEBRD in the array argument TAUQ or TAUP.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q
-* or P*C or P**H*C or C*P or C*P**H.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M);
-* if N = 0 or M = 0, LWORK >= 1.
-* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',
-* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the
-* optimal blocksize. (NB = 0 if M = 0 or N = 0.)
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
- CHARACTER TRANST
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZUNMLQ, ZUNMQR
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmhr"></A>
- <H2>zunmhr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmhr( side, trans, ilo, ihi, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmhr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMHR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* IHI-ILO elementary reflectors, as returned by ZGEHRD:
-*
-* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q**H (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* ILO (input) INTEGER
-* IHI (input) INTEGER
-* ILO and IHI must have the same values as in the previous call
-* of ZGEHRD. Q is equal to the unit matrix except in the
-* submatrix Q(ilo+1:ihi,ilo+1:ihi).
-* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
-* ILO = 1 and IHI = 0, if M = 0;
-* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
-* ILO = 1 and IHI = 0, if N = 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by ZGEHRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) COMPLEX*16 array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEHRD.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZUNMQR
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunml2"></A>
- <H2>zunml2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.zunml2( side, trans, a, tau, c)
- or
- NumRu::Lapack.zunml2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNML2 overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGELQF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX*16 array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmlq"></A>
- <H2>zunmlq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmlq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmlq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMLQ overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k)' . . . H(2)' H(1)'
-*
-* as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGELQF in the first k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGELQF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmql"></A>
- <H2>zunmql</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmql( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmql # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMQL overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(k) . . . H(2) H(1)
-*
-* as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGEQLF in the last k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQLF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmqr"></A>
- <H2>zunmqr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmqr( side, trans, m, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmqr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMQR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension (LDA,K)
-* The i-th column must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGEQRF in the first k columns of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* If SIDE = 'L', LDA >= max(1,M);
-* if SIDE = 'R', LDA >= max(1,N).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGEQRF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmr2"></A>
- <H2>zunmr2</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.zunmr2( side, trans, a, tau, c)
- or
- NumRu::Lapack.zunmr2 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMR2 overwrites the general complex m-by-n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGERQF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX*16 array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmr3"></A>
- <H2>zunmr3</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.zunmr3( side, trans, l, a, tau, c)
- or
- NumRu::Lapack.zunmr3 # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMR3 overwrites the general complex m by n matrix C with
-*
-* Q * C if SIDE = 'L' and TRANS = 'N', or
-*
-* Q'* C if SIDE = 'L' and TRANS = 'C', or
-*
-* C * Q if SIDE = 'R' and TRANS = 'N', or
-*
-* C * Q' if SIDE = 'R' and TRANS = 'C',
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q' from the Left
-* = 'R': apply Q or Q' from the Right
-*
-* TRANS (input) CHARACTER*1
-* = 'N': apply Q (No transpose)
-* = 'C': apply Q' (Conjugate transpose)
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZTZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZTZRZF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the m-by-n matrix C.
-* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX*16 array, dimension
-* (N) if SIDE = 'L',
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, NOTRAN
- INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
- COMPLEX*16 TAUI
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZLARZ
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC DCONJG, MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmrq"></A>
- <H2>zunmrq</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmrq( side, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmrq # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMRQ overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1)' H(2)' . . . H(k)'
-*
-* as returned by ZGERQF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZGERQF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZGERQF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmrz"></A>
- <H2>zunmrz</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmrz( side, trans, l, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmrz # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMRZ overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix defined as the product of k
-* elementary reflectors
-*
-* Q = H(1) H(2) . . . H(k)
-*
-* as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N
-* if SIDE = 'R'.
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* K (input) INTEGER
-* The number of elementary reflectors whose product defines
-* the matrix Q.
-* If SIDE = 'L', M >= K >= 0;
-* if SIDE = 'R', N >= K >= 0.
-*
-* L (input) INTEGER
-* The number of columns of the matrix A containing
-* the meaningful part of the Householder reflectors.
-* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L',
-* (LDA,N) if SIDE = 'R'
-* The i-th row must contain the vector which defines the
-* elementary reflector H(i), for i = 1,2,...,k, as returned by
-* ZTZRZF in the last k rows of its array argument A.
-* A is modified by the routine but restored on exit.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A. LDA >= max(1,K).
-*
-* TAU (input) COMPLEX*16 array, dimension (K)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZTZRZF.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* Further Details
-* ===============
-*
-* Based on contributions by
-* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zunmtr"></A>
- <H2>zunmtr</H2>
-
- <PRE>
-USAGE:
- work, info, c = NumRu::Lapack.zunmtr( side, uplo, trans, a, tau, c, lwork)
- or
- NumRu::Lapack.zunmtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUNMTR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by ZHETRD:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangle of A contains elementary reflectors
-* from ZHETRD;
-* = 'L': Lower triangle of A contains elementary reflectors
-* from ZHETRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* A (input) COMPLEX*16 array, dimension
-* (LDA,M) if SIDE = 'L'
-* (LDA,N) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by ZHETRD.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
-*
-* TAU (input) COMPLEX*16 array, dimension
-* (M-1) if SIDE = 'L'
-* (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZHETRD.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))
-* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
-*
-* LWORK (input) INTEGER
-* The dimension of the array WORK.
-* If SIDE = 'L', LWORK >= max(1,N);
-* if SIDE = 'R', LWORK >= max(1,M).
-* For optimum performance LWORK >= N*NB if SIDE = 'L', and
-* LWORK >=M*NB if SIDE = 'R', where NB is the optimal
-* blocksize.
-*
-* If LWORK = -1, then a workspace query is assumed; the routine
-* only calculates the optimal size of the WORK array, returns
-* this value as the first entry of the WORK array, and no error
-* message related to LWORK is issued by XERBLA.
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL LEFT, LQUERY, UPPER
- INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- INTEGER ILAENV
- EXTERNAL LSAME, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL XERBLA, ZUNMQL, ZUNMQR
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/doc/zup.html b/doc/zup.html
deleted file mode 100644
index 03533ba..0000000
--- a/doc/zup.html
+++ /dev/null
@@ -1,171 +0,0 @@
-<HTML>
- <HEAD>
- <TITLE>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) unitary, packed storageBDbidiagonal matrix</TITLE>
- </HEAD>
- <BODY>
- <A NAME="top"></A>
- <H1>COMPLEX*16 or DOUBLE COMPLEX routines for (complex) unitary, packed storageBDbidiagonal matrix</H1>
- <UL>
- <LI><A HREF="#zupgtr">zupgtr</A> : </LI>
- <LI><A HREF="#zupmtr">zupmtr</A> : </LI>
- </UL>
-
- <A NAME="zupgtr"></A>
- <H2>zupgtr</H2>
-
- <PRE>
-USAGE:
- q, info = NumRu::Lapack.zupgtr( uplo, ap, tau)
- or
- NumRu::Lapack.zupgtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUPGTR generates a complex unitary matrix Q which is defined as the
-* product of n-1 elementary reflectors H(i) of order n, as returned by
-* ZHPTRD using packed storage:
-*
-* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
-*
-
-* Arguments
-* =========
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to ZHPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to ZHPTRD.
-*
-* N (input) INTEGER
-* The order of the matrix Q. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)
-* The vectors which define the elementary reflectors, as
-* returned by ZHPTRD.
-*
-* TAU (input) COMPLEX*16 array, dimension (N-1)
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZHPTRD.
-*
-* Q (output) COMPLEX*16 array, dimension (LDQ,N)
-* The N-by-N unitary matrix Q.
-*
-* LDQ (input) INTEGER
-* The leading dimension of the array Q. LDQ >= max(1,N).
-*
-* WORK (workspace) COMPLEX*16 array, dimension (N-1)
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <A NAME="zupmtr"></A>
- <H2>zupmtr</H2>
-
- <PRE>
-USAGE:
- info, c = NumRu::Lapack.zupmtr( side, uplo, trans, m, ap, tau, c)
- or
- NumRu::Lapack.zupmtr # print help
-
-
-FORTRAN MANUAL
- SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )
-
-* Purpose
-* =======
-*
-* ZUPMTR overwrites the general complex M-by-N matrix C with
-*
-* SIDE = 'L' SIDE = 'R'
-* TRANS = 'N': Q * C C * Q
-* TRANS = 'C': Q**H * C C * Q**H
-*
-* where Q is a complex unitary matrix of order nq, with nq = m if
-* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
-* nq-1 elementary reflectors, as returned by ZHPTRD using packed
-* storage:
-*
-* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
-*
-* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
-*
-
-* Arguments
-* =========
-*
-* SIDE (input) CHARACTER*1
-* = 'L': apply Q or Q**H from the Left;
-* = 'R': apply Q or Q**H from the Right.
-*
-* UPLO (input) CHARACTER*1
-* = 'U': Upper triangular packed storage used in previous
-* call to ZHPTRD;
-* = 'L': Lower triangular packed storage used in previous
-* call to ZHPTRD.
-*
-* TRANS (input) CHARACTER*1
-* = 'N': No transpose, apply Q;
-* = 'C': Conjugate transpose, apply Q**H.
-*
-* M (input) INTEGER
-* The number of rows of the matrix C. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix C. N >= 0.
-*
-* AP (input) COMPLEX*16 array, dimension
-* (M*(M+1)/2) if SIDE = 'L'
-* (N*(N+1)/2) if SIDE = 'R'
-* The vectors which define the elementary reflectors, as
-* returned by ZHPTRD. AP is modified by the routine but
-* restored on exit.
-*
-* TAU (input) COMPLEX*16 array, dimension (M-1) if SIDE = 'L'
-* or (N-1) if SIDE = 'R'
-* TAU(i) must contain the scalar factor of the elementary
-* reflector H(i), as returned by ZHPTRD.
-*
-* C (input/output) COMPLEX*16 array, dimension (LDC,N)
-* On entry, the M-by-N matrix C.
-* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
-*
-* LDC (input) INTEGER
-* The leading dimension of the array C. LDC >= max(1,M).
-*
-* WORK (workspace) COMPLEX*16 array, dimension
-* (N) if SIDE = 'L'
-* (M) if SIDE = 'R'
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-
-* =====================================================================
-*
-
-
- </PRE>
- <A HREF="#top">go to the page top</A>
-
- <HR />
- <A HREF="z.html">back to matrix types</A>
- </BODY>
-</HTML>
diff --git a/dopgtr.c b/dopgtr.c
deleted file mode 100644
index b7fd3a5..0000000
--- a/dopgtr.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#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
-rb_dopgtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_info;
- integer info;
- doublereal *work;
-
- integer ldap;
- integer ldtau;
- integer ldq;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, info = NumRu::Lapack.dopgtr( uplo, ap, tau)\n or\n NumRu::Lapack.dopgtr # print 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_tau = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- ldtau = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ldtau+1;
- ldq = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- work = ALLOC_N(doublereal, (n-1));
-
- dopgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_q, rb_info);
-}
-
-void
-init_lapack_dopgtr(VALUE mLapack){
- rb_define_module_function(mLapack, "dopgtr", rb_dopgtr, -1);
-}
diff --git a/dopmtr.c b/dopmtr.c
deleted file mode 100644
index fda676f..0000000
--- a/dopmtr.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#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
-rb_dopmtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, c)\n or\n NumRu::Lapack.dopmtr # print 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_ap = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (m*(m+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_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);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_dopmtr(VALUE mLapack){
- rb_define_module_function(mLapack, "dopmtr", rb_dopmtr, -1);
-}
diff --git a/dorbdb.c b/dorbdb.c
deleted file mode 100644
index dc9d2a1..0000000
--- a/dorbdb.c
+++ /dev/null
@@ -1,216 +0,0 @@
-#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
-rb_dorbdb(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- doublereal *x11;
- VALUE rb_x12;
- doublereal *x12;
- VALUE rb_x21;
- doublereal *x21;
- VALUE rb_x22;
- doublereal *x22;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_theta;
- doublereal *theta;
- VALUE rb_phi;
- doublereal *phi;
- VALUE rb_taup1;
- doublereal *taup1;
- VALUE rb_taup2;
- doublereal *taup2;
- VALUE rb_tauq1;
- doublereal *tauq1;
- VALUE rb_tauq2;
- doublereal *tauq2;
- VALUE rb_info;
- integer info;
- VALUE rb_x11_out__;
- doublereal *x11_out__;
- VALUE rb_x12_out__;
- doublereal *x12_out__;
- VALUE rb_x21_out__;
- doublereal *x21_out__;
- VALUE rb_x22_out__;
- doublereal *x22_out__;
- doublereal *work;
-
- integer ldx11;
- integer q;
- integer ldx12;
- integer ldx21;
- integer ldx22;
- integer p;
-
- if (argc == 0) {
- 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)\n or\n NumRu::Lapack.dorbdb # print 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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_signs = argv[1];
- rb_m = argv[2];
- rb_x11 = argv[3];
- rb_x12 = argv[4];
- rb_x21 = argv[5];
- rb_x22 = argv[6];
- rb_lwork = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- signs = StringValueCStr(rb_signs)[0];
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- ldx21 = NA_SHAPE0(rb_x21);
- if (ldx21 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x21 must be %d", p);
- p = ldx21;
- if (NA_TYPE(rb_x21) != NA_DFLOAT)
- rb_x21 = na_change_type(rb_x21, NA_DFLOAT);
- x21 = NA_PTR_TYPE(rb_x21, doublereal*);
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- ldx11 = NA_SHAPE0(rb_x11);
- if (ldx11 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x11 must be %d", p);
- p = ldx11;
- if (NA_TYPE(rb_x11) != NA_DFLOAT)
- rb_x11 = na_change_type(rb_x11, NA_DFLOAT);
- x11 = NA_PTR_TYPE(rb_x11, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- ldx22 = NA_SHAPE0(rb_x22);
- if (ldx22 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be %d", p);
- p = ldx22;
- if (NA_TYPE(rb_x22) != NA_DFLOAT)
- rb_x22 = na_change_type(rb_x22, NA_DFLOAT);
- x22 = NA_PTR_TYPE(rb_x22, doublereal*);
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- ldx12 = NA_SHAPE0(rb_x12);
- if (ldx12 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be %d", p);
- p = ldx12;
- if (NA_TYPE(rb_x12) != NA_DFLOAT)
- rb_x12 = na_change_type(rb_x12, NA_DFLOAT);
- x12 = NA_PTR_TYPE(rb_x12, doublereal*);
- ldx12 = p;
- ldx22 = p;
- ldx21 = p;
- ldx11 = p;
- {
- int shape[1];
- shape[0] = q;
- rb_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- phi = NA_PTR_TYPE(rb_phi, doublereal*);
- {
- int shape[1];
- shape[0] = p;
- rb_taup1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taup1 = NA_PTR_TYPE(rb_taup1, doublereal*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_taup2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- taup2 = NA_PTR_TYPE(rb_taup2, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_tauq1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tauq1 = NA_PTR_TYPE(rb_tauq1, doublereal*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_tauq2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tauq2 = NA_PTR_TYPE(rb_tauq2, doublereal*);
- {
- int shape[2];
- shape[0] = ldx11;
- shape[1] = q;
- rb_x11_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x11_out__ = NA_PTR_TYPE(rb_x11_out__, doublereal*);
- MEMCPY(x11_out__, x11, doublereal, NA_TOTAL(rb_x11));
- rb_x11 = rb_x11_out__;
- x11 = x11_out__;
- {
- int shape[2];
- shape[0] = ldx12;
- shape[1] = m-q;
- rb_x12_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x12_out__ = NA_PTR_TYPE(rb_x12_out__, doublereal*);
- MEMCPY(x12_out__, x12, doublereal, NA_TOTAL(rb_x12));
- rb_x12 = rb_x12_out__;
- x12 = x12_out__;
- {
- int shape[2];
- shape[0] = ldx21;
- shape[1] = q;
- rb_x21_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x21_out__ = NA_PTR_TYPE(rb_x21_out__, doublereal*);
- MEMCPY(x21_out__, x21, doublereal, NA_TOTAL(rb_x21));
- rb_x21 = rb_x21_out__;
- x21 = x21_out__;
- {
- int shape[2];
- shape[0] = ldx22;
- shape[1] = m-q;
- rb_x22_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x22_out__ = NA_PTR_TYPE(rb_x22_out__, doublereal*);
- MEMCPY(x22_out__, x22, doublereal, NA_TOTAL(rb_x22));
- rb_x22 = rb_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);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_theta, rb_phi, rb_taup1, rb_taup2, rb_tauq1, rb_tauq2, rb_info, rb_x11, rb_x12, rb_x21, rb_x22);
-}
-
-void
-init_lapack_dorbdb(VALUE mLapack){
- rb_define_module_function(mLapack, "dorbdb", rb_dorbdb, -1);
-}
diff --git a/dorcsd.c b/dorcsd.c
deleted file mode 100644
index 03074be..0000000
--- a/dorcsd.c
+++ /dev/null
@@ -1,195 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, 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 *u1, integer *ldu1, doublereal *u2, integer *ldu2, doublereal *v1t, integer *ldv1t, doublereal *v2t, integer *ldv2t, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dorcsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- doublereal *x11;
- VALUE rb_x12;
- doublereal *x12;
- VALUE rb_x21;
- doublereal *x21;
- VALUE rb_x22;
- doublereal *x22;
- VALUE rb_ldu1;
- integer ldu1;
- VALUE rb_ldu2;
- integer ldu2;
- VALUE rb_ldv1t;
- integer ldv1t;
- VALUE rb_ldv2t;
- integer ldv2t;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_theta;
- doublereal *theta;
- VALUE rb_u1;
- doublereal *u1;
- VALUE rb_u2;
- doublereal *u2;
- VALUE rb_v1t;
- doublereal *v1t;
- VALUE rb_v2t;
- doublereal *v2t;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldx11;
- integer q;
- integer ldx12;
- integer ldx21;
- integer ldx22;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.dorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, ldu1, ldu2, ldv1t, ldv2t, lwork)\n or\n NumRu::Lapack.dorcsd # print help\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORCSD computes the CS decomposition of an M-by-M partitioned\n* orthogonal matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) DOUBLE PRECISION array, dimension (LDX,M)\n* On entry, the orthogonal matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) DOUBLE PRECISION array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) DOUBLE PRECISION array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) DOUBLE PRECISION array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) DOUBLE PRECISION array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n* matrix V1**T.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) DOUBLE PRECISION array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n* matrix V2**T.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n* If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\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-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: DBBCSD did not converge. See the description of WORK\n* above for details.\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\n");
- return Qnil;
- }
- if (argc != 16)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_signs = argv[5];
- rb_m = argv[6];
- rb_x11 = argv[7];
- rb_x12 = argv[8];
- rb_x21 = argv[9];
- rb_x22 = argv[10];
- rb_ldu1 = argv[11];
- rb_ldu2 = argv[12];
- rb_ldv1t = argv[13];
- rb_ldv2t = argv[14];
- rb_lwork = argv[15];
-
- trans = StringValueCStr(rb_trans)[0];
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- lwork = NUM2INT(rb_lwork);
- signs = StringValueCStr(rb_signs)[0];
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- ldx21 = NA_SHAPE0(rb_x21);
- if (ldx21 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x21 must be %d", p);
- p = ldx21;
- if (NA_TYPE(rb_x21) != NA_DFLOAT)
- rb_x21 = na_change_type(rb_x21, NA_DFLOAT);
- x21 = NA_PTR_TYPE(rb_x21, doublereal*);
- jobu1 = StringValueCStr(rb_jobu1)[0];
- jobu2 = StringValueCStr(rb_jobu2)[0];
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- ldx11 = NA_SHAPE0(rb_x11);
- if (ldx11 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x11 must be %d", p);
- p = ldx11;
- if (NA_TYPE(rb_x11) != NA_DFLOAT)
- rb_x11 = na_change_type(rb_x11, NA_DFLOAT);
- x11 = NA_PTR_TYPE(rb_x11, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- ldx22 = NA_SHAPE0(rb_x22);
- if (ldx22 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be %d", p);
- p = ldx22;
- if (NA_TYPE(rb_x22) != NA_DFLOAT)
- rb_x22 = na_change_type(rb_x22, NA_DFLOAT);
- x22 = NA_PTR_TYPE(rb_x22, doublereal*);
- ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
- ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- ldx12 = NA_SHAPE0(rb_x12);
- if (ldx12 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be %d", p);
- p = ldx12;
- if (NA_TYPE(rb_x12) != NA_DFLOAT)
- rb_x12 = na_change_type(rb_x12, NA_DFLOAT);
- x12 = NA_PTR_TYPE(rb_x12, doublereal*);
- ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
- ldx12 = p;
- ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
- ldx22 = p;
- ldx21 = p;
- ldx11 = p;
- {
- int shape[1];
- shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
- rb_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, doublereal*);
- {
- int shape[1];
- shape[0] = p;
- rb_u1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- u1 = NA_PTR_TYPE(rb_u1, doublereal*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_u2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- u2 = NA_PTR_TYPE(rb_u2, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_v1t = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- v1t = NA_PTR_TYPE(rb_v1t, doublereal*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_v2t = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- v2t = NA_PTR_TYPE(rb_v2t, doublereal*);
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
- iwork = ALLOC_N(integer, (m-q));
-
- dorcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t, rb_info);
-}
-
-void
-init_lapack_dorcsd(VALUE mLapack){
- rb_define_module_function(mLapack, "dorcsd", rb_dorcsd, -1);
-}
diff --git a/dorg2l.c b/dorg2l.c
deleted file mode 100644
index 6538658..0000000
--- a/dorg2l.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorg2l_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dorg2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dorg2l( m, a, tau)\n or\n NumRu::Lapack.dorg2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORG2L generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n));
-
- dorg2l_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dorg2l(VALUE mLapack){
- rb_define_module_function(mLapack, "dorg2l", rb_dorg2l, -1);
-}
diff --git a/dorg2r.c b/dorg2r.c
deleted file mode 100644
index 6653d7c..0000000
--- a/dorg2r.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorg2r_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dorg2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dorg2r( m, a, tau)\n or\n NumRu::Lapack.dorg2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORG2R generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n));
-
- dorg2r_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dorg2r(VALUE mLapack){
- rb_define_module_function(mLapack, "dorg2r", rb_dorg2r, -1);
-}
diff --git a/dorgbr.c b/dorgbr.c
deleted file mode 100644
index e244ab9..0000000
--- a/dorgbr.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorgbr_(char *vect, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dorgbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgbr( vect, m, k, a, tau, lwork)\n or\n NumRu::Lapack.dorgbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGBR generates one of the real orthogonal matrices Q or P**T\n* determined by DGEBRD when reducing a real matrix A to bidiagonal\n* form: A = Q * B * P**T. Q and P**T are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n* is of order N:\n* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m\n* rows of P**T, where n >= m >= k;\n* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**T is\n* required, as defined in the transformation applied by DGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**T.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**T to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**T to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by DGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by DGEBRD.\n* K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by DGEBRD.\n* On exit, the M-by-N matrix Q or P**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**T, as\n* returned by DGEBRD in its array argument TAUQ or TAUP.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_m = argv[1];
- rb_k = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_lwork = argv[5];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(m,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dorgbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dorgbr(VALUE mLapack){
- rb_define_module_function(mLapack, "dorgbr", rb_dorgbr, -1);
-}
diff --git a/dorghr.c b/dorghr.c
deleted file mode 100644
index f045dfc..0000000
--- a/dorghr.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorghr_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dorghr(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorghr( ilo, ihi, a, tau, lwork)\n or\n NumRu::Lapack.dorghr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGHR generates a real orthogonal matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* DGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of DGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by DGEHRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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 DGEHRD.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dorghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dorghr(VALUE mLapack){
- rb_define_module_function(mLapack, "dorghr", rb_dorghr, -1);
-}
diff --git a/dorgl2.c b/dorgl2.c
deleted file mode 100644
index c478e78..0000000
--- a/dorgl2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorgl2_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dorgl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dorgl2( a, tau)\n or\n NumRu::Lapack.dorgl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGL2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by DGELQF in the first k rows of its array argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (m));
-
- dorgl2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dorgl2(VALUE mLapack){
- rb_define_module_function(mLapack, "dorgl2", rb_dorgl2, -1);
-}
diff --git a/dorglq.c b/dorglq.c
deleted file mode 100644
index 9356cd0..0000000
--- a/dorglq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorglq_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dorglq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorglq( m, a, tau, lwork)\n or\n NumRu::Lapack.dorglq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by DGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dorglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dorglq(VALUE mLapack){
- rb_define_module_function(mLapack, "dorglq", rb_dorglq, -1);
-}
diff --git a/dorgql.c b/dorgql.c
deleted file mode 100644
index 3132c57..0000000
--- a/dorgql.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorgql_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dorgql(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgql( m, a, tau, lwork)\n or\n NumRu::Lapack.dorgql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGQL generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dorgql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dorgql(VALUE mLapack){
- rb_define_module_function(mLapack, "dorgql", rb_dorgql, -1);
-}
diff --git a/dorgqr.c b/dorgqr.c
deleted file mode 100644
index a328793..0000000
--- a/dorgqr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorgqr_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dorgqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgqr( m, a, tau, lwork)\n or\n NumRu::Lapack.dorgqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGQR generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dorgqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dorgqr(VALUE mLapack){
- rb_define_module_function(mLapack, "dorgqr", rb_dorgqr, -1);
-}
diff --git a/dorgr2.c b/dorgr2.c
deleted file mode 100644
index b3bf7e2..0000000
--- a/dorgr2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorgr2_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *info);
-
-static VALUE
-rb_dorgr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dorgr2( a, tau)\n or\n NumRu::Lapack.dorgr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGR2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGERQF in the last k rows of its array argument\n* A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (m));
-
- dorgr2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dorgr2(VALUE mLapack){
- rb_define_module_function(mLapack, "dorgr2", rb_dorgr2, -1);
-}
diff --git a/dorgrq.c b/dorgrq.c
deleted file mode 100644
index e7668ad..0000000
--- a/dorgrq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorgrq_(integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dorgrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgrq( m, a, tau, lwork)\n or\n NumRu::Lapack.dorgrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dorgrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dorgrq(VALUE mLapack){
- rb_define_module_function(mLapack, "dorgrq", rb_dorgrq, -1);
-}
diff --git a/dorgtr.c b/dorgtr.c
deleted file mode 100644
index 9f5984f..0000000
--- a/dorgtr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorgtr_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dorgtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgtr( uplo, a, tau, lwork)\n or\n NumRu::Lapack.dorgtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGTR generates a real orthogonal matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* DSYTRD:\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 triangle of A contains elementary reflectors\n* from DSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from DSYTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by DSYTRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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 DSYTRD.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N-1).\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dorgtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dorgtr(VALUE mLapack){
- rb_define_module_function(mLapack, "dorgtr", rb_dorgtr, -1);
-}
diff --git a/dorm2l.c b/dorm2l.c
deleted file mode 100644
index 964dee0..0000000
--- a/dorm2l.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorm2l_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dorm2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dorm2l( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.dorm2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORM2L overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\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'*C or C*Q' 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dorm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_dorm2l(VALUE mLapack){
- rb_define_module_function(mLapack, "dorm2l", rb_dorm2l, -1);
-}
diff --git a/dorm2r.c b/dorm2r.c
deleted file mode 100644
index 768406b..0000000
--- a/dorm2r.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorm2r_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dorm2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dorm2r( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.dorm2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORM2R overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\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'*C or C*Q' 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dorm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_dorm2r(VALUE mLapack){
- rb_define_module_function(mLapack, "dorm2r", rb_dorm2r, -1);
-}
diff --git a/dormbr.c b/dormbr.c
deleted file mode 100644
index 42b2bd8..0000000
--- a/dormbr.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormbr_(char *vect, char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer ldc;
- integer n;
- integer nq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormbr( vect, side, trans, m, k, a, tau, c, lwork)\n or\n NumRu::Lapack.dormbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'T': Q**T * C C * Q**T\n*\n* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'T': P**T * C C * P**T\n*\n* Here Q and P**T are the orthogonal matrices determined by DGEBRD when\n* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n* P**T are defined as products of elementary reflectors H(i) and G(i)\n* respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the orthogonal matrix Q or P**T that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**T;\n* = 'P': apply P or P**T.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**T, P or P**T from the Left;\n* = 'R': apply Q, Q**T, P or P**T from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'T': Transpose, apply Q**T or P**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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by DGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by DGEBRD.\n* K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by DGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by DGEBRD in the array argument TAUQ or TAUP.\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* or P*C or P**T*C or C*P or C*P**T.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DORMLQ, DORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_vect = argv[0];
- rb_side = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_k = argv[4];
- rb_a = argv[5];
- rb_tau = argv[6];
- rb_c = argv[7];
- rb_lwork = argv[8];
-
- k = NUM2INT(rb_k);
- lwork = NUM2INT(rb_lwork);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormbr(VALUE mLapack){
- rb_define_module_function(mLapack, "dormbr", rb_dormbr, -1);
-}
diff --git a/dormhr.c b/dormhr.c
deleted file mode 100644
index b600539..0000000
--- a/dormhr.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormhr_(char *side, char *trans, integer *m, integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormhr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormhr( side, trans, ilo, ihi, a, tau, c, lwork)\n or\n NumRu::Lapack.dormhr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMHR 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* IHI-ILO elementary reflectors, as returned by DGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-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* 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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of DGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by DGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEHRD.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
- rb_lwork = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- ihi = NUM2INT(rb_ihi);
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormhr(VALUE mLapack){
- rb_define_module_function(mLapack, "dormhr", rb_dormhr, -1);
-}
diff --git a/dorml2.c b/dorml2.c
deleted file mode 100644
index c9679e0..0000000
--- a/dorml2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dorml2_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dorml2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dorml2( side, trans, a, tau, c)\n or\n NumRu::Lapack.dorml2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORML2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\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'*C or C*Q' 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dorml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_dorml2(VALUE mLapack){
- rb_define_module_function(mLapack, "dorml2", rb_dorml2, -1);
-}
diff --git a/dormlq.c b/dormlq.c
deleted file mode 100644
index 4b4a330..0000000
--- a/dormlq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormlq_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormlq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormlq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.dormlq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMLQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormlq(VALUE mLapack){
- rb_define_module_function(mLapack, "dormlq", rb_dormlq, -1);
-}
diff --git a/dormql.c b/dormql.c
deleted file mode 100644
index 889d2bd..0000000
--- a/dormql.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormql_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormql(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormql( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.dormql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMQL 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormql(VALUE mLapack){
- rb_define_module_function(mLapack, "dormql", rb_dormql, -1);
-}
diff --git a/dormqr.c b/dormqr.c
deleted file mode 100644
index d0fe475..0000000
--- a/dormqr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormqr_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormqr( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.dormqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMQR 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormqr(VALUE mLapack){
- rb_define_module_function(mLapack, "dormqr", rb_dormqr, -1);
-}
diff --git a/dormr2.c b/dormr2.c
deleted file mode 100644
index dbd88b8..0000000
--- a/dormr2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormr2_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dormr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dormr2( side, trans, a, tau, c)\n or\n NumRu::Lapack.dormr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMR2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\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'*C or C*Q' 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dormr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_dormr2(VALUE mLapack){
- rb_define_module_function(mLapack, "dormr2", rb_dormr2, -1);
-}
diff --git a/dormr3.c b/dormr3.c
deleted file mode 100644
index 7580171..0000000
--- a/dormr3.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormr3_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *info);
-
-static VALUE
-rb_dormr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- doublereal *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dormr3( side, trans, l, a, tau, c)\n or\n NumRu::Lapack.dormr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMR3 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DTZRZF.\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'*C or C*Q' 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLARZ, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- dormr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_dormr3(VALUE mLapack){
- rb_define_module_function(mLapack, "dormr3", rb_dormr3, -1);
-}
diff --git a/dormrq.c b/dormrq.c
deleted file mode 100644
index 6aacae6..0000000
--- a/dormrq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormrq_(char *side, char *trans, integer *m, integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormrq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.dormrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMRQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormrq(VALUE mLapack){
- rb_define_module_function(mLapack, "dormrq", rb_dormrq, -1);
-}
diff --git a/dormrz.c b/dormrz.c
deleted file mode 100644
index 1926fa7..0000000
--- a/dormrz.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormrz( side, trans, l, a, tau, c, lwork)\n or\n NumRu::Lapack.dormrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMRZ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DTZRZF.\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**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormrz(VALUE mLapack){
- rb_define_module_function(mLapack, "dormrz", rb_dormrz, -1);
-}
diff --git a/dormtr.c b/dormtr.c
deleted file mode 100644
index e2da28c..0000000
--- a/dormtr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dormtr_(char *side, char *uplo, char *trans, integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *c, integer *ldc, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dormtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormtr( side, uplo, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.dormtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMTR 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 DSYTRD:\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 triangle of A contains elementary reflectors\n* from DSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from DSYTRD.\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* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by DSYTRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DSYTRD.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DORMQL, DORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_DFLOAT)
- rb_tau = na_change_type(rb_tau, NA_DFLOAT);
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dormtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_dormtr(VALUE mLapack){
- rb_define_module_function(mLapack, "dormtr", rb_dormtr, -1);
-}
diff --git a/dpbcon.c b/dpbcon.c
deleted file mode 100644
index 49cd9fc..0000000
--- a/dpbcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbcon_(char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dpbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dpbcon( uplo, kd, ab, anorm)\n or\n NumRu::Lapack.dpbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite band matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the symmetric band matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dpbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbcon", rb_dpbcon, -1);
-}
diff --git a/dpbequ.c b/dpbequ.c
deleted file mode 100644
index 7d23b3a..0000000
--- a/dpbequ.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbequ_(char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_dpbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dpbequ( uplo, kd, ab)\n or\n NumRu::Lapack.dpbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPBEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- dpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_dpbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbequ", rb_dpbequ, -1);
-}
diff --git a/dpbrfs.c b/dpbrfs.c
deleted file mode 100644
index ecdd5b9..0000000
--- a/dpbrfs.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbrfs_(char *uplo, integer *n, integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dpbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dpbrfs( uplo, kd, ab, afb, b, x)\n or\n NumRu::Lapack.dpbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A as computed by\n* DPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_afb = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dpbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbrfs", rb_dpbrfs, -1);
-}
diff --git a/dpbstf.c b/dpbstf.c
deleted file mode 100644
index b36bb7d..0000000
--- a/dpbstf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbstf_(char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_dpbstf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.dpbstf( uplo, kd, ab)\n or\n NumRu::Lapack.dpbstf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* DPBSTF computes a split Cholesky factorization of a real\n* symmetric positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with DSBGST.\n*\n* The factorization has the form A = S**T*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**T*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dpbstf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_dpbstf(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbstf", rb_dpbstf, -1);
-}
diff --git a/dpbsv.c b/dpbsv.c
deleted file mode 100644
index f66eb7d..0000000
--- a/dpbsv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbsv_(char *uplo, integer *n, integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dpbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.dpbsv( uplo, kd, ab, b)\n or\n NumRu::Lapack.dpbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPBSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPBTRF, DPBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_dpbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbsv", rb_dpbsv, -1);
-}
diff --git a/dpbsvx.c b/dpbsvx.c
deleted file mode 100644
index ba716d5..0000000
--- a/dpbsvx.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbsvx_(char *fact, char *uplo, integer *n, integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dpbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_afb_out__;
- doublereal *afb_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.dpbsvx( fact, uplo, kd, ab, afb, equed, s, b)\n or\n NumRu::Lapack.dpbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- kd = NUM2INT(rb_kd);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, doublereal*);
- MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ab, rb_afb, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_dpbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbsvx", rb_dpbsvx, -1);
-}
diff --git a/dpbtf2.c b/dpbtf2.c
deleted file mode 100644
index 2e247bb..0000000
--- a/dpbtf2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbtf2_(char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_dpbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.dpbtf2( uplo, kd, ab)\n or\n NumRu::Lapack.dpbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* DPBTF2 computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the transpose of U, and\n* L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_dpbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbtf2", rb_dpbtf2, -1);
-}
diff --git a/dpbtrf.c b/dpbtrf.c
deleted file mode 100644
index 6064111..0000000
--- a/dpbtrf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbtrf_(char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_dpbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.dpbtrf( uplo, kd, ab)\n or\n NumRu::Lapack.dpbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* DPBTRF computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_dpbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbtrf", rb_dpbtrf, -1);
-}
diff --git a/dpbtrs.c b/dpbtrs.c
deleted file mode 100644
index fcdf353..0000000
--- a/dpbtrs.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpbtrs_(char *uplo, integer *n, integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dpbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpbtrs( uplo, kd, ab, b)\n or\n NumRu::Lapack.dpbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPBTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite band matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by DPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DTBSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dpbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dpbtrs", rb_dpbtrs, -1);
-}
diff --git a/dpftrf.c b/dpftrf.c
deleted file mode 100644
index d27c192..0000000
--- a/dpftrf.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpftrf_(char *transr, char *uplo, integer *n, doublereal *a, integer *info);
-
-static VALUE
-rb_dpftrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpftrf( transr, uplo, n, a)\n or\n NumRu::Lapack.dpftrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* DPFTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the NT elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**T*U or RFP A = L*L**T.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dpftrf_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dpftrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dpftrf", rb_dpftrf, -1);
-}
diff --git a/dpftri.c b/dpftri.c
deleted file mode 100644
index 82b0ac8..0000000
--- a/dpftri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpftri_(char *transr, char *uplo, integer *n, doublereal *a, integer *info);
-
-static VALUE
-rb_dpftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpftri( transr, uplo, n, a)\n or\n NumRu::Lapack.dpftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* DPFTRI computes the inverse of a (real) symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by DPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 )\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the symmetric inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dpftri_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dpftri(VALUE mLapack){
- rb_define_module_function(mLapack, "dpftri", rb_dpftri, -1);
-}
diff --git a/dpftrs.c b/dpftrs.c
deleted file mode 100644
index a0dc760..0000000
--- a/dpftrs.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpftrs_(char *transr, char *uplo, integer *n, integer *nrhs, doublereal *a, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dpftrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpftrs( transr, uplo, n, a, b)\n or\n NumRu::Lapack.dpftrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPFTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by DPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ).\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dpftrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dpftrs", rb_dpftrs, -1);
-}
diff --git a/dpocon.c b/dpocon.c
deleted file mode 100644
index 6bea3df..0000000
--- a/dpocon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpocon_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dpocon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dpocon( uplo, a, anorm)\n or\n NumRu::Lapack.dpocon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPOCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dpocon(VALUE mLapack){
- rb_define_module_function(mLapack, "dpocon", rb_dpocon, -1);
-}
diff --git a/dpoequ.c b/dpoequ.c
deleted file mode 100644
index bae6750..0000000
--- a/dpoequ.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpoequ_(integer *n, doublereal *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_dpoequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dpoequ( a)\n or\n NumRu::Lapack.dpoequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- dpoequ_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_dpoequ(VALUE mLapack){
- rb_define_module_function(mLapack, "dpoequ", rb_dpoequ, -1);
-}
diff --git a/dpoequb.c b/dpoequb.c
deleted file mode 100644
index 788f3d6..0000000
--- a/dpoequb.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpoequb_(integer *n, doublereal *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_dpoequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dpoequb( a)\n or\n NumRu::Lapack.dpoequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- dpoequb_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_dpoequb(VALUE mLapack){
- rb_define_module_function(mLapack, "dpoequb", rb_dpoequb, -1);
-}
diff --git a/dporfs.c b/dporfs.c
deleted file mode 100644
index a580e40..0000000
--- a/dporfs.c
+++ /dev/null
@@ -1,122 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dporfs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dporfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dporfs( uplo, a, af, b, x)\n or\n NumRu::Lapack.dporfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPOTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dporfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dporfs", rb_dporfs, -1);
-}
diff --git a/dporfsx.c b/dporfsx.c
deleted file mode 100644
index eeb2b83..0000000
--- a/dporfsx.c
+++ /dev/null
@@ -1,187 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dporfsx_(char *uplo, char *equed, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dporfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dporfsx( uplo, equed, a, af, s, b, x, params)\n or\n NumRu::Lapack.dporfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_s = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
- rb_params = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (5th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_dporfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "dporfsx", rb_dporfsx, -1);
-}
diff --git a/dposv.c b/dposv.c
deleted file mode 100644
index d0213fa..0000000
--- a/dposv.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dposv_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dposv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.dposv( uplo, a, b)\n or\n NumRu::Lapack.dposv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPOSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPOTRF, DPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dposv(VALUE mLapack){
- rb_define_module_function(mLapack, "dposv", rb_dposv, -1);
-}
diff --git a/dposvx.c b/dposvx.c
deleted file mode 100644
index 7b2453e..0000000
--- a/dposvx.c
+++ /dev/null
@@ -1,178 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dposvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dposvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_af_out__;
- doublereal *af_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.dposvx( fact, uplo, a, af, equed, s, b)\n or\n NumRu::Lapack.dposvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublereal*);
- MEMCPY(af_out__, af, doublereal, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_dposvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dposvx", rb_dposvx, -1);
-}
diff --git a/dposvxx.c b/dposvxx.c
deleted file mode 100644
index fea2e44..0000000
--- a/dposvxx.c
+++ /dev/null
@@ -1,216 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dposvxx_(char *fact, char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dposvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_af_out__;
- doublereal *af_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.dposvxx( fact, uplo, a, af, equed, s, b, params)\n or\n NumRu::Lapack.dposvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a double precision system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_params = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- n_err_bnds = 3;
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublereal*);
- MEMCPY(af_out__, af, doublereal, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_dposvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "dposvxx", rb_dposvxx, -1);
-}
diff --git a/dpotf2.c b/dpotf2.c
deleted file mode 100644
index f53ab19..0000000
--- a/dpotf2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpotf2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dpotf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpotf2( uplo, a)\n or\n NumRu::Lapack.dpotf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DPOTF2 computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dpotf2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dpotf2(VALUE mLapack){
- rb_define_module_function(mLapack, "dpotf2", rb_dpotf2, -1);
-}
diff --git a/dpotrf.c b/dpotrf.c
deleted file mode 100644
index 01803c3..0000000
--- a/dpotrf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpotrf_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dpotrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpotrf( uplo, a)\n or\n NumRu::Lapack.dpotrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DPOTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dpotrf_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dpotrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dpotrf", rb_dpotrf, -1);
-}
diff --git a/dpotri.c b/dpotri.c
deleted file mode 100644
index 37324cb..0000000
--- a/dpotri.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpotri_(char *uplo, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dpotri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpotri( uplo, a)\n or\n NumRu::Lapack.dpotri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DPOTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, as computed by\n* DPOTRF.\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLAUUM, DTRTRI, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dpotri_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dpotri(VALUE mLapack){
- rb_define_module_function(mLapack, "dpotri", rb_dpotri, -1);
-}
diff --git a/dpotrs.c b/dpotrs.c
deleted file mode 100644
index 18cb13b..0000000
--- a/dpotrs.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpotrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dpotrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpotrs( uplo, a, b)\n or\n NumRu::Lapack.dpotrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPOTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dpotrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dpotrs", rb_dpotrs, -1);
-}
diff --git a/dppcon.c b/dppcon.c
deleted file mode 100644
index 16c07bf..0000000
--- a/dppcon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dppcon_(char *uplo, integer *n, doublereal *ap, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dppcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dppcon( uplo, ap, anorm)\n or\n NumRu::Lapack.dppcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite packed matrix using\n* the Cholesky factorization A = U**T*U or A = L*L**T computed by\n* DPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dppcon_(&uplo, &n, ap, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dppcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dppcon", rb_dppcon, -1);
-}
diff --git a/dppequ.c b/dppequ.c
deleted file mode 100644
index 06e77ce..0000000
--- a/dppequ.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dppequ_(char *uplo, integer *n, doublereal *ap, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_dppequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dppequ( uplo, ap)\n or\n NumRu::Lapack.dppequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPPEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- dppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_dppequ(VALUE mLapack){
- rb_define_module_function(mLapack, "dppequ", rb_dppequ, -1);
-}
diff --git a/dpprfs.c b/dpprfs.c
deleted file mode 100644
index d729bf4..0000000
--- a/dpprfs.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpprfs_(char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *afp, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dpprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_afp;
- doublereal *afp;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dpprfs( uplo, ap, afp, b, x)\n or\n NumRu::Lapack.dpprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DFLOAT)
- rb_afp = na_change_type(rb_afp, NA_DFLOAT);
- afp = NA_PTR_TYPE(rb_afp, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dpprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dpprfs", rb_dpprfs, -1);
-}
diff --git a/dppsv.c b/dppsv.c
deleted file mode 100644
index ef34ea7..0000000
--- a/dppsv.c
+++ /dev/null
@@ -1,85 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dppsv_(char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dppsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.dppsv( uplo, n, ap, b)\n or\n NumRu::Lapack.dppsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPPTRF, DPPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_dppsv(VALUE mLapack){
- rb_define_module_function(mLapack, "dppsv", rb_dppsv, -1);
-}
diff --git a/dppsvx.c b/dppsvx.c
deleted file mode 100644
index 1e0a495..0000000
--- a/dppsvx.c
+++ /dev/null
@@ -1,172 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dppsvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *afp, char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dppsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_afp;
- doublereal *afp;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- VALUE rb_afp_out__;
- doublereal *afp_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.dppsvx( fact, uplo, ap, afp, equed, s, b)\n or\n NumRu::Lapack.dppsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) DOUBLE PRECISION array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L', in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the original matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DFLOAT)
- rb_afp = na_change_type(rb_afp, NA_DFLOAT);
- afp = NA_PTR_TYPE(rb_afp, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, doublereal*);
- MEMCPY(afp_out__, afp, doublereal, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ap, rb_afp, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_dppsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dppsvx", rb_dppsvx, -1);
-}
diff --git a/dpptrf.c b/dpptrf.c
deleted file mode 100644
index 9e8a082..0000000
--- a/dpptrf.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpptrf_(char *uplo, integer *n, doublereal *ap, integer *info);
-
-static VALUE
-rb_dpptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dpptrf( uplo, n, ap)\n or\n NumRu::Lapack.dpptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* DPPTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ======= =======\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dpptrf_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_dpptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dpptrf", rb_dpptrf, -1);
-}
diff --git a/dpptri.c b/dpptri.c
deleted file mode 100644
index 89be9c6..0000000
--- a/dpptri.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpptri_(char *uplo, integer *n, doublereal *ap, integer *info);
-
-static VALUE
-rb_dpptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dpptri( uplo, n, ap)\n or\n NumRu::Lapack.dpptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* DPPTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by DPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dpptri_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_dpptri(VALUE mLapack){
- rb_define_module_function(mLapack, "dpptri", rb_dpptri, -1);
-}
diff --git a/dpptrs.c b/dpptrs.c
deleted file mode 100644
index 04808be..0000000
--- a/dpptrs.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpptrs_(char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dpptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpptrs( uplo, n, ap, b)\n or\n NumRu::Lapack.dpptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPPTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**T*U or A = L*L**T computed by DPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dpptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dpptrs", rb_dpptrs, -1);
-}
diff --git a/dpstf2.c b/dpstf2.c
deleted file mode 100644
index e3065c9..0000000
--- a/dpstf2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpstf2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, integer *info);
-
-static VALUE
-rb_dpstf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.dpstf2( uplo, a, tol)\n or\n NumRu::Lapack.dpstf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPSTF2 computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- tol = NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- dpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_dpstf2(VALUE mLapack){
- rb_define_module_function(mLapack, "dpstf2", rb_dpstf2, -1);
-}
diff --git a/dpstrf.c b/dpstrf.c
deleted file mode 100644
index aba76b6..0000000
--- a/dpstrf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpstrf_(char *uplo, integer *n, doublereal *a, integer *lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, integer *info);
-
-static VALUE
-rb_dpstrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.dpstrf( uplo, a, tol)\n or\n NumRu::Lapack.dpstrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPSTRF computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- tol = NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- dpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_dpstrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dpstrf", rb_dpstrf, -1);
-}
diff --git a/dptcon.c b/dptcon.c
deleted file mode 100644
index f709236..0000000
--- a/dptcon.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dptcon_(integer *n, doublereal *d, doublereal *e, doublereal *anorm, doublereal *rcond, doublereal *work, integer *info);
-
-static VALUE
-rb_dptcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dptcon( d, e, anorm)\n or\n NumRu::Lapack.dptcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite tridiagonal matrix\n* using the factorization A = L*D*L**T or A = U**T*D*U computed by\n* DPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by DPTTRF.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by DPTTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal of the condition number of the matrix A,\n* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n* 1-norm of inv(A) computed in this routine.\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- work = ALLOC_N(doublereal, (n));
-
- dptcon_(&n, d, e, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dptcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dptcon", rb_dptcon, -1);
-}
diff --git a/dpteqr.c b/dpteqr.c
deleted file mode 100644
index 84cad02..0000000
--- a/dpteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpteqr_(char *compz, integer *n, doublereal *d, doublereal *e, doublereal *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_dpteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
- doublereal *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.dpteqr( compz, d, e, z)\n or\n NumRu::Lapack.dpteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using DPTTRF, and then calling DBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band symmetric positive definite matrix\n* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n* form, however, may preclude the possibility of obtaining high\n* relative accuracy in the small eigenvalues of the original matrix, if\n* these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original symmetric\n* matrix also. Array Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal\n* matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original symmetric matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(doublereal, (4*n));
-
- dpteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_dpteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "dpteqr", rb_dpteqr, -1);
-}
diff --git a/dptrfs.c b/dptrfs.c
deleted file mode 100644
index 8c6e79a..0000000
--- a/dptrfs.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dptrfs_(integer *n, integer *nrhs, doublereal *d, doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *info);
-
-static VALUE
-rb_dptrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_df;
- doublereal *df;
- VALUE rb_ef;
- doublereal *ef;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dptrfs( d, e, df, ef, b, x)\n or\n NumRu::Lapack.dptrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization computed by DPTTRF.\n*\n* EF (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the factorization computed by DPTTRF.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPTTRS.\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) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (2*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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_df = argv[2];
- rb_ef = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (3th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_df);
- if (NA_TYPE(rb_df) != NA_DFLOAT)
- rb_df = na_change_type(rb_df, NA_DFLOAT);
- df = NA_PTR_TYPE(rb_df, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (4th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_DFLOAT)
- rb_ef = na_change_type(rb_ef, NA_DFLOAT);
- ef = NA_PTR_TYPE(rb_ef, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- dptrfs_(&n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dptrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dptrfs", rb_dptrfs, -1);
-}
diff --git a/dptsv.c b/dptsv.c
deleted file mode 100644
index db8c11f..0000000
--- a/dptsv.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dptsv_(integer *n, integer *nrhs, doublereal *d, doublereal *e, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dptsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.dptsv( d, e, b)\n or\n NumRu::Lapack.dptsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPTSV computes the solution to a real system of linear equations\n* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**T, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**T.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**T factorization of\n* A. (E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**T*D*U factorization of A.)\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL DPTTRF, DPTTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dptsv_(&n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_dptsv(VALUE mLapack){
- rb_define_module_function(mLapack, "dptsv", rb_dptsv, -1);
-}
diff --git a/dptsvx.c b/dptsvx.c
deleted file mode 100644
index c7bd8bb..0000000
--- a/dptsvx.c
+++ /dev/null
@@ -1,149 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dptsvx_(char *fact, integer *n, integer *nrhs, doublereal *d, doublereal *e, doublereal *df, doublereal *ef, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *info);
-
-static VALUE
-rb_dptsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_df;
- doublereal *df;
- VALUE rb_ef;
- doublereal *ef;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_df_out__;
- doublereal *df_out__;
- VALUE rb_ef_out__;
- doublereal *ef_out__;
- doublereal *work;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.dptsvx( fact, d, e, df, ef, b)\n or\n NumRu::Lapack.dptsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTSVX uses the factorization A = L*D*L**T to compute the solution\n* to a real system of linear equations A*X = B, where A is an N-by-N\n* symmetric positive definite tridiagonal matrix and X and B are\n* N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**T*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) DOUBLE PRECISION array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n*\n* EF (input or output) DOUBLE PRECISION array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The componentwise relative backward error of each solution\n* vector X(j) (i.e., the smallest relative change in any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_df = argv[3];
- rb_ef = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (4th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_df);
- if (NA_TYPE(rb_df) != NA_DFLOAT)
- rb_df = na_change_type(rb_df, NA_DFLOAT);
- df = NA_PTR_TYPE(rb_df, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_DFLOAT)
- rb_ef = na_change_type(rb_ef, NA_DFLOAT);
- ef = NA_PTR_TYPE(rb_ef, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, doublereal*);
- MEMCPY(df_out__, df, doublereal, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_ef_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ef_out__ = NA_PTR_TYPE(rb_ef_out__, doublereal*);
- MEMCPY(ef_out__, ef, doublereal, NA_TOTAL(rb_ef));
- rb_ef = rb_ef_out__;
- ef = ef_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- dptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_df, rb_ef);
-}
-
-void
-init_lapack_dptsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dptsvx", rb_dptsvx, -1);
-}
diff --git a/dpttrf.c b/dpttrf.c
deleted file mode 100644
index c8acf84..0000000
--- a/dpttrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpttrf_(integer *n, doublereal *d, doublereal *e, integer *info);
-
-static VALUE
-rb_dpttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.dpttrf( d, e)\n or\n NumRu::Lapack.dpttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* DPTTRF computes the L*D*L' factorization of a real symmetric\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- dpttrf_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dpttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dpttrf", rb_dpttrf, -1);
-}
diff --git a/dpttrs.c b/dpttrs.c
deleted file mode 100644
index c505bc1..0000000
--- a/dpttrs.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dpttrs_(integer *n, integer *nrhs, doublereal *d, doublereal *e, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dpttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpttrs( d, e, b)\n or\n NumRu::Lapack.dpttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by DPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n INTEGER J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DPTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dpttrs_(&n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dpttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dpttrs", rb_dpttrs, -1);
-}
diff --git a/dptts2.c b/dptts2.c
deleted file mode 100644
index 6e9ca80..0000000
--- a/dptts2.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dptts2_(integer *n, integer *nrhs, doublereal *d, doublereal *e, doublereal *b, integer *ldb);
-
-static VALUE
-rb_dptts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.dptts2( d, e, b)\n or\n NumRu::Lapack.dptts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* DPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by DPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL DSCAL\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dptts2_(&n, &nrhs, d, e, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_dptts2(VALUE mLapack){
- rb_define_module_function(mLapack, "dptts2", rb_dptts2, -1);
-}
diff --git a/drscl.c b/drscl.c
deleted file mode 100644
index 34063a9..0000000
--- a/drscl.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID drscl_(integer *n, doublereal *sa, doublereal *sx, integer *incx);
-
-static VALUE
-rb_drscl(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_sa;
- doublereal sa;
- VALUE rb_sx;
- doublereal *sx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_sx_out__;
- doublereal *sx_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sx = NumRu::Lapack.drscl( n, sa, sx, incx)\n or\n NumRu::Lapack.drscl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* DRSCL multiplies an n-element real vector x by the real scalar 1/a.\n* This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) DOUBLE PRECISION\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) DOUBLE PRECISION array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_sa = argv[1];
- rb_sx = argv[2];
- rb_incx = argv[3];
-
- sa = NUM2DBL(rb_sa);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_sx))
- rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
- if (NA_RANK(rb_sx) != 1)
- rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sx) != (1+(n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
- if (NA_TYPE(rb_sx) != NA_DFLOAT)
- rb_sx = na_change_type(rb_sx, NA_DFLOAT);
- sx = NA_PTR_TYPE(rb_sx, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*abs(incx);
- rb_sx_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sx_out__ = NA_PTR_TYPE(rb_sx_out__, doublereal*);
- MEMCPY(sx_out__, sx, doublereal, NA_TOTAL(rb_sx));
- rb_sx = rb_sx_out__;
- sx = sx_out__;
-
- drscl_(&n, &sa, sx, &incx);
-
- return rb_sx;
-}
-
-void
-init_lapack_drscl(VALUE mLapack){
- rb_define_module_function(mLapack, "drscl", rb_drscl, -1);
-}
diff --git a/dsbev.c b/dsbev.c
deleted file mode 100644
index 2444a6b..0000000
--- a/dsbev.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbev_(char *jobz, char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_dsbev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.dsbev( jobz, uplo, kd, ab)\n or\n NumRu::Lapack.dsbev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(doublereal, (MAX(1,3*n-2)));
-
- dsbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ab);
-}
-
-void
-init_lapack_dsbev(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbev", rb_dsbev, -1);
-}
diff --git a/dsbevd.c b/dsbevd.c
deleted file mode 100644
index 2263160..0000000
--- a/dsbevd.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbevd_(char *jobz, char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dsbevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab = NumRu::Lapack.dsbevd( jobz, uplo, kd, ab, lwork, liwork)\n or\n NumRu::Lapack.dsbevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A. If eigenvectors are desired, it uses\n* a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* IF N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 2, LWORK must be at least\n* ( 1 + 5*N + 2*N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array LIWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_lwork = argv[4];
- rb_liwork = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- liwork = NUM2INT(rb_liwork);
- jobz = StringValueCStr(rb_jobz)[0];
- lwork = NUM2INT(rb_lwork);
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- dsbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ab);
-}
-
-void
-init_lapack_dsbevd(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbevd", rb_dsbevd, -1);
-}
diff --git a/dsbevx.c b/dsbevx.c
deleted file mode 100644
index ac52047..0000000
--- a/dsbevx.c
+++ /dev/null
@@ -1,138 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbevx_(char *jobz, char *range, char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dsbevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.dsbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.dsbevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric band matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_vl = argv[5];
- rb_vu = argv[6];
- rb_il = argv[7];
- rb_iu = argv[8];
- rb_abstol = argv[9];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(doublereal, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- dsbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_q, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ab);
-}
-
-void
-init_lapack_dsbevx(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbevx", rb_dsbevx, -1);
-}
diff --git a/dsbgst.c b/dsbgst.c
deleted file mode 100644
index e529020..0000000
--- a/dsbgst.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbgst_(char *vect, char *uplo, integer *n, integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *ldbb, doublereal *x, integer *ldx, doublereal *work, integer *info);
-
-static VALUE
-rb_dsbgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_bb;
- doublereal *bb;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, info, ab = NumRu::Lapack.dsbgst( vect, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.dsbgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBGST reduces a real symmetric-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**T*S by DPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**T*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) DOUBLE PRECISION array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by DPBSTF, stored in the first KB+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DFLOAT)
- rb_bb = na_change_type(rb_bb, NA_DFLOAT);
- bb = NA_PTR_TYPE(rb_bb, doublereal*);
- ka = NUM2INT(rb_ka);
- vect = StringValueCStr(rb_vect)[0];
- kb = NUM2INT(rb_kb);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- dsbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_x, rb_info, rb_ab);
-}
-
-void
-init_lapack_dsbgst(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbgst", rb_dsbgst, -1);
-}
diff --git a/dsbgv.c b/dsbgv.c
deleted file mode 100644
index 3c78970..0000000
--- a/dsbgv.c
+++ /dev/null
@@ -1,118 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbgv_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *ldbb, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_dsbgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_bb;
- doublereal *bb;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_bb_out__;
- doublereal *bb_out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.dsbgv( jobz, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.dsbgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by DPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DFLOAT)
- rb_bb = na_change_type(rb_bb, NA_DFLOAT);
- bb = NA_PTR_TYPE(rb_bb, doublereal*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- kb = NUM2INT(rb_kb);
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, doublereal*);
- MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
- work = ALLOC_N(doublereal, (3*n));
-
- dsbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_dsbgv(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbgv", rb_dsbgv, -1);
-}
diff --git a/dsbgvd.c b/dsbgvd.c
deleted file mode 100644
index 9944ee7..0000000
--- a/dsbgvd.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbgvd_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *ldbb, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dsbgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_bb;
- doublereal *bb;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_bb_out__;
- doublereal *bb_out__;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab, bb = NumRu::Lapack.dsbgvd( jobz, uplo, ka, kb, ab, bb, lwork, liwork)\n or\n NumRu::Lapack.dsbgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of the\n* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and\n* banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by DPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
- rb_lwork = argv[6];
- rb_liwork = argv[7];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DFLOAT)
- rb_bb = na_change_type(rb_bb, NA_DFLOAT);
- bb = NA_PTR_TYPE(rb_bb, doublereal*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kb = NUM2INT(rb_kb);
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, doublereal*);
- MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
-
- dsbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_dsbgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbgvd", rb_dsbgvd, -1);
-}
diff --git a/dsbgvx.c b/dsbgvx.c
deleted file mode 100644
index ca150a9..0000000
--- a/dsbgvx.c
+++ /dev/null
@@ -1,178 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbgvx_(char *jobz, char *range, char *uplo, integer *n, integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dsbgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_bb;
- doublereal *bb;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_bb_out__;
- doublereal *bb_out__;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.dsbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.dsbgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSBGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by DPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvalues that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* < 0 : if INFO = -i, the i-th argument had an illegal value\n* <= N: if INFO = i, then i eigenvectors failed to converge.\n* Their indices are stored in IFAIL.\n* > N : DPBSTF returned an error code; i.e.,\n* if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ka = argv[3];
- rb_kb = argv[4];
- rb_ab = argv[5];
- rb_bb = argv[6];
- rb_vl = argv[7];
- rb_vu = argv[8];
- rb_il = argv[9];
- rb_iu = argv[10];
- rb_abstol = argv[11];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DFLOAT)
- rb_bb = na_change_type(rb_bb, NA_DFLOAT);
- bb = NA_PTR_TYPE(rb_bb, doublereal*);
- ka = NUM2INT(rb_ka);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kb = NUM2INT(rb_kb);
- range = StringValueCStr(rb_range)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- uplo = StringValueCStr(rb_uplo)[0];
- ldq = 1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = 7*n;
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = 5*n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = m;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, doublereal*);
- MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
-
- dsbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_q, rb_m, rb_w, rb_z, rb_work, rb_iwork, rb_ifail, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_dsbgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbgvx", rb_dsbgvx, -1);
-}
diff --git a/dsbtrd.c b/dsbtrd.c
deleted file mode 100644
index 3450813..0000000
--- a/dsbtrd.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsbtrd_(char *vect, char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *d, doublereal *e, doublereal *q, integer *ldq, doublereal *work, integer *info);
-
-static VALUE
-rb_dsbtrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublereal *ab_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.dsbtrd( vect, uplo, kd, ab, q)\n or\n NumRu::Lapack.dsbtrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBTRD reduces a real symmetric band matrix A to symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_q = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- vect = StringValueCStr(rb_vect)[0];
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of ab");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublereal*);
- MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(doublereal, (n));
-
- dsbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_info, rb_ab, rb_q);
-}
-
-void
-init_lapack_dsbtrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dsbtrd", rb_dsbtrd, -1);
-}
diff --git a/dsfrk.c b/dsfrk.c
deleted file mode 100644
index 9979ac8..0000000
--- a/dsfrk.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsfrk_(char *transr, char *uplo, char *trans, integer *n, integer *k, doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, doublereal *c);
-
-static VALUE
-rb_dsfrk(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer nt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.dsfrk( transr, uplo, trans, n, k, alpha, a, beta, c)\n or\n NumRu::Lapack.dsfrk # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* DSFRK performs one of the symmetric rank--k operations\n*\n* C := alpha*A*A' + beta*C,\n*\n* or\n*\n* C := alpha*A'*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n symmetric\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.\n*\n* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with TRANS = 'T'\n* or 't', K specifies the number of rows of the matrix A. K\n* must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n*\n* C (input/output) DOUBLE PRECISION array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n* Format. RFP Format is described by TRANSR, UPLO and N.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_n = argv[3];
- rb_k = argv[4];
- rb_alpha = argv[5];
- rb_a = argv[6];
- rb_beta = argv[7];
- rb_c = argv[8];
-
- k = NUM2INT(rb_k);
- transr = StringValueCStr(rb_transr)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- nt = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha = NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- beta = NUM2DBL(rb_beta);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (lsame_(&trans,"N") ? k : n))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = nt;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dsfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
-
- return rb_c;
-}
-
-void
-init_lapack_dsfrk(VALUE mLapack){
- rb_define_module_function(mLapack, "dsfrk", rb_dsfrk, -1);
-}
diff --git a/dsgesv.c b/dsgesv.c
deleted file mode 100644
index 4a90e10..0000000
--- a/dsgesv.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsgesv_(integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *work, real *swork, integer *iter, integer *info);
-
-static VALUE
-rb_dsgesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_iter;
- integer iter;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
- real *swork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, x, iter, info, a = NumRu::Lapack.dsgesv( a, b)\n or\n NumRu::Lapack.dsgesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* DSGESV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* DSGESV first attempts to factorize the matrix in SINGLE PRECISION\n* and use this factorization within an iterative refinement procedure\n* to produce a solution with DOUBLE PRECISION normwise backward error\n* quality (see below). If the approach fails the method switches to a\n* DOUBLE PRECISION factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n* performance is too small. A reasonable strategy should take the\n* number of right-hand sides and the size of the matrix into account.\n* This might be done with a call to ILAENV in the future. Up to now, we\n* always try iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array,\n* dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n* Corresponds either to the single precision factorization\n* (if INFO.EQ.0 and ITER.GE.0) or the double precision\n* factorization (if INFO.EQ.0 and ITER.LT.0).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) REAL array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, double precision\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of SGETRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, U(i,i) computed in DOUBLE PRECISION is\n* exactly zero. The factorization has been completed,\n* but the factor U is exactly singular, so the solution\n* could not be computed.\n*\n* =========\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n)*(nrhs));
- swork = ALLOC_N(real, (n*(n+nrhs)));
-
- dsgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, x, &ldx, work, swork, &iter, &info);
-
- free(work);
- free(swork);
- rb_iter = INT2NUM(iter);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_x, rb_iter, rb_info, rb_a);
-}
-
-void
-init_lapack_dsgesv(VALUE mLapack){
- rb_define_module_function(mLapack, "dsgesv", rb_dsgesv, -1);
-}
diff --git a/dspcon.c b/dspcon.c
deleted file mode 100644
index 818918b..0000000
--- a/dspcon.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspcon_(char *uplo, integer *n, doublereal *ap, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dspcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dspcon( uplo, ap, ipiv, anorm)\n or\n NumRu::Lapack.dspcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric packed matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- work = ALLOC_N(doublereal, (2*n));
- iwork = ALLOC_N(integer, (n));
-
- dspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dspcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dspcon", rb_dspcon, -1);
-}
diff --git a/dspev.c b/dspev.c
deleted file mode 100644
index 1621d30..0000000
--- a/dspev.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspev_(char *jobz, char *uplo, integer *n, doublereal *ap, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_dspev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- doublereal *work;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.dspev( jobz, uplo, ap)\n or\n NumRu::Lapack.dspev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(doublereal, (3*n));
-
- dspev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ap);
-}
-
-void
-init_lapack_dspev(VALUE mLapack){
- rb_define_module_function(mLapack, "dspev", rb_dspev, -1);
-}
diff --git a/dspevd.c b/dspevd.c
deleted file mode 100644
index 789dc7b..0000000
--- a/dspevd.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspevd_(char *jobz, char *uplo, integer *n, doublereal *ap, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dspevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap = NumRu::Lapack.dspevd( jobz, uplo, ap, lwork, liwork)\n or\n NumRu::Lapack.dspevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPEVD computes all the eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least\n* 1 + 6*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_lwork = argv[3];
- rb_liwork = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dspevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ap);
-}
-
-void
-init_lapack_dspevd(VALUE mLapack){
- rb_define_module_function(mLapack, "dspevd", rb_dspevd, -1);
-}
diff --git a/dspevx.c b/dspevx.c
deleted file mode 100644
index 006560a..0000000
--- a/dspevx.c
+++ /dev/null
@@ -1,122 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspevx_(char *jobz, char *range, char *uplo, integer *n, doublereal *ap, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dspevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.dspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.dspevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. Eigenvalues/vectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- il = NUM2INT(rb_il);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(doublereal, (8*n));
- iwork = ALLOC_N(integer, (5*n));
-
- dspevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap);
-}
-
-void
-init_lapack_dspevx(VALUE mLapack){
- rb_define_module_function(mLapack, "dspevx", rb_dspevx, -1);
-}
diff --git a/dspgst.c b/dspgst.c
deleted file mode 100644
index 21af190..0000000
--- a/dspgst.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspgst_(integer *itype, char *uplo, integer *n, doublereal *ap, doublereal *bp, integer *info);
-
-static VALUE
-rb_dspgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_bp;
- doublereal *bp;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dspgst( itype, uplo, n, ap, bp)\n or\n NumRu::Lapack.dspgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* DSPGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by DPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by DPPTRF.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- itype = NUM2INT(rb_itype);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DFLOAT)
- rb_bp = na_change_type(rb_bp, NA_DFLOAT);
- bp = NA_PTR_TYPE(rb_bp, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dspgst_(&itype, &uplo, &n, ap, bp, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_dspgst(VALUE mLapack){
- rb_define_module_function(mLapack, "dspgst", rb_dspgst, -1);
-}
diff --git a/dspgv.c b/dspgv.c
deleted file mode 100644
index 14b7642..0000000
--- a/dspgv.c
+++ /dev/null
@@ -1,110 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspgv_(integer *itype, char *jobz, char *uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_dspgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_bp;
- doublereal *bp;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- VALUE rb_bp_out__;
- doublereal *bp_out__;
- doublereal *work;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.dspgv( itype, jobz, uplo, ap, bp)\n or\n NumRu::Lapack.dspgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension\n* (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: DPPTRF or DSPEV returned an error code:\n* <= N: if INFO = i, DSPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero.\n* > N: if INFO = n + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DFLOAT)
- rb_bp = na_change_type(rb_bp, NA_DFLOAT);
- bp = NA_PTR_TYPE(rb_bp, doublereal*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, doublereal*);
- MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(doublereal, (3*n));
-
- dspgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_dspgv(VALUE mLapack){
- rb_define_module_function(mLapack, "dspgv", rb_dspgv, -1);
-}
diff --git a/dspgvd.c b/dspgvd.c
deleted file mode 100644
index c440b0a..0000000
--- a/dspgvd.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspgvd_(integer *itype, char *jobz, char *uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dspgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_bp;
- doublereal *bp;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- VALUE rb_bp_out__;
- doublereal *bp_out__;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap, bp = NumRu::Lapack.dspgvd( itype, jobz, uplo, ap, bp, lwork, liwork)\n or\n NumRu::Lapack.dspgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: DPPTRF or DSPEVD returned an error code:\n* <= N: if INFO = i, DSPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
- rb_lwork = argv[5];
- rb_liwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DFLOAT)
- rb_bp = na_change_type(rb_bp, NA_DFLOAT);
- bp = NA_PTR_TYPE(rb_bp, doublereal*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, doublereal*);
- MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
-
- dspgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_dspgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "dspgvd", rb_dspgvd, -1);
-}
diff --git a/dspgvx.c b/dspgvx.c
deleted file mode 100644
index 89d1399..0000000
--- a/dspgvx.c
+++ /dev/null
@@ -1,151 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspgvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, doublereal *ap, doublereal *bp, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dspgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_bp;
- doublereal *bp;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- VALUE rb_bp_out__;
- doublereal *bp_out__;
- doublereal *work;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.dspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)\n or\n NumRu::Lapack.dspgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSPGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric, stored in packed storage, and B\n* is also positive definite. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: DPPTRF or DSPEVX returned an error code:\n* <= N: if INFO = i, DSPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_ap = argv[4];
- rb_bp = argv[5];
- rb_vl = argv[6];
- rb_vu = argv[7];
- rb_il = argv[8];
- rb_iu = argv[9];
- rb_abstol = argv[10];
- rb_ldz = argv[11];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DFLOAT)
- rb_bp = na_change_type(rb_bp, NA_DFLOAT);
- bp = NA_PTR_TYPE(rb_bp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, doublereal*);
- MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(doublereal, (8*n));
- iwork = ALLOC_N(integer, (5*n));
-
- dspgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_dspgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dspgvx", rb_dspgvx, -1);
-}
diff --git a/dsposv.c b/dsposv.c
deleted file mode 100644
index 9c185e2..0000000
--- a/dsposv.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsposv_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *work, real *swork, integer *iter, integer *info);
-
-static VALUE
-rb_dsposv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_iter;
- integer iter;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
- real *swork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iter, info, a = NumRu::Lapack.dsposv( uplo, a, b)\n or\n NumRu::Lapack.dsposv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* DSPOSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* DSPOSV first attempts to factorize the matrix in SINGLE PRECISION\n* and use this factorization within an iterative refinement procedure\n* to produce a solution with DOUBLE PRECISION normwise backward error\n* quality (see below). If the approach fails the method switches to a\n* DOUBLE PRECISION factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n* performance is too small. A reasonable strategy should take the\n* number of right-hand sides and the size of the matrix into account.\n* This might be done with a call to ILAENV in the future. Up to now, we\n* always try iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array,\n* 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* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) REAL array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, double precision\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of SPOTRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, the leading minor of order i of (DOUBLE\n* PRECISION) A is not positive definite, so the\n* factorization could not be completed, and the solution\n* has not been computed.\n*\n* =========\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n)*(nrhs));
- swork = ALLOC_N(real, (n*(n+nrhs)));
-
- dsposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, work, swork, &iter, &info);
-
- free(work);
- free(swork);
- rb_iter = INT2NUM(iter);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_x, rb_iter, rb_info, rb_a);
-}
-
-void
-init_lapack_dsposv(VALUE mLapack){
- rb_define_module_function(mLapack, "dsposv", rb_dsposv, -1);
-}
diff --git a/dsprfs.c b/dsprfs.c
deleted file mode 100644
index 4162787..0000000
--- a/dsprfs.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsprfs_(char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dsprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_afp;
- doublereal *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dsprfs( uplo, ap, afp, ipiv, b, x)\n or\n NumRu::Lapack.dsprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by DSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DSPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DFLOAT)
- rb_afp = na_change_type(rb_afp, NA_DFLOAT);
- afp = NA_PTR_TYPE(rb_afp, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dsprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dsprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dsprfs", rb_dsprfs, -1);
-}
diff --git a/dspsv.c b/dspsv.c
deleted file mode 100644
index 6f133ac..0000000
--- a/dspsv.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspsv_(char *uplo, integer *n, integer *nrhs, doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dspsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldb;
- integer nrhs;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.dspsv( uplo, ap, b)\n or\n NumRu::Lapack.dspsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by DSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSPTRF, DSPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_dspsv(VALUE mLapack){
- rb_define_module_function(mLapack, "dspsv", rb_dspsv, -1);
-}
diff --git a/dspsvx.c b/dspsvx.c
deleted file mode 100644
index 91e2016..0000000
--- a/dspsvx.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dspsvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublereal *ap, doublereal *afp, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dspsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_afp;
- doublereal *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_afp_out__;
- doublereal *afp_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.dspsvx( fact, uplo, ap, afp, ipiv, b)\n or\n NumRu::Lapack.dspsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a real system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) DOUBLE PRECISION array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by DSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by DSPTRF.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DFLOAT)
- rb_afp = na_change_type(rb_afp, NA_DFLOAT);
- afp = NA_PTR_TYPE(rb_afp, doublereal*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, doublereal*);
- MEMCPY(afp_out__, afp, doublereal, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_afp, rb_ipiv);
-}
-
-void
-init_lapack_dspsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dspsvx", rb_dspsvx, -1);
-}
diff --git a/dsptrd.c b/dsptrd.c
deleted file mode 100644
index ffd3f23..0000000
--- a/dsptrd.c
+++ /dev/null
@@ -1,81 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsptrd_(char *uplo, integer *n, doublereal *ap, doublereal *d, doublereal *e, doublereal *tau, integer *info);
-
-static VALUE
-rb_dsptrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.dsptrd( uplo, ap)\n or\n NumRu::Lapack.dsptrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRD reduces a real symmetric matrix A stored in packed form to\n* symmetric tridiagonal form T by an orthogonal similarity\n* transformation: Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dsptrd_(&uplo, &n, ap, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_ap);
-}
-
-void
-init_lapack_dsptrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dsptrd", rb_dsptrd, -1);
-}
diff --git a/dsptrf.c b/dsptrf.c
deleted file mode 100644
index ee99d98..0000000
--- a/dsptrf.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsptrf_(char *uplo, integer *n, doublereal *ap, integer *ipiv, integer *info);
-
-static VALUE
-rb_dsptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.dsptrf( uplo, ap)\n or\n NumRu::Lapack.dsptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRF computes the factorization of a real symmetric matrix A stored\n* in packed format using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dsptrf_(&uplo, &n, ap, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ap);
-}
-
-void
-init_lapack_dsptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dsptrf", rb_dsptrf, -1);
-}
diff --git a/dsptri.c b/dsptri.c
deleted file mode 100644
index 3f55cb5..0000000
--- a/dsptri.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsptri_(char *uplo, integer *n, doublereal *ap, integer *ipiv, doublereal *work, integer *info);
-
-static VALUE
-rb_dsptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
- doublereal *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dsptri( uplo, ap, ipiv)\n or\n NumRu::Lapack.dsptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRI computes the inverse of a real symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by DSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* WORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(doublereal, (n));
-
- dsptri_(&uplo, &n, ap, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_dsptri(VALUE mLapack){
- rb_define_module_function(mLapack, "dsptri", rb_dsptri, -1);
-}
diff --git a/dsptrs.c b/dsptrs.c
deleted file mode 100644
index 36be2f9..0000000
--- a/dsptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsptrs_(char *uplo, integer *n, integer *nrhs, doublereal *ap, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dsptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dsptrs( uplo, ap, ipiv, b)\n or\n NumRu::Lapack.dsptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dsptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dsptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dsptrs", rb_dsptrs, -1);
-}
diff --git a/dstebz.c b/dstebz.c
deleted file mode 100644
index 1807833..0000000
--- a/dstebz.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstebz_(char *range, char *order, integer *n, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, doublereal *d, doublereal *e, integer *m, integer *nsplit, doublereal *w, integer *iblock, integer *isplit, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dstebz(int argc, VALUE *argv, VALUE self){
- VALUE rb_range;
- char range;
- VALUE rb_order;
- char order;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_m;
- integer m;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, nsplit, w, iblock, isplit, info = NumRu::Lapack.dstebz( range, order, vl, vu, il, iu, abstol, d, e)\n or\n NumRu::Lapack.dstebz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEBZ computes the eigenvalues of a symmetric tridiagonal\n* matrix T. The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute tolerance for the eigenvalues. An eigenvalue\n* (or cluster) is considered to be located if it has been\n* determined to lie in an interval whose width is ABSTOL or\n* less. If ABSTOL is less than or equal to zero, then ULP*|T|\n* will be used, where |T| means the 1-norm of T.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* NSPLIT (output) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalues. (DSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (DSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* RELFAC DOUBLE PRECISION, default = 2.0e0\n* The relative tolerance. An interval (a,b] lies within\n* \"relative tolerance\" if b-a < RELFAC*ulp*max(|a|,|b|),\n* where \"ulp\" is the machine precision (distance from 1 to\n* the next larger floating point number.)\n*\n* FUDGE DOUBLE PRECISION, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_range = argv[0];
- rb_order = argv[1];
- rb_vl = argv[2];
- rb_vu = argv[3];
- rb_il = argv[4];
- rb_iu = argv[5];
- rb_abstol = argv[6];
- rb_d = argv[7];
- rb_e = argv[8];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- il = NUM2INT(rb_il);
- range = StringValueCStr(rb_range)[0];
- vu = NUM2DBL(rb_vu);
- order = StringValueCStr(rb_order)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (8th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (9th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (3*n));
-
- dstebz_(&range, &order, &n, &vl, &vu, &il, &iu, &abstol, d, e, &m, &nsplit, w, iblock, isplit, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_nsplit = INT2NUM(nsplit);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_m, rb_nsplit, rb_w, rb_iblock, rb_isplit, rb_info);
-}
-
-void
-init_lapack_dstebz(VALUE mLapack){
- rb_define_module_function(mLapack, "dstebz", rb_dstebz, -1);
-}
diff --git a/dstedc.c b/dstedc.c
deleted file mode 100644
index 69aade0..0000000
--- a/dstedc.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstedc_(char *compz, integer *n, doublereal *d, doublereal *e, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dstedc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, iwork, info, d, e, z = NumRu::Lapack.dstedc( compz, d, e, z, lwork, liwork)\n or\n NumRu::Lapack.dstedc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band real symmetric matrix can also be\n* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See DLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original dense symmetric\n* matrix also. On entry, Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be max(1,2*(N-1)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LIWORK must be at least\n* ( 6 + 6*N + 5*N*lg N ).\n* If COMPZ = 'I' and N > 1 then LIWORK must be at least\n* ( 3 + 5*N ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
- rb_lwork = argv[4];
- rb_liwork = argv[5];
-
- compz = StringValueCStr(rb_compz)[0];
- liwork = NUM2INT(rb_liwork);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_work, rb_iwork, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_dstedc(VALUE mLapack){
- rb_define_module_function(mLapack, "dstedc", rb_dstedc, -1);
-}
diff --git a/dstegr.c b/dstegr.c
deleted file mode 100644
index 446a119..0000000
--- a/dstegr.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstegr_(char *jobz, char *range, integer *n, doublereal *d, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, integer *isuppz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dstegr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.dstegr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* DSTEGR is a compatability wrapper around the improved DSTEMR routine.\n* See DSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : DSTEGR and DSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in DLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* DLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL DSTEMR\n* ..\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- il = NUM2INT(rb_il);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- dstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dstegr(VALUE mLapack){
- rb_define_module_function(mLapack, "dstegr", rb_dstegr, -1);
-}
diff --git a/dstein.c b/dstein.c
deleted file mode 100644
index 1e2b4f8..0000000
--- a/dstein.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstein_(integer *n, doublereal *d, doublereal *e, integer *m, doublereal *w, integer *iblock, integer *isplit, doublereal *z, integer *ldz, doublereal *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dstein(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldz;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.dstein( d, e, w, iblock, isplit)\n or\n NumRu::Lapack.dstein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from DSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from DSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from DSTEBZ is expected here. )\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_w = argv[2];
- rb_iblock = argv[3];
- rb_isplit = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- m = n;
- ldz = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = m;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = m;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- work = ALLOC_N(doublereal, (5*n));
- iwork = ALLOC_N(integer, (n));
-
- dstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_z, rb_ifail, rb_info);
-}
-
-void
-init_lapack_dstein(VALUE mLapack){
- rb_define_module_function(mLapack, "dstein", rb_dstein, -1);
-}
diff --git a/dstemr.c b/dstemr.c
deleted file mode 100644
index a99ce69..0000000
--- a/dstemr.c
+++ /dev/null
@@ -1,162 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstemr_(char *jobz, char *range, integer *n, doublereal *d, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, integer *m, doublereal *w, doublereal *z, integer *ldz, integer *nzc, integer *isuppz, logical *tryrac, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dstemr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_nzc;
- integer nzc;
- VALUE rb_tryrac;
- logical tryrac;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.dstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)\n or\n NumRu::Lapack.dstemr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.DSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in DLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* DLARRV, respectively.\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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_nzc = argv[8];
- rb_tryrac = argv[9];
- rb_lwork = argv[10];
- rb_liwork = argv[11];
-
- vl = NUM2DBL(rb_vl);
- nzc = NUM2INT(rb_nzc);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- il = NUM2INT(rb_il);
- tryrac = (rb_tryrac == Qtrue);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- dstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- rb_tryrac = tryrac ? Qtrue : Qfalse;
- return rb_ary_new3(10, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e, rb_tryrac);
-}
-
-void
-init_lapack_dstemr(VALUE mLapack){
- rb_define_module_function(mLapack, "dstemr", rb_dstemr, -1);
-}
diff --git a/dsteqr.c b/dsteqr.c
deleted file mode 100644
index d672f94..0000000
--- a/dsteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsteqr_(char *compz, integer *n, doublereal *d, doublereal *e, doublereal *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_dsteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
- doublereal *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.dsteqr( compz, d, e, z)\n or\n NumRu::Lapack.dsteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band symmetric matrix can also be found\n* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to\n* tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* symmetric matrix. On entry, Z must contain the\n* orthogonal matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is orthogonally similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(doublereal, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
-
- dsteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_dsteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "dsteqr", rb_dsteqr, -1);
-}
diff --git a/dsterf.c b/dsterf.c
deleted file mode 100644
index 428f868..0000000
--- a/dsterf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsterf_(integer *n, doublereal *d, doublereal *e, integer *info);
-
-static VALUE
-rb_dsterf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.dsterf( d, e)\n or\n NumRu::Lapack.dsterf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTERF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n* using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed to find all of the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- dsterf_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dsterf(VALUE mLapack){
- rb_define_module_function(mLapack, "dsterf", rb_dsterf, -1);
-}
diff --git a/dstev.c b/dstev.c
deleted file mode 100644
index 59ccfe5..0000000
--- a/dstev.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstev_(char *jobz, integer *n, doublereal *d, doublereal *e, doublereal *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_dstev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- doublereal *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, info, d, e = NumRu::Lapack.dstev( jobz, d, e)\n or\n NumRu::Lapack.dstev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n* If JOBZ = 'N', WORK is not referenced.\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, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_jobz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
-
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(doublereal, (lsame_(&jobz,"N") ? 0 : MAX(1,2*n-2)));
-
- dstev_(&jobz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_z, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dstev(VALUE mLapack){
- rb_define_module_function(mLapack, "dstev", rb_dstev, -1);
-}
diff --git a/dstevd.c b/dstevd.c
deleted file mode 100644
index 61f8928..0000000
--- a/dstevd.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstevd_(char *jobz, integer *n, doublereal *d, doublereal *e, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dstevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, work, iwork, info, d, e = NumRu::Lapack.dstevd( jobz, d, e, lwork, liwork)\n or\n NumRu::Lapack.dstevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_lwork = argv[3];
- rb_liwork = argv[4];
-
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- dstevd_(&jobz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_z, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dstevd(VALUE mLapack){
- rb_define_module_function(mLapack, "dstevd", rb_dstevd, -1);
-}
diff --git a/dstevr.c b/dstevr.c
deleted file mode 100644
index 50c14d9..0000000
--- a/dstevr.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstevr_(char *jobz, char *range, integer *n, doublereal *d, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, integer *isuppz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dstevr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstevr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.dstevr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n* Whenever possible, DSTEVR calls DSTEMR to compute the\n* eigenspectrum using Relatively Robust Representations. DSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows. For the i-th\n* unreduced block of T,\n* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n* is a relatively robust representation,\n* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n* relative accuracy by the dqds algorithm,\n* (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n* close to the cluster, and go to step (a),\n* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n* compute the corresponding eigenvector by forming a\n* rank-revealing twisted factorization.\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n* Computer Science Division Technical Report No. UCB//CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of DSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** DSTEIN are called\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal (and\n* minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,20*N).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal (and\n* minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = NUM2INT(rb_lwork);
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (MAX(1,n-1)))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- m = lsame_(&range,"I") ? iu-il+1 : n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = MAX(1,n-1);
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- dstevr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dstevr(VALUE mLapack){
- rb_define_module_function(mLapack, "dstevr", rb_dstevr, -1);
-}
diff --git a/dstevx.c b/dstevx.c
deleted file mode 100644
index 14654f3..0000000
--- a/dstevx.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dstevx_(char *jobz, char *range, integer *n, doublereal *d, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dstevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, d, e = NumRu::Lapack.dstevx( jobz, range, d, e, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.dstevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSTEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix A. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less\n* than or equal to zero, then EPS*|T| will be used in\n* its place, where |T| is the 1-norm of the tridiagonal\n* matrix.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge (INFO > 0), then that\n* column of Z contains the latest approximation to the\n* eigenvector, and the index of the eigenvector is returned\n* in IFAIL. If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (MAX(1,n-1)))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- m = n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = MAX(1,n-1);
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(doublereal, (5*n));
- iwork = ALLOC_N(integer, (5*n));
-
- dstevx_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_dstevx(VALUE mLapack){
- rb_define_module_function(mLapack, "dstevx", rb_dstevx, -1);
-}
diff --git a/dsycon.c b/dsycon.c
deleted file mode 100644
index 2e5742d..0000000
--- a/dsycon.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsycon_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dsycon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dsycon( uplo, a, ipiv, anorm)\n or\n NumRu::Lapack.dsycon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by DSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublereal, (2*n));
- iwork = ALLOC_N(integer, (n));
-
- dsycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dsycon(VALUE mLapack){
- rb_define_module_function(mLapack, "dsycon", rb_dsycon, -1);
-}
diff --git a/dsyconv.c b/dsyconv.c
deleted file mode 100644
index 7fb8ba4..0000000
--- a/dsyconv.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyconv_(char *uplo, char *way, integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work, integer *info);
-
-static VALUE
-rb_dsyconv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_way;
- char way;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info = NumRu::Lapack.dsyconv( uplo, way, a, ipiv)\n or\n NumRu::Lapack.dsyconv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYCONV convert A given by TRF into L and D and vice-versa.\n* Get Non-diag elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_way = argv[1];
- rb_a = argv[2];
- rb_ipiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- way = StringValueCStr(rb_way)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublereal, (MAX(1,n)));
-
- dsyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_info;
-}
-
-void
-init_lapack_dsyconv(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyconv", rb_dsyconv, -1);
-}
diff --git a/dsyequb.c b/dsyequb.c
deleted file mode 100644
index fc46ba3..0000000
--- a/dsyequb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyequb_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, doublereal *work, integer *info);
-
-static VALUE
-rb_dsyequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dsyequb( uplo, a)\n or\n NumRu::Lapack.dsyequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- work = ALLOC_N(doublereal, (3*n));
-
- dsyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
-
- free(work);
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_dsyequb(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyequb", rb_dsyequb, -1);
-}
diff --git a/dsyev.c b/dsyev.c
deleted file mode 100644
index 3ab84b5..0000000
--- a/dsyev.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyev_(char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *w, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dsyev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.dsyev( jobz, uplo, a, lwork)\n or\n NumRu::Lapack.dsyev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for DSYTRD returned by ILAENV.\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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dsyev(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyev", rb_dsyev, -1);
-}
diff --git a/dsyevd.c b/dsyevd.c
deleted file mode 100644
index df22e08..0000000
--- a/dsyevd.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyevd_(char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *w, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dsyevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, iwork, info, a = NumRu::Lapack.dsyevd( jobz, uplo, a, lwork, liwork)\n or\n NumRu::Lapack.dsyevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* Because of large use of BLAS of level 3, DSYEVD needs N**2 more\n* workspace than DSYEVX.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least\n* 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
- rb_liwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsyevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_dsyevd(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyevd", rb_dsyevd, -1);
-}
diff --git a/dsyevr.c b/dsyevr.c
deleted file mode 100644
index 12b1b16..0000000
--- a/dsyevr.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyevr_(char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, integer *isuppz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dsyevr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.dsyevr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* DSYEVR first reduces the matrix A to tridiagonal form T with a call\n* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute\n* the eigenspectrum using Relatively Robust Representations. DSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see DSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of DSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** DSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,26*N).\n* For optimal efficiency, LWORK >= (NB+6)*N,\n* where NB is the max of the blocksize for DSYTRD and DORMTR\n* returned by ILAENV.\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- liwork = NUM2INT(rb_liwork);
- m = lsame_(&range,"I") ? iu-il+1 : n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsyevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_dsyevr(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyevr", rb_dsyevr, -1);
-}
diff --git a/dsyevx.c b/dsyevx.c
deleted file mode 100644
index bfbddf3..0000000
--- a/dsyevx.c
+++ /dev/null
@@ -1,132 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyevx_(char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dsyevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.dsyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)\n or\n NumRu::Lapack.dsyevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSYEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 8*N.\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the max of the blocksize for DSYTRD and DORMTR\n* returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- m = lsame_(&range,"I") ? iu-il+1 : n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- iwork = ALLOC_N(integer, (5*n));
-
- dsyevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a);
-}
-
-void
-init_lapack_dsyevx(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyevx", rb_dsyevx, -1);
-}
diff --git a/dsygs2.c b/dsygs2.c
deleted file mode 100644
index 9f9d375..0000000
--- a/dsygs2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsygs2_(integer *itype, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dsygs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dsygs2( itype, uplo, a, b)\n or\n NumRu::Lapack.dsygs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSYGS2 reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by DPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsygs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dsygs2(VALUE mLapack){
- rb_define_module_function(mLapack, "dsygs2", rb_dsygs2, -1);
-}
diff --git a/dsygst.c b/dsygst.c
deleted file mode 100644
index 3331e06..0000000
--- a/dsygst.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsygst_(integer *itype, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dsygst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dsygst( itype, uplo, a, b)\n or\n NumRu::Lapack.dsygst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSYGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by DPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsygst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dsygst(VALUE mLapack){
- rb_define_module_function(mLapack, "dsygst", rb_dsygst, -1);
-}
diff --git a/dsygv.c b/dsygv.c
deleted file mode 100644
index a4bdaf0..0000000
--- a/dsygv.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsygv_(integer *itype, char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *w, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dsygv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.dsygv( itype, jobz, uplo, a, b, lwork)\n or\n NumRu::Lapack.dsygv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the symmetric positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for DSYTRD returned by ILAENV.\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* > 0: DPOTRF or DSYEV returned an error code:\n* <= N: if INFO = i, DSYEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dsygv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dsygv(VALUE mLapack){
- rb_define_module_function(mLapack, "dsygv", rb_dsygv, -1);
-}
diff --git a/dsygvd.c b/dsygvd.c
deleted file mode 100644
index 18f6cab..0000000
--- a/dsygvd.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsygvd_(integer *itype, char *jobz, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *w, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dsygvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, iwork, info, a, b = NumRu::Lapack.dsygvd( itype, jobz, uplo, a, b, lwork, liwork)\n or\n NumRu::Lapack.dsygvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: DPOTRF or DSYEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if DSYEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
- rb_liwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- liwork = NUM2INT(rb_liwork);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dsygvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_work, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dsygvd(VALUE mLapack){
- rb_define_module_function(mLapack, "dsygvd", rb_dsygvd, -1);
-}
diff --git a/dsygvx.c b/dsygvx.c
deleted file mode 100644
index 6d17a96..0000000
--- a/dsygvx.c
+++ /dev/null
@@ -1,164 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsygvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_dsygvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.dsygvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, ldz, lwork)\n or\n NumRu::Lapack.dsygvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSYGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,8*N).\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the blocksize for DSYTRD returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: DPOTRF or DSYEVX returned an error code:\n* <= N: if INFO = i, DSYEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_vl = argv[6];
- rb_vu = argv[7];
- rb_il = argv[8];
- rb_iu = argv[9];
- rb_abstol = argv[10];
- rb_ldz = argv[11];
- rb_lwork = argv[12];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- vu = NUM2DBL(rb_vu);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
- rb_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (5*n));
-
- dsygvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dsygvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dsygvx", rb_dsygvx, -1);
-}
diff --git a/dsyrfs.c b/dsyrfs.c
deleted file mode 100644
index 3c1efbd..0000000
--- a/dsyrfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyrfs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dsyrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublereal *x_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.dsyrfs( uplo, a, af, ipiv, b, x)\n or\n NumRu::Lapack.dsyrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DSYTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dsyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_dsyrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyrfs", rb_dsyrfs, -1);
-}
diff --git a/dsyrfsx.c b/dsyrfsx.c
deleted file mode 100644
index ba018da..0000000
--- a/dsyrfsx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyrfsx_(char *uplo, char *equed, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dsyrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)\n or\n NumRu::Lapack.dsyrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
- rb_params = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dsyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_dsyrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyrfsx", rb_dsyrfsx, -1);
-}
diff --git a/dsysv.c b/dsysv.c
deleted file mode 100644
index 926c1e4..0000000
--- a/dsysv.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsysv_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dsysv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.dsysv( uplo, a, b, lwork)\n or\n NumRu::Lapack.dsysv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by DSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* DSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DSYTRF, DSYTRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dsysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_dsysv(VALUE mLapack){
- rb_define_module_function(mLapack, "dsysv", rb_dsysv, -1);
-}
diff --git a/dsysvx.c b/dsysvx.c
deleted file mode 100644
index 2f5dc93..0000000
--- a/dsysvx.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsysvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dsysvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_af_out__;
- doublereal *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.dsysvx( fact, uplo, a, af, ipiv, b, lwork)\n or\n NumRu::Lapack.dsysvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a real system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form of\n* A. AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by DSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by DSYTRF.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,3*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n* NB is the optimal blocksize for DSYTRF.\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 (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- lwork = NUM2INT(rb_lwork);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublereal*);
- MEMCPY(af_out__, af, doublereal, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- iwork = ALLOC_N(integer, (n));
-
- dsysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_af, rb_ipiv);
-}
-
-void
-init_lapack_dsysvx(VALUE mLapack){
- rb_define_module_function(mLapack, "dsysvx", rb_dsysvx, -1);
-}
diff --git a/dsysvxx.c b/dsysvxx.c
deleted file mode 100644
index 8e98c0e..0000000
--- a/dsysvxx.c
+++ /dev/null
@@ -1,239 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsysvxx_(char *fact, char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer *ipiv, char *equed, doublereal *s, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dsysvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_af_out__;
- doublereal *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.dsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)\n or\n NumRu::Lapack.dsysvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a double precision system of linear equations A * X = B, where A\n* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
- rb_params = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublereal*);
- MEMCPY(af_out__, af, doublereal, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublereal, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- dsysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(14, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_dsysvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "dsysvxx", rb_dsysvxx, -1);
-}
diff --git a/dsyswapr.c b/dsyswapr.c
deleted file mode 100644
index 3754785..0000000
--- a/dsyswapr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsyswapr_(char *uplo, integer *n, doublereal *a, integer *i1, integer *i2);
-
-static VALUE
-rb_dsyswapr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_i1;
- integer i1;
- VALUE rb_i2;
- integer i2;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.dsyswapr( uplo, a, i1, i2)\n or\n NumRu::Lapack.dsyswapr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* DSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n DOUBLE PRECISION TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSWAP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_i1 = argv[2];
- rb_i2 = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- i1 = NUM2INT(rb_i1);
- i2 = NUM2INT(rb_i2);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsyswapr_(&uplo, &n, a, &i1, &i2);
-
- return rb_a;
-}
-
-void
-init_lapack_dsyswapr(VALUE mLapack){
- rb_define_module_function(mLapack, "dsyswapr", rb_dsyswapr, -1);
-}
diff --git a/dsytd2.c b/dsytd2.c
deleted file mode 100644
index 9d39f0c..0000000
--- a/dsytd2.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytd2_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *d, doublereal *e, doublereal *tau, integer *info);
-
-static VALUE
-rb_dsytd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.dsytd2( uplo, a)\n or\n NumRu::Lapack.dsytd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n* form T by an orthogonal similarity transformation: Q' * A * Q = T.\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) DOUBLE PRECISION 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsytd2_(&uplo, &n, a, &lda, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dsytd2(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytd2", rb_dsytd2, -1);
-}
diff --git a/dsytf2.c b/dsytf2.c
deleted file mode 100644
index 8750dd3..0000000
--- a/dsytf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytf2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_dsytf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.dsytf2( uplo, a)\n or\n NumRu::Lapack.dsytf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DSYTF2 computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) DOUBLE PRECISION 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.204 and l.372\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsytf2_(&uplo, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_dsytf2(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytf2", rb_dsytf2, -1);
-}
diff --git a/dsytrd.c b/dsytrd.c
deleted file mode 100644
index 7aaea08..0000000
--- a/dsytrd.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytrd_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *d, doublereal *e, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dsytrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.dsytrd( uplo, a, lwork)\n or\n NumRu::Lapack.dsytrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRD reduces a real symmetric matrix A to real symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsytrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dsytrd(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytrd", rb_dsytrd, -1);
-}
diff --git a/dsytrf.c b/dsytrf.c
deleted file mode 100644
index 4430141..0000000
--- a/dsytrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytrf_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dsytrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.dsytrf( uplo, a, lwork)\n or\n NumRu::Lapack.dsytrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRF computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DLASYF, DSYTF2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dsytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dsytrf(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytrf", rb_dsytrf, -1);
-}
diff --git a/dsytri.c b/dsytri.c
deleted file mode 100644
index 2f38bd1..0000000
--- a/dsytri.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytri_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work, integer *info);
-
-static VALUE
-rb_dsytri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dsytri( uplo, a, ipiv)\n or\n NumRu::Lapack.dsytri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRI computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* DSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n));
-
- dsytri_(&uplo, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dsytri(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytri", rb_dsytri, -1);
-}
diff --git a/dsytri2.c b/dsytri2.c
deleted file mode 100644
index a2ee32f..0000000
--- a/dsytri2.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytri2_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dsytri2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- integer c__1;
- integer nb;
- integer c__m1;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dsytri2( uplo, a, ipiv, lwork)\n or\n NumRu::Lapack.dsytri2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRI2 computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling DSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DSYTRI2X\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- c__1 = 1;
- uplo = StringValueCStr(rb_uplo)[0];
- c__m1 = -1;
- lwork = NUM2INT(rb_lwork);
- nb = ilaenv_(&c__1, "DSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, ((n+nb+1)*(nb+3)));
-
- dsytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dsytri2(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytri2", rb_dsytri2, -1);
-}
diff --git a/dsytri2x.c b/dsytri2x.c
deleted file mode 100644
index df531b2..0000000
--- a/dsytri2x.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytri2x_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv, doublereal *work, integer *nb, integer *info);
-
-static VALUE
-rb_dsytri2x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_nb;
- integer nb;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dsytri2x( uplo, a, ipiv, nb)\n or\n NumRu::Lapack.dsytri2x # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRI2X computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* DSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_nb = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- nb = NUM2INT(rb_nb);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (n+nb+1)*(nb+3));
-
- dsytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dsytri2x(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytri2x", rb_dsytri2x, -1);
-}
diff --git a/dsytrs.c b/dsytrs.c
deleted file mode 100644
index e5e7cce..0000000
--- a/dsytrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dsytrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dsytrs( uplo, a, ipiv, b)\n or\n NumRu::Lapack.dsytrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by DSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dsytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dsytrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytrs", rb_dsytrs, -1);
-}
diff --git a/dsytrs2.c b/dsytrs2.c
deleted file mode 100644
index 853b046..0000000
--- a/dsytrs2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dsytrs2_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *ldb, real *work, integer *info);
-
-static VALUE
-rb_dsytrs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dsytrs2( uplo, a, ipiv, b)\n or\n NumRu::Lapack.dsytrs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRS2 solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by DSYTRF and converted by DSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (n));
-
- dsytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dsytrs2(VALUE mLapack){
- rb_define_module_function(mLapack, "dsytrs2", rb_dsytrs2, -1);
-}
diff --git a/dtbcon.c b/dtbcon.c
deleted file mode 100644
index 52e2cc0..0000000
--- a/dtbcon.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtbcon_(char *norm, char *uplo, char *diag, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dtbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dtbcon( norm, uplo, diag, kd, ab)\n or\n NumRu::Lapack.dtbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dtbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dtbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dtbcon", rb_dtbcon, -1);
-}
diff --git a/dtbrfs.c b/dtbrfs.c
deleted file mode 100644
index 36fee37..0000000
--- a/dtbrfs.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtbrfs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dtbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.dtbrfs( uplo, trans, diag, kd, ab, b, x)\n or\n NumRu::Lapack.dtbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by DTBTRS or some other\n* means before entering this routine. DTBRFS 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dtbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_dtbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dtbrfs", rb_dtbrfs, -1);
-}
diff --git a/dtbtrs.c b/dtbtrs.c
deleted file mode 100644
index de9aaf3..0000000
--- a/dtbtrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtbtrs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dtbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dtbtrs( uplo, trans, diag, kd, ab, b)\n or\n NumRu::Lapack.dtbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DTBTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by NRHS matrix. A check is made to verify that A is nonsingular.\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 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dtbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dtbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dtbtrs", rb_dtbtrs, -1);
-}
diff --git a/dtfsm.c b/dtfsm.c
deleted file mode 100644
index 8765d37..0000000
--- a/dtfsm.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtfsm_(char *transr, char *side, char *uplo, char *trans, char *diag, integer *m, integer *n, doublereal *alpha, doublereal *a, doublereal *b, integer *ldb);
-
-static VALUE
-rb_dtfsm(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer nt;
- integer ldb;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.dtfsm( transr, side, uplo, trans, diag, m, alpha, a, b)\n or\n NumRu::Lapack.dtfsm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* DTFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = A'.\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'T' or 't' op( A ) = A'.\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) DOUBLE PRECISION array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'T' then RFP is the transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_side = argv[1];
- rb_uplo = argv[2];
- rb_trans = argv[3];
- rb_diag = argv[4];
- rb_m = argv[5];
- rb_alpha = argv[6];
- rb_a = argv[7];
- rb_b = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (8th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
- nt = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- m = NUM2INT(rb_m);
- diag = StringValueCStr(rb_diag)[0];
- alpha = NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- transr = StringValueCStr(rb_transr)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dtfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_dtfsm(VALUE mLapack){
- rb_define_module_function(mLapack, "dtfsm", rb_dtfsm, -1);
-}
diff --git a/dtftri.c b/dtftri.c
deleted file mode 100644
index 4f565b4..0000000
--- a/dtftri.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtftri_(char *transr, char *uplo, char *diag, integer *n, doublereal *a, integer *info);
-
-static VALUE
-rb_dtftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dtftri( transr, uplo, diag, n, a)\n or\n NumRu::Lapack.dtftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* DTFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\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* A (input/output) DOUBLE PRECISION array, dimension (0:nt-1);\n* nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n* Positive Definite matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dtftri_(&transr, &uplo, &diag, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dtftri(VALUE mLapack){
- rb_define_module_function(mLapack, "dtftri", rb_dtftri, -1);
-}
diff --git a/dtfttp.c b/dtfttp.c
deleted file mode 100644
index 92ffdf4..0000000
--- a/dtfttp.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtfttp_(char *transr, char *uplo, integer *n, doublereal *arf, doublereal *ap, integer *info);
-
-static VALUE
-rb_dtfttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_arf;
- doublereal *arf;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.dtfttp( transr, uplo, n, arf)\n or\n NumRu::Lapack.dtfttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* DTFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_arf = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_arf) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_arf) != NA_DFLOAT)
- rb_arf = na_change_type(rb_arf, NA_DFLOAT);
- arf = NA_PTR_TYPE(rb_arf, doublereal*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_ap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
-
- dtfttp_(&transr, &uplo, &n, arf, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_dtfttp(VALUE mLapack){
- rb_define_module_function(mLapack, "dtfttp", rb_dtfttp, -1);
-}
diff --git a/dtfttr.c b/dtfttr.c
deleted file mode 100644
index 70a69a9..0000000
--- a/dtfttr.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtfttr_(char *transr, char *uplo, integer *n, doublereal *arf, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dtfttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_arf;
- doublereal *arf;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- integer ldarf;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.dtfttr( transr, uplo, arf)\n or\n NumRu::Lapack.dtfttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrices ARF and A. N >= 0.\n*\n* ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2).\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* matrix A in RFP format. See the \"Notes\" below for more\n* details.\n*\n* A (output) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER N1, N2, K, NT, NX2, NP1X2\n INTEGER I, J, L, IJ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_arf = argv[2];
-
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
- ldarf = NA_SHAPE0(rb_arf);
- if (NA_TYPE(rb_arf) != NA_DFLOAT)
- rb_arf = na_change_type(rb_arf, NA_DFLOAT);
- arf = NA_PTR_TYPE(rb_arf, doublereal*);
- n = ((int)sqrtf(8*ldarf+1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, doublereal*);
-
- dtfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_dtfttr(VALUE mLapack){
- rb_define_module_function(mLapack, "dtfttr", rb_dtfttr, -1);
-}
diff --git a/dtgevc.c b/dtgevc.c
deleted file mode 100644
index a226003..0000000
--- a/dtgevc.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgevc_(char *side, char *howmny, logical *select, integer *n, doublereal *s, integer *lds, doublereal *p, integer *ldp, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m, doublereal *work, integer *info);
-
-static VALUE
-rb_dtgevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_p;
- doublereal *p;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_vl_out__;
- doublereal *vl_out__;
- VALUE rb_vr_out__;
- doublereal *vr_out__;
- doublereal *work;
-
- integer n;
- integer lds;
- integer ldp;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr)\n or\n NumRu::Lapack.dtgevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of real matrices (S,P), where S is a quasi-triangular matrix\n* and P is upper triangular. Matrix pairs of this type are produced by\n* the generalized Schur factorization of a matrix pair (A,B):\n*\n* A = Q*S*Z**T, B = Q*P*Z**T\n*\n* as computed by DGGHRD + DHGEQZ.\n*\n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal blocks of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the orthogonal factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n* \n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. If w(j) is a real eigenvalue, the corresponding\n* real eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector\n* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n* set to .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) DOUBLE PRECISION array, dimension (LDS,N)\n* The upper quasi-triangular matrix S from a generalized Schur\n* factorization, as computed by DHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) DOUBLE PRECISION array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by DHGEQZ.\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n* of S must be in positive diagonal form.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of left Schur vectors returned by DHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n*\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Z (usually the orthogonal matrix Z\n* of right Schur vectors returned by DHGEQZ).\n*\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B' or 'b', the matrix Z*X;\n* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n* specified by SELECT, stored consecutively in the\n* columns of VR, in the same order as their\n* eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* \n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected real eigenvector occupies one\n* column and each selected complex eigenvector occupies two\n* columns.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Allocation of workspace:\n* ---------- -- ---------\n*\n* WORK( j ) = 1-norm of j-th column of A, above the diagonal\n* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n* WORK( 2*N+1:3*N ) = real part of eigenvector\n* WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n*\n* Rowwise vs. columnwise solution methods:\n* ------- -- ---------- -------- -------\n*\n* Finding a generalized eigenvector consists basically of solving the\n* singular triangular system\n*\n* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)\n*\n* Consider finding the i-th right eigenvector (assume all eigenvalues\n* are real). The equation to be solved is:\n* n i\n* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1\n* k=j k=j\n*\n* where C = (A - w B) (The components v(i+1:n) are 0.)\n*\n* The \"rowwise\" method is:\n*\n* (1) v(i) := 1\n* for j = i-1,. . .,1:\n* i\n* (2) compute s = - sum C(j,k) v(k) and\n* k=j+1\n*\n* (3) v(j) := s / C(j,j)\n*\n* Step 2 is sometimes called the \"dot product\" step, since it is an\n* inner product between the j-th row and the portion of the eigenvector\n* that has been computed so far.\n*\n* The \"columnwise\" method consists basically in doing the sums\n* for all the rows in parallel. As each v(j) is computed, the\n* contribution of v(j) times the j-th column of C is added to the\n* partial sums. Since FORTRAN arrays are stored columnwise, this has\n* the advantage that at each step, the elements of C that are accessed\n* are adjacent to one another, whereas with the rowwise method, the\n* elements accessed at a step are spaced LDS (and LDP) words apart.\n*\n* When finding left eigenvectors, the matrix in question is the\n* transpose of the one in storage, so the rowwise method then\n* actually accesses columns of A and B at each step, and so is the\n* preferred method.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_s = argv[3];
- rb_p = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_p))
- rb_raise(rb_eArgError, "p (5th argument) must be NArray");
- if (NA_RANK(rb_p) != 2)
- rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_p);
- ldp = NA_SHAPE0(rb_p);
- if (NA_TYPE(rb_p) != NA_DFLOAT)
- rb_p = na_change_type(rb_p, NA_DFLOAT);
- p = NA_PTR_TYPE(rb_p, doublereal*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DFLOAT)
- rb_vr = na_change_type(rb_vr, NA_DFLOAT);
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 2)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 1 of p");
- lds = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of p");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublereal*);
- MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, doublereal*);
- MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(doublereal, (6*n));
-
- dtgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
-
- free(work);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_m, rb_info, rb_vl, rb_vr);
-}
-
-void
-init_lapack_dtgevc(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgevc", rb_dtgevc, -1);
-}
diff --git a/dtgex2.c b/dtgex2.c
deleted file mode 100644
index dcce73d..0000000
--- a/dtgex2.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgex2_(logical *wantq, logical *wantz, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *q, integer *ldq, doublereal *z, integer *ldz, integer *j1, integer *n1, integer *n2, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dtgex2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_j1;
- integer j1;
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldq;
- integer ldz;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2)\n or\n NumRu::Lapack.dtgex2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n* (A, B) by an orthogonal equivalence transformation.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11). 1 <= J1 <= N.\n*\n* N1 (input) INTEGER\n* The order of the first block (A11, B11). N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block (A22, B22). N2 = 0, 1 or 2.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n*\n* INFO (output) INTEGER\n* =0: Successful exit\n* >0: If INFO = 1, the transformed matrix (A, B) would be\n* too far from generalized Schur form; the blocks are\n* not swapped and (A, B) and (Q, Z) are unchanged.\n* The problem of swapping is too ill-conditioned.\n* <0: If INFO = -16: LWORK is too small. Appropriate value\n* for LWORK is returned in WORK(1).\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* =====================================================================\n* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO\n* loops. Sven Hammarling, 1/5/02.\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_z = argv[5];
- rb_j1 = argv[6];
- rb_n1 = argv[7];
- rb_n2 = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- n1 = NUM2INT(rb_n1);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- j1 = NUM2INT(rb_j1);
- n2 = NUM2INT(rb_n2);
- lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(doublereal, (lwork));
-
- dtgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &n1, &n2, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_dtgex2(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgex2", rb_dtgex2, -1);
-}
diff --git a/dtgexc.c b/dtgexc.c
deleted file mode 100644
index 5688d78..0000000
--- a/dtgexc.c
+++ /dev/null
@@ -1,162 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgexc_(logical *wantq, logical *wantz, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *q, integer *ldq, doublereal *z, integer *ldz, integer *ifst, integer *ilst, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dtgexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, lwork)\n or\n NumRu::Lapack.dtgexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGEXC reorders the generalized real Schur decomposition of a real\n* matrix pair (A,B) using an orthogonal equivalence transformation\n*\n* (A, B) = Q * (A, B) * Z',\n*\n* so that the diagonal block of (A, B) with row index IFST is moved\n* to row ILST.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the matrix A in generalized real Schur canonical\n* form.\n* On exit, the updated matrix A, again in generalized\n* real Schur canonical form.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the matrix B in generalized real Schur canonical\n* form (A,B).\n* On exit, the updated matrix B, again in generalized\n* real Schur canonical form (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of\n* a 2-by-2 block, it is changed to point to the first row;\n* ILST always points to the first row of the block in its\n* final position (which may differ from its input value by\n* +1 or -1). 1 <= IFST, ILST <= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_z = argv[5];
- rb_ifst = argv[6];
- rb_ilst = argv[7];
- rb_lwork = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- lwork = NUM2INT(rb_lwork);
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dtgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- rb_ifst = INT2NUM(ifst);
- rb_ilst = INT2NUM(ilst);
- return rb_ary_new3(8, rb_work, rb_info, rb_a, rb_b, rb_q, rb_z, rb_ifst, rb_ilst);
-}
-
-void
-init_lapack_dtgexc(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgexc", rb_dtgexc, -1);
-}
diff --git a/dtgsen.c b/dtgsen.c
deleted file mode 100644
index 2d21bb9..0000000
--- a/dtgsen.c
+++ /dev/null
@@ -1,221 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgsen_(integer *ijob, logical *wantq, logical *wantz, logical *select, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal *beta, doublereal *q, integer *ldq, doublereal *z, integer *ldz, integer *m, doublereal *pl, doublereal *pr, doublereal *dif, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dtgsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_alphar;
- doublereal *alphar;
- VALUE rb_alphai;
- doublereal *alphai;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_m;
- integer m;
- VALUE rb_pl;
- doublereal pl;
- VALUE rb_pr;
- doublereal pr;
- VALUE rb_dif;
- doublereal *dif;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- VALUE rb_z_out__;
- doublereal *z_out__;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.dtgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)\n or\n NumRu::Lapack.dtgsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGSEN reorders the generalized real Schur decomposition of a real\n* matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the upper quasi-triangular\n* matrix A and the upper triangular B. The leading columns of Q and\n* Z form orthonormal bases of the corresponding left and right eigen-\n* spaces (deflating subspaces). (A, B) must be in generalized real\n* Schur canonical form (as returned by DGGES), i.e. A is block upper\n* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n* triangular.\n*\n* DTGSEN also computes the generalized eigenvalues\n*\n* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, DTGSEN computes the estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster.\n* To select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension(LDA,N)\n* On entry, the upper quasi-triangular matrix A, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real generalized Schur form of (A,B) were further reduced\n* to triangular form using complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* and if WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right eigen-\n* spaces (deflating subspaces). 0 <= M <= N.\n*\n* PL (output) DOUBLE PRECISION\n* PR (output) DOUBLE PRECISION\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspaces with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3, PL and PR are not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* 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 >= 4*N+16.\n* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+6.\n* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n\n* Further Details\n* ===============\n*\n* DTGSEN first collects the selected eigenvalues by computing\n* orthogonal U and W that move them to the top left corner of (A, B).\n* In other words, the selected eigenvalues are the eigenvalues of\n* (A11, B11) in:\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the transpose of U. The first n1 columns\n* of U and W span the specified pair of left and right eigenspaces\n* (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized real Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see DLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF\n* (IJOB = 2 will be used)). See DTGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_ijob = argv[0];
- rb_wantq = argv[1];
- rb_wantz = argv[2];
- rb_select = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
- rb_lwork = argv[8];
- rb_liwork = argv[9];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- liwork = NUM2INT(rb_liwork);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = ijob==0 ? 0 : MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublereal*);
- MEMCPY(z_out__, z, doublereal, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- dtgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alphar, alphai, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_pl = rb_float_new((double)pl);
- rb_pr = rb_float_new((double)pr);
- rb_info = INT2NUM(info);
- return rb_ary_new3(14, rb_alphar, rb_alphai, rb_beta, rb_m, rb_pl, rb_pr, rb_dif, rb_work, rb_iwork, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_dtgsen(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgsen", rb_dtgsen, -1);
-}
diff --git a/dtgsja.c b/dtgsja.c
deleted file mode 100644
index 59e9844..0000000
--- a/dtgsja.c
+++ /dev/null
@@ -1,208 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgsja_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, integer *k, integer *l, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *tola, doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u, integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer *ldq, doublereal *work, integer *ncycle, integer *info);
-
-static VALUE
-rb_dtgsja(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_tola;
- doublereal tola;
- VALUE rb_tolb;
- doublereal tolb;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_v;
- doublereal *v;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_alpha;
- doublereal *alpha;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_ncycle;
- integer ncycle;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
- VALUE rb_b_out__;
- doublereal *b_out__;
- VALUE rb_u_out__;
- doublereal *u_out__;
- VALUE rb_v_out__;
- doublereal *v_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.dtgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)\n or\n NumRu::Lapack.dtgsja # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* DTGSJA computes the generalized singular value decomposition (GSVD)\n* of two real upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine DGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are orthogonal matrices, Z' denotes the transpose\n* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n* ``diagonal'' matrices, which are of the following structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the orthogonal transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain an orthogonal matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* orthogonal matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain an orthogonal matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* orthogonal matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by DTGSJA.\n* See Further Details.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = max(M,N)*norm(A)*MAZHEPS,\n* TOLB = max(P,N)*norm(B)*MAZHEPS.\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0 and\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) DOUBLE PRECISION array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the orthogonal matrix returned by DGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the orthogonal matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the orthogonal matrix returned by DGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the orthogonal matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the orthogonal matrix returned by DGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the orthogonal matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n* of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_k = argv[3];
- rb_l = argv[4];
- rb_a = argv[5];
- rb_b = argv[6];
- rb_tola = argv[7];
- rb_tolb = argv[8];
- rb_u = argv[9];
- rb_v = argv[10];
- rb_q = argv[11];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (11th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
- p = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DFLOAT)
- rb_v = na_change_type(rb_v, NA_DFLOAT);
- v = NA_PTR_TYPE(rb_v, doublereal*);
- k = NUM2INT(rb_k);
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- l = NUM2INT(rb_l);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (12th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- tola = NUM2DBL(rb_tola);
- tolb = NUM2DBL(rb_tolb);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (10th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
- m = NA_SHAPE1(rb_u);
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_DFLOAT)
- rb_u = na_change_type(rb_u, NA_DFLOAT);
- u = NA_PTR_TYPE(rb_u, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, doublereal*);
- MEMCPY(u_out__, u, doublereal, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublereal*);
- MEMCPY(v_out__, v, doublereal, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- dtgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
-
- free(work);
- rb_ncycle = INT2NUM(ncycle);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_ncycle, rb_info, rb_a, rb_b, rb_u, rb_v, rb_q);
-}
-
-void
-init_lapack_dtgsja(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgsja", rb_dtgsja, -1);
-}
diff --git a/dtgsna.c b/dtgsna.c
deleted file mode 100644
index c0857ef..0000000
--- a/dtgsna.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgsna_(char *job, char *howmny, logical *select, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *dif, integer *mm, integer *m, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dtgsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_dif;
- doublereal *dif;
- VALUE rb_m;
- integer m;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- integer *iwork;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.dtgsna( job, howmny, select, a, b, vl, vr, lwork)\n or\n NumRu::Lapack.dtgsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n* generalized real Schur canonical form (or of any matrix pair\n* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n* Z' denotes the transpose of Z.\n*\n* (A, B) must be in generalized real Schur form (as returned by DGGES),\n* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n* blocks. B is upper triangular.\n*\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The upper quasi-triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by DTGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1.\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns ov VR, as returned by DTGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1.\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), DIF(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of DIF are set to the same value. If\n* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected real\n* eigenvalue one element is used, and for each selected complex\n* conjugate pair of eigenvalues, two elements are used.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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 (N + 6)\n* If JOB = 'E', IWORK is not referenced.\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* Further Details\n* ===============\n*\n* The reciprocal of the condition number of a generalized eigenvalue\n* w = (a, b) is defined as\n*\n* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the left and right eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u.\n* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n* of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number DIF(i) of right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows:\n*\n* a) If the i-th eigenvalue w = (a,b) is real\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1\n* ( 0 S22 ),( 0 T22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(i) is\n*\n* Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n*\n* where sigma-min(Zl) denotes the smallest singular value of the\n* 2(n-1)-by-2(n-1) matrix\n*\n* Zl = [ kron(a, In-1) -kron(1, S22) ]\n* [ kron(b, In-1) -kron(1, T22) ] .\n*\n* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n* Kronecker product between the matrices X and Y.\n*\n* Note that if the default method for computing DIF(i) is wanted\n* (see DLATDF), then the parameter DIFDRI (see below) should be\n* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).\n* See DTGSYL for more details.\n*\n* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2\n* ( 0 S22 ),( 0 T22) n-2\n* 2 n-2 2 n-2\n*\n* and (S11, T11) corresponds to the complex conjugate eigenvalue\n* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n* that\n*\n* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )\n* ( 0 s22 ) ( 0 t22 )\n*\n* where the generalized eigenvalues w = s11/t11 and\n* conjg(w) = s22/t22.\n*\n* Then the reciprocal condition number DIF(i) is bounded by\n*\n* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n*\n* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n* Z1 is the complex 2-by-2 matrix\n*\n* Z1 = [ s11 -s22 ]\n* [ t11 -t22 ],\n*\n* This is done by computing (using real arithmetic) the\n* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n* the determinant of X.\n*\n* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n*\n* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]\n* [ kron(T11', In-2) -kron(I2, T22) ]\n*\n* Note that if the default method for computing DIF is wanted (see\n* DLATDF), then the parameter DIFDRI (see below) should be changed\n* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL\n* for more details.\n*\n* For each eigenvalue/vector specified by SELECT, DIF stores a\n* Frobenius norm-based estimate of Difl.\n*\n* An approximate error bound for the i-th computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
- rb_lwork = argv[7];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DFLOAT)
- rb_vr = na_change_type(rb_vr, NA_DFLOAT);
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = mm;
- rb_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n + 6));
-
- dtgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_s, rb_dif, rb_m, rb_work, rb_info);
-}
-
-void
-init_lapack_dtgsna(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgsna", rb_dtgsna, -1);
-}
diff --git a/dtgsy2.c b/dtgsy2.c
deleted file mode 100644
index e487d23..0000000
--- a/dtgsy2.c
+++ /dev/null
@@ -1,163 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgsy2_(char *trans, integer *ijob, integer *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *c, integer *ldc, doublereal *d, integer *ldd, doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *scale, doublereal *rdsum, doublereal *rdscal, integer *iwork, integer *pq, integer *info);
-
-static VALUE
-rb_dtgsy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_f;
- doublereal *f;
- VALUE rb_rdsum;
- doublereal rdsum;
- VALUE rb_rdscal;
- doublereal rdscal;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_pq;
- integer pq;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_f_out__;
- doublereal *f_out__;
- integer *iwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.dtgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)\n or\n NumRu::Lapack.dtgsy2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n* Purpose\n* =======\n*\n* DTGSY2 solves the generalized Sylvester equation:\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F,\n*\n* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n* must be in generalized Schur canonical form, i.e. A, B are upper\n* quasi triangular and D, E are upper triangular. The solution (R, L)\n* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n* chosen to avoid overflow.\n*\n* In matrix notation solving equation (1) corresponds to solve\n* Z*x = scale*b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n* In the process of solving (1), we solve a number of such systems\n* where Dim(In), Dim(In) = 1 or 2.\n*\n* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* sigma_min(Z) using reverse communicaton with DLACON.\n*\n* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of the matrix pair in\n* DTGSYL. See DTGSYL for details.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* = 2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (DGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA, M)\n* On entry, A contains an upper quasi triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, B contains an upper quasi triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1, N).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)\n* On entry, C contains the right-hand-side of the first matrix\n* equation in (1).\n* On exit, if IJOB = 0, C has been overwritten by the\n* solution R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) DOUBLE PRECISION array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) DOUBLE PRECISION array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix E. LDE >= max(1, N).\n*\n* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)\n* On entry, F contains the right-hand-side of the second matrix\n* equation in (1).\n* On exit, if IJOB = 0, F has been overwritten by the\n* solution L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0. Normally,\n* SCALE = 1.\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by DTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when DTGSY2 is called by\n* DTGSYL.\n*\n* IWORK (workspace) INTEGER array, dimension (M+N+2)\n*\n* PQ (output) INTEGER\n* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n* 8-by-8) solved by this routine.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, the i-th argument had an illegal value.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n* Replaced various illegal calls to DCOPY by calls to DLASET.\n* Sven Hammarling, 27/5/02.\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_rdsum = argv[8];
- rb_rdscal = argv[9];
-
- rdscal = NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- rdsum = NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_DFLOAT)
- rb_f = na_change_type(rb_f, NA_DFLOAT);
- f = NA_PTR_TYPE(rb_f, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, doublereal*);
- MEMCPY(f_out__, f, doublereal, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
- iwork = ALLOC_N(integer, (m+n+2));
-
- dtgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, iwork, &pq, &info);
-
- free(iwork);
- rb_scale = rb_float_new((double)scale);
- rb_pq = INT2NUM(pq);
- rb_info = INT2NUM(info);
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(7, rb_scale, rb_pq, rb_info, rb_c, rb_f, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_dtgsy2(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgsy2", rb_dtgsy2, -1);
-}
diff --git a/dtgsyl.c b/dtgsyl.c
deleted file mode 100644
index 7728cf1..0000000
--- a/dtgsyl.c
+++ /dev/null
@@ -1,165 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtgsyl_(char *trans, integer *ijob, integer *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *c, integer *ldc, doublereal *d, integer *ldd, doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal *scale, doublereal *dif, doublereal *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dtgsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_f;
- doublereal *f;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_dif;
- doublereal dif;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_f_out__;
- doublereal *f_out__;
- integer *iwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, dif, work, info, c, f = NumRu::Lapack.dtgsyl( trans, ijob, a, b, c, d, e, f, lwork)\n or\n NumRu::Lapack.dtgsyl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSYL( 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* DTGSYL 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', DTGSYL 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 DLACON.\n*\n* If IJOB >= 1, DTGSYL 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* ( DGECON 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION 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 DCOPY by calls to DLASET.\n* Sven Hammarling, 1/5/02.\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_lwork = argv[8];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_DFLOAT)
- rb_f = na_change_type(rb_f, NA_DFLOAT);
- f = NA_PTR_TYPE(rb_f, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, doublereal*);
- MEMCPY(f_out__, f, doublereal, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
- iwork = ALLOC_N(integer, (m+n+6));
-
- dtgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_scale = rb_float_new((double)scale);
- rb_dif = rb_float_new((double)dif);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_scale, rb_dif, rb_work, rb_info, rb_c, rb_f);
-}
-
-void
-init_lapack_dtgsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "dtgsyl", rb_dtgsyl, -1);
-}
diff --git a/dtpcon.c b/dtpcon.c
deleted file mode 100644
index d498a28..0000000
--- a/dtpcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtpcon_(char *norm, char *uplo, char *diag, integer *n, doublereal *ap, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dtpcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dtpcon( norm, uplo, diag, ap)\n or\n NumRu::Lapack.dtpcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTPCON 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) DOUBLE PRECISION 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) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dtpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dtpcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dtpcon", rb_dtpcon, -1);
-}
diff --git a/dtprfs.c b/dtprfs.c
deleted file mode 100644
index 7bfdc6f..0000000
--- a/dtprfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dtprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.dtprfs( uplo, trans, diag, ap, b, x)\n or\n NumRu::Lapack.dtprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTPRFS 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 DTPTRS or some other\n* means before entering this routine. DTPRFS 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dtprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_dtprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dtprfs", rb_dtprfs, -1);
-}
diff --git a/dtptri.c b/dtptri.c
deleted file mode 100644
index 5c1d324..0000000
--- a/dtptri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtptri_(char *uplo, char *diag, integer *n, doublereal *ap, integer *info);
-
-static VALUE
-rb_dtptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublereal *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dtptri( uplo, diag, n, ap)\n or\n NumRu::Lapack.dtptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* DTPTRI 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) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublereal*);
- MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- dtptri_(&uplo, &diag, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_dtptri(VALUE mLapack){
- rb_define_module_function(mLapack, "dtptri", rb_dtptri, -1);
-}
diff --git a/dtptrs.c b/dtptrs.c
deleted file mode 100644
index 89d7c69..0000000
--- a/dtptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtptrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dtptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dtptrs( uplo, trans, diag, n, ap, b)\n or\n NumRu::Lapack.dtptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DTPTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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 matrix B. NRHS >= 0.\n*\n* AP (input) DOUBLE PRECISION 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*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dtptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dtptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dtptrs", rb_dtptrs, -1);
-}
diff --git a/dtpttf.c b/dtpttf.c
deleted file mode 100644
index 72ca6e5..0000000
--- a/dtpttf.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtpttf_(char *transr, char *uplo, integer *n, doublereal *ap, doublereal *arf, integer *info);
-
-static VALUE
-rb_dtpttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_arf;
- doublereal *arf;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.dtpttf( transr, uplo, n, ap)\n or\n NumRu::Lapack.dtpttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* DTPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'T': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_arf = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, doublereal*);
-
- dtpttf_(&transr, &uplo, &n, ap, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_dtpttf(VALUE mLapack){
- rb_define_module_function(mLapack, "dtpttf", rb_dtpttf, -1);
-}
diff --git a/dtpttr.c b/dtpttr.c
deleted file mode 100644
index ef0cb12..0000000
--- a/dtpttr.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtpttr_(char *uplo, integer *n, doublereal *ap, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dtpttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.dtpttr( uplo, ap)\n or\n NumRu::Lapack.dtpttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) DOUBLE PRECISION array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -i, the i-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DFLOAT)
- rb_ap = na_change_type(rb_ap, NA_DFLOAT);
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, doublereal*);
-
- dtpttr_(&uplo, &n, ap, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_dtpttr(VALUE mLapack){
- rb_define_module_function(mLapack, "dtpttr", rb_dtpttr, -1);
-}
diff --git a/dtrcon.c b/dtrcon.c
deleted file mode 100644
index 4f1a5c4..0000000
--- a/dtrcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrcon_(char *norm, char *uplo, char *diag, integer *n, doublereal *a, integer *lda, doublereal *rcond, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dtrcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dtrcon( norm, uplo, diag, a)\n or\n NumRu::Lapack.dtrcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRCON estimates the reciprocal of the condition number of a\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dtrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_dtrcon(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrcon", rb_dtrcon, -1);
-}
diff --git a/dtrevc.c b/dtrevc.c
deleted file mode 100644
index 62af0c4..0000000
--- a/dtrevc.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrevc_(char *side, char *howmny, logical *select, integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m, doublereal *work, integer *info);
-
-static VALUE
-rb_dtrevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_select_out__;
- logical *select_out__;
- VALUE rb_vl_out__;
- doublereal *vl_out__;
- VALUE rb_vr_out__;
- doublereal *vr_out__;
- doublereal *work;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, select, vl, vr = NumRu::Lapack.dtrevc( side, howmny, select, t, vl, vr)\n or\n NumRu::Lapack.dtrevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DTREVC computes some or all of the right and/or left eigenvectors of\n* a real upper quasi-triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal blocks of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the orthogonal factor that reduces a matrix\n* A to Schur form T, then Q*X and Q*Y are the matrices of right and\n* left eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* If w(j) is a real eigenvalue, the corresponding real\n* eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector is\n* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n* .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,N)\n* The upper quasi-triangular matrix T in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by DHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by DHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors.\n* If HOWMNY = 'A' or 'B', M is set to N.\n* Each selected real eigenvector occupies one column and each\n* selected complex eigenvector occupies two columns.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DFLOAT)
- rb_vr = na_change_type(rb_vr, NA_DFLOAT);
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_select);
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- select_out__ = NA_PTR_TYPE(rb_select_out__, logical*);
- MEMCPY(select_out__, select, logical, NA_TOTAL(rb_select));
- rb_select = rb_select_out__;
- select = select_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublereal*);
- MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, doublereal*);
- MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(doublereal, (3*n));
-
- dtrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
-
- free(work);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_m, rb_info, rb_select, rb_vl, rb_vr);
-}
-
-void
-init_lapack_dtrevc(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrevc", rb_dtrevc, -1);
-}
diff --git a/dtrexc.c b/dtrexc.c
deleted file mode 100644
index caf3948..0000000
--- a/dtrexc.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrexc_(char *compq, integer *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, integer *ifst, integer *ilst, doublereal *work, integer *info);
-
-static VALUE
-rb_dtrexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- doublereal *t_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- doublereal *work;
-
- integer ldt;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, t, q, ifst, ilst = NumRu::Lapack.dtrexc( compq, t, q, ifst, ilst)\n or\n NumRu::Lapack.dtrexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DTREXC reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n* moved to row ILST.\n*\n* The real Schur form T is reordered by an orthogonal similarity\n* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n* is updated by postmultiplying it with Z.\n*\n* T must be in Schur canonical form (as returned by DHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* Schur canonical form.\n* On exit, the reordered upper quasi-triangular matrix, again\n* in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of T.\n* The block with row index IFST is moved to row ILST, by a\n* sequence of transpositions between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of a\n* 2-by-2 block, it is changed to point to the first row; ILST\n* always points to the first row of the block in its final\n* position (which may differ from its input value by +1 or -1).\n* 1 <= IFST <= N; 1 <= ILST <= N.\n*\n* WORK (workspace) DOUBLE PRECISION 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* = 1: two adjacent blocks were too close to swap (the problem\n* is very ill-conditioned); T may have been partially\n* reordered, and ILST points to the first row of the\n* current position of the block being moved.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_compq = argv[0];
- rb_t = argv[1];
- rb_q = argv[2];
- rb_ifst = argv[3];
- rb_ilst = argv[4];
-
- compq = StringValueCStr(rb_compq)[0];
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (2th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublereal*);
- MEMCPY(t_out__, t, doublereal, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(doublereal, (n));
-
- dtrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- rb_ifst = INT2NUM(ifst);
- rb_ilst = INT2NUM(ilst);
- return rb_ary_new3(5, rb_info, rb_t, rb_q, rb_ifst, rb_ilst);
-}
-
-void
-init_lapack_dtrexc(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrexc", rb_dtrexc, -1);
-}
diff --git a/dtrrfs.c b/dtrrfs.c
deleted file mode 100644
index 5016987..0000000
--- a/dtrrfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_dtrrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.dtrrfs( uplo, trans, diag, a, b, x)\n or\n NumRu::Lapack.dtrrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by DTRTRS or some other\n* means before entering this routine. DTRRFS 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- work = ALLOC_N(doublereal, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- dtrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_dtrrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrrfs", rb_dtrrfs, -1);
-}
diff --git a/dtrsen.c b/dtrsen.c
deleted file mode 100644
index 2064f67..0000000
--- a/dtrsen.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrsen_(char *job, char *compq, logical *select, integer *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal *sep, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_dtrsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_q;
- doublereal *q;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_wr;
- doublereal *wr;
- VALUE rb_wi;
- doublereal *wi;
- VALUE rb_m;
- integer m;
- VALUE rb_s;
- doublereal s;
- VALUE rb_sep;
- doublereal sep;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- doublereal *t_out__;
- VALUE rb_q_out__;
- doublereal *q_out__;
- integer *iwork;
-
- integer n;
- integer ldt;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.dtrsen( job, compq, select, t, q, lwork, liwork)\n or\n NumRu::Lapack.dtrsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRSEN reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n* the leading diagonal blocks of the upper quasi-triangular matrix T,\n* and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n* T must be in Schur canonical form (as returned by DHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elemnts equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, T is overwritten by the reordered matrix T, again in\n* Schur canonical form, with the selected eigenvalues in the\n* leading diagonal blocks.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix which reorders T; the\n* leading M columns of Q form an orthonormal basis for the\n* specified invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* The real and imaginary parts, respectively, of the reordered\n* eigenvalues of T. The eigenvalues are stored in the same\n* order as on the diagonal of T, with WR(i) = T(i,i) and, if\n* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n* WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n* sufficiently ill-conditioned, then its value may differ\n* significantly from its value before reordering.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 < = M <= N.\n*\n* S (output) DOUBLE PRECISION\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If JOB = 'N', LWORK >= max(1,N);\n* if JOB = 'E', LWORK >= max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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 (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOB = 'N' or 'E', LIWORK >= 1;\n* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* = 1: reordering of T failed because some eigenvalues are too\n* close to separate (the problem is very ill-conditioned);\n* T may have been partially reordered, and WR and WI\n* contain the eigenvalues in the same order as in T; S and\n* SEP (if requested) are set to zero.\n*\n\n* Further Details\n* ===============\n*\n* DTRSEN first collects the selected eigenvalues by computing an\n* orthogonal transformation Z to move them to the top left corner of T.\n* In other words, the selected eigenvalues are the eigenvalues of T11\n* in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n* of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the real Schur factorization of a matrix\n* A = Q*T*Q', then the reordered real Schur factorization of A is given\n* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n* the corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_q = argv[4];
- rb_lwork = argv[5];
- rb_liwork = argv[6];
-
- liwork = NUM2INT(rb_liwork);
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DFLOAT)
- rb_q = na_change_type(rb_q, NA_DFLOAT);
- q = NA_PTR_TYPE(rb_q, doublereal*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of q");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublereal*);
- MEMCPY(t_out__, t, doublereal, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublereal*);
- MEMCPY(q_out__, q, doublereal, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
-
- dtrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, wr, wi, &m, &s, &sep, work, &lwork, iwork, &liwork, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_s = rb_float_new((double)s);
- rb_sep = rb_float_new((double)sep);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_wr, rb_wi, rb_m, rb_s, rb_sep, rb_work, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_dtrsen(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrsen", rb_dtrsen, -1);
-}
diff --git a/dtrsna.c b/dtrsna.c
deleted file mode 100644
index 661bf6f..0000000
--- a/dtrsna.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrsna_(char *job, char *howmny, logical *select, integer *n, doublereal *t, integer *ldt, doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep, integer *mm, integer *m, doublereal *work, integer *ldwork, integer *iwork, integer *info);
-
-static VALUE
-rb_dtrsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- doublereal *t;
- VALUE rb_vl;
- doublereal *vl;
- VALUE rb_vr;
- doublereal *vr;
- VALUE rb_ldwork;
- integer ldwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_sep;
- doublereal *sep;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.dtrsna( job, howmny, select, t, vl, vr, ldwork)\n or\n NumRu::Lapack.dtrsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a real upper\n* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n* orthogonal).\n*\n* T must be in Schur canonical form (as returned by DHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,N)\n* The upper quasi-triangular matrix T, in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* DHSEIN or DTREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* DHSEIN or DTREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), SEP(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of SEP are set to the same value. If\n* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* IWORK (workspace) INTEGER array, dimension (2*(N-1))\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
- rb_ldwork = argv[6];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DFLOAT)
- rb_t = na_change_type(rb_t, NA_DFLOAT);
- t = NA_PTR_TYPE(rb_t, doublereal*);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DFLOAT)
- rb_vl = na_change_type(rb_vl, NA_DFLOAT);
- vl = NA_PTR_TYPE(rb_vl, doublereal*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DFLOAT)
- rb_vr = na_change_type(rb_vr, NA_DFLOAT);
- vr = NA_PTR_TYPE(rb_vr, doublereal*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of t");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- job = StringValueCStr(rb_job)[0];
- ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = mm;
- rb_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sep = NA_PTR_TYPE(rb_sep, doublereal*);
- work = ALLOC_N(doublereal, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
- iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : 2*(n-1)));
-
- dtrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, iwork, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_sep, rb_m, rb_info);
-}
-
-void
-init_lapack_dtrsna(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrsna", rb_dtrsna, -1);
-}
diff --git a/dtrsyl.c b/dtrsyl.c
deleted file mode 100644
index 0acd4d0..0000000
--- a/dtrsyl.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *c, integer *ldc, doublereal *scale, integer *info);
-
-static VALUE
-rb_dtrsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trana;
- char trana;
- VALUE rb_tranb;
- char tranb;
- VALUE rb_isgn;
- integer isgn;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublereal *c_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.dtrsyl( trana, tranb, isgn, a, b, c)\n or\n NumRu::Lapack.dtrsyl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* DTRSYL solves the real Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**T, and A and B are both upper quasi-\n* triangular. A is M-by-M and B is N-by-N; the right hand side C and\n* the solution X are M-by-N; and scale is an output scale factor, set\n* <= 1 to avoid overflow in X.\n*\n* A and B must be in Schur canonical form (as returned by DHSEQR), that\n* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n* each 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'T': op(A) = A**T (Transpose)\n* = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'T': op(B) = B**T (Transpose)\n* = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,M)\n* The upper quasi-triangular matrix A, in Schur canonical form.\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* The upper quasi-triangular matrix B, in Schur canonical form.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n* On entry, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) DOUBLE PRECISION\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trana = argv[0];
- rb_tranb = argv[1];
- rb_isgn = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- trana = StringValueCStr(rb_trana)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- tranb = StringValueCStr(rb_tranb)[0];
- isgn = NUM2INT(rb_isgn);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- dtrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_scale, rb_info, rb_c);
-}
-
-void
-init_lapack_dtrsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrsyl", rb_dtrsyl, -1);
-}
diff --git a/dtrti2.c b/dtrti2.c
deleted file mode 100644
index 74e80e1..0000000
--- a/dtrti2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrti2_(char *uplo, char *diag, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dtrti2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dtrti2( uplo, diag, a)\n or\n NumRu::Lapack.dtrti2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTRTI2 computes the inverse of a real upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dtrti2_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dtrti2(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrti2", rb_dtrti2, -1);
-}
diff --git a/dtrtri.c b/dtrtri.c
deleted file mode 100644
index c953ad2..0000000
--- a/dtrtri.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrtri_(char *uplo, char *diag, integer *n, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_dtrtri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dtrtri( uplo, diag, a)\n or\n NumRu::Lapack.dtrtri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTRTRI computes the inverse of a real upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dtrtri_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_dtrtri(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrtri", rb_dtrtri, -1);
-}
diff --git a/dtrtrs.c b/dtrtrs.c
deleted file mode 100644
index 10ebe54..0000000
--- a/dtrtrs.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *info);
-
-static VALUE
-rb_dtrtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublereal *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dtrtrs( uplo, trans, diag, a, b)\n or\n NumRu::Lapack.dtrtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DTRTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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 matrix B. NRHS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublereal*);
- MEMCPY(b_out__, b, doublereal, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- dtrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_dtrtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrtrs", rb_dtrtrs, -1);
-}
diff --git a/dtrttf.c b/dtrttf.c
deleted file mode 100644
index c53d182..0000000
--- a/dtrttf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrttf_(char *transr, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *arf, integer *info);
-
-static VALUE
-rb_dtrttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_arf;
- doublereal *arf;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.dtrttf( transr, uplo, a)\n or\n NumRu::Lapack.dtrttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* DTRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal form is wanted;\n* = 'T': ARF in Transpose form is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N).\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) DOUBLE PRECISION array, dimension (NT).\n* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- transr = StringValueCStr(rb_transr)[0];
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_arf = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, doublereal*);
-
- dtrttf_(&transr, &uplo, &n, a, &lda, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_dtrttf(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrttf", rb_dtrttf, -1);
-}
diff --git a/dtrttp.c b/dtrttp.c
deleted file mode 100644
index c97ea0f..0000000
--- a/dtrttp.c
+++ /dev/null
@@ -1,54 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtrttp_(char *uplo, integer *n, doublereal *a, integer *lda, doublereal *ap, integer *info);
-
-static VALUE
-rb_dtrttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_ap;
- doublereal *ap;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.dtrttp( uplo, a)\n or\n NumRu::Lapack.dtrttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* DTRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, doublereal*);
-
- dtrttp_(&uplo, &n, a, &lda, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_dtrttp(VALUE mLapack){
- rb_define_module_function(mLapack, "dtrttp", rb_dtrttp, -1);
-}
diff --git a/dtzrqf.c b/dtzrqf.c
deleted file mode 100644
index 8914c16..0000000
--- a/dtzrqf.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtzrqf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, integer *info);
-
-static VALUE
-rb_dtzrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dtzrqf( a)\n or\n NumRu::Lapack.dtzrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DTZRZF.\n*\n* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dtzrqf_(&m, &n, a, &lda, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_dtzrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "dtzrqf", rb_dtzrqf, -1);
-}
diff --git a/dtzrzf.c b/dtzrzf.c
deleted file mode 100644
index 6a429df..0000000
--- a/dtzrzf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID dtzrzf_(integer *m, integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info);
-
-static VALUE
-rb_dtzrzf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublereal *tau;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublereal *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dtzrzf( a, lwork)\n or\n NumRu::Lapack.dtzrzf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_lwork = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- lwork = NUM2INT(rb_lwork);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublereal*);
- MEMCPY(a_out__, a, doublereal, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- dtzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_dtzrzf(VALUE mLapack){
- rb_define_module_function(mLapack, "dtzrzf", rb_dtzrzf, -1);
-}
diff --git a/dzsum1.c b/dzsum1.c
deleted file mode 100644
index a14f821..0000000
--- a/dzsum1.c
+++ /dev/null
@@ -1,44 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal dzsum1_(integer *n, doublecomplex *cx, integer *incx);
-
-static VALUE
-rb_dzsum1(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- doublecomplex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb___out__;
- doublereal __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dzsum1( cx, incx)\n or\n NumRu::Lapack.dzsum1 # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* DZSUM1 takes the sum of the absolute values of a complex\n* vector and returns a double precision result.\n*\n* Based on DZASUM from the Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with ZLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX*16 array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX > 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, NINCX\n DOUBLE PRECISION STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
-
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cx);
- if (NA_TYPE(rb_cx) != NA_DCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_DCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, doublecomplex*);
-
- __out__ = dzsum1_(&n, cx, &incx);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_dzsum1(VALUE mLapack){
- rb_define_module_function(mLapack, "dzsum1", rb_dzsum1, -1);
-}
diff --git a/ext/cbbcsd.c b/ext/cbbcsd.c
new file mode 100644
index 0000000..ceebbb9
--- /dev/null
+++ b/ext/cbbcsd.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID cbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, real* theta, real* phi, complex* u1, integer* ldu1, complex* u2, integer* ldu2, complex* v1t, integer* ldv1t, complex* v2t, integer* ldv2t, real* b11d, real* b11e, real* b12d, real* b12e, real* b21d, real* b21e, real* b22d, real* b22e, real* rwork, integer* lrwork, integer* info);
+
+
+static VALUE
+rblapack_cbbcsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_theta;
+ real *theta;
+ VALUE rblapack_phi;
+ real *phi;
+ VALUE rblapack_u1;
+ complex *u1;
+ VALUE rblapack_u2;
+ complex *u2;
+ VALUE rblapack_v1t;
+ complex *v1t;
+ VALUE rblapack_v2t;
+ complex *v2t;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_b11d;
+ real *b11d;
+ VALUE rblapack_b11e;
+ real *b11e;
+ VALUE rblapack_b12d;
+ real *b12d;
+ VALUE rblapack_b12e;
+ real *b12e;
+ VALUE rblapack_b21d;
+ real *b21d;
+ VALUE rblapack_b21e;
+ real *b21e;
+ VALUE rblapack_b22d;
+ real *b22d;
+ VALUE rblapack_b22e;
+ real *b22e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_theta_out__;
+ real *theta_out__;
+ VALUE rblapack_u1_out__;
+ complex *u1_out__;
+ VALUE rblapack_u2_out__;
+ complex *u2_out__;
+ VALUE rblapack_v1t_out__;
+ complex *v1t_out__;
+ VALUE rblapack_v2t_out__;
+ complex *v2t_out__;
+ real *rwork;
+
+ integer q;
+ integer ldu1;
+ integer p;
+ integer ldu2;
+ integer ldv1t;
+ integer ldv2t;
+
+ 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 b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n* Purpose\n* =======\n*\n* CBBCSD computes the CS decomposition of a unitary matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See CUNCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The unitary matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the unitary matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) REAL array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) REAL array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) COMPLEX array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) COMPLEX array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) COMPLEX array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the conjugate transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) COMPLEX array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the conjugate transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) REAL array, dimension (Q)\n* When CBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If CBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) REAL array, dimension (Q-1)\n* When CBBCSD converges, B11E contains zeros. If CBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) REAL array, dimension (Q)\n* When CBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If CBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) REAL array, dimension (Q-1)\n* When CBBCSD converges, B12E contains zeros. If CBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the RWORK array,\n* returns this value as the first entry of the work array, and\n* no error message related to LRWORK 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* > 0: if CBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :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_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_m = argv[5];
+ rblapack_theta = argv[6];
+ rblapack_phi = argv[7];
+ rblapack_u1 = argv[8];
+ rblapack_u2 = argv[9];
+ rblapack_v1t = argv[10];
+ rblapack_v2t = argv[11];
+ if (argc == 13) {
+ rblapack_lrwork = argv[12];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ } else {
+ rblapack_lrwork = Qnil;
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_theta))
+ rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
+ if (NA_RANK(rblapack_theta) != 1)
+ rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
+ q = NA_SHAPE0(rblapack_theta);
+ if (NA_TYPE(rblapack_theta) != NA_SFLOAT)
+ rblapack_theta = na_change_type(rblapack_theta, NA_SFLOAT);
+ theta = NA_PTR_TYPE(rblapack_theta, real*);
+ if (!NA_IsNArray(rblapack_u1))
+ rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_u1) != 2)
+ rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
+ ldu1 = NA_SHAPE0(rblapack_u1);
+ p = NA_SHAPE1(rblapack_u1);
+ if (NA_TYPE(rblapack_u1) != NA_SCOMPLEX)
+ rblapack_u1 = na_change_type(rblapack_u1, NA_SCOMPLEX);
+ u1 = NA_PTR_TYPE(rblapack_u1, complex*);
+ if (!NA_IsNArray(rblapack_v1t))
+ rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v1t) != 2)
+ rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
+ ldv1t = NA_SHAPE0(rblapack_v1t);
+ if (NA_SHAPE1(rblapack_v1t) != q)
+ rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
+ if (NA_TYPE(rblapack_v1t) != NA_SCOMPLEX)
+ rblapack_v1t = na_change_type(rblapack_v1t, NA_SCOMPLEX);
+ v1t = NA_PTR_TYPE(rblapack_v1t, complex*);
+ lrwork = MAX(1,8*q);
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_u2))
+ rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u2) != 2)
+ rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
+ ldu2 = NA_SHAPE0(rblapack_u2);
+ if (NA_SHAPE1(rblapack_u2) != (m-p))
+ rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
+ if (NA_TYPE(rblapack_u2) != NA_SCOMPLEX)
+ rblapack_u2 = na_change_type(rblapack_u2, NA_SCOMPLEX);
+ u2 = NA_PTR_TYPE(rblapack_u2, complex*);
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_v2t))
+ rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
+ if (NA_RANK(rblapack_v2t) != 2)
+ rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
+ ldv2t = NA_SHAPE0(rblapack_v2t);
+ if (NA_SHAPE1(rblapack_v2t) != (m-q))
+ rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
+ if (NA_TYPE(rblapack_v2t) != NA_SCOMPLEX)
+ rblapack_v2t = na_change_type(rblapack_v2t, NA_SCOMPLEX);
+ v2t = NA_PTR_TYPE(rblapack_v2t, complex*);
+ if (!NA_IsNArray(rblapack_phi))
+ rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
+ if (NA_RANK(rblapack_phi) != 1)
+ rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_phi) != (q-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
+ if (NA_TYPE(rblapack_phi) != NA_SFLOAT)
+ rblapack_phi = na_change_type(rblapack_phi, NA_SFLOAT);
+ phi = NA_PTR_TYPE(rblapack_phi, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b11d = NA_PTR_TYPE(rblapack_b11d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b11e = NA_PTR_TYPE(rblapack_b11e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b12d = NA_PTR_TYPE(rblapack_b12d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b12e = NA_PTR_TYPE(rblapack_b12e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b21d = NA_PTR_TYPE(rblapack_b21d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b21e = NA_PTR_TYPE(rblapack_b21e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b22d = NA_PTR_TYPE(rblapack_b22d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b22e = NA_PTR_TYPE(rblapack_b22e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, real*);
+ MEMCPY(theta_out__, theta, real, NA_TOTAL(rblapack_theta));
+ rblapack_theta = rblapack_theta_out__;
+ theta = theta_out__;
+ {
+ int shape[2];
+ shape[0] = ldu1;
+ shape[1] = p;
+ rblapack_u1_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, complex*);
+ MEMCPY(u1_out__, u1, complex, NA_TOTAL(rblapack_u1));
+ rblapack_u1 = rblapack_u1_out__;
+ u1 = u1_out__;
+ {
+ int shape[2];
+ shape[0] = ldu2;
+ shape[1] = m-p;
+ rblapack_u2_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, complex*);
+ MEMCPY(u2_out__, u2, complex, NA_TOTAL(rblapack_u2));
+ rblapack_u2 = rblapack_u2_out__;
+ u2 = u2_out__;
+ {
+ int shape[2];
+ shape[0] = ldv1t;
+ shape[1] = q;
+ rblapack_v1t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, complex*);
+ MEMCPY(v1t_out__, v1t, complex, NA_TOTAL(rblapack_v1t));
+ rblapack_v1t = rblapack_v1t_out__;
+ v1t = v1t_out__;
+ {
+ int shape[2];
+ shape[0] = ldv2t;
+ shape[1] = m-q;
+ rblapack_v2t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, complex*);
+ MEMCPY(v2t_out__, v2t, complex, NA_TOTAL(rblapack_v2t));
+ rblapack_v2t = rblapack_v2t_out__;
+ v2t = v2t_out__;
+ rwork = ALLOC_N(real, (MAX(1,lrwork)));
+
+ cbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, &lrwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
+}
+
+void
+init_lapack_cbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cbbcsd", rblapack_cbbcsd, -1);
+}
diff --git a/ext/cbdsqr.c b/ext/cbdsqr.c
new file mode 100644
index 0000000..eb69ea1
--- /dev/null
+++ b/ext/cbdsqr.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID cbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, real* d, real* e, complex* vt, integer* ldvt, complex* u, integer* ldu, complex* c, integer* ldc, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cbdsqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nru;
+ integer nru;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vt;
+ complex *vt;
+ VALUE rblapack_u;
+ complex *u;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_vt_out__;
+ complex *vt_out__;
+ VALUE rblapack_u_out__;
+ complex *u_out__;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ real *rwork;
+
+ integer n;
+ integer ldvt;
+ integer ncvt;
+ integer ldu;
+ integer ldc;
+ integer ncc;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.cbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**H\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**H*VT instead of\n* P**H, for given complex input matrices U and VT. When U and VT are\n* the unitary matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by CGEBRD, then\n* \n* A = (U*Q) * S * (P**H*VT)\n* \n* is the SVD of A. Optionally, the subroutine may also compute Q**H*C\n* for a given complex input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B.\n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) COMPLEX array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**H * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) COMPLEX array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) COMPLEX array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**H * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* RWORK (workspace) REAL array, dimension (2*N) \n* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.cbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_nru = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vt = argv[4];
+ rblapack_u = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ ncvt = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_SCOMPLEX)
+ rblapack_vt = na_change_type(rblapack_vt, NA_SCOMPLEX);
+ vt = NA_PTR_TYPE(rblapack_vt, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ nru = NUM2INT(rblapack_nru);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (6th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ if (NA_SHAPE1(rblapack_u) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_u) != NA_SCOMPLEX)
+ rblapack_u = na_change_type(rblapack_u, NA_SCOMPLEX);
+ u = NA_PTR_TYPE(rblapack_u, complex*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = ncvt;
+ rblapack_vt_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, complex*);
+ MEMCPY(vt_out__, vt, complex, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, complex*);
+ MEMCPY(u_out__, u, complex, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ rwork = ALLOC_N(real, ((ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)));
+
+ cbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
+}
+
+void
+init_lapack_cbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cbdsqr", rblapack_cbdsqr, -1);
+}
diff --git a/ext/cgbbrd.c b/ext/cgbbrd.c
new file mode 100644
index 0000000..d735bfc
--- /dev/null
+++ b/ext/cgbbrd.c
@@ -0,0 +1,157 @@
+#include "rb_lapack.h"
+
+extern VOID cgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, complex* ab, integer* ldab, real* d, real* e, complex* q, integer* ldq, complex* pt, integer* ldpt, complex* c, integer* ldc, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgbbrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_pt;
+ complex *pt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldc;
+ integer ncc;
+ integer ldq;
+ integer m;
+ integer ldpt;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.cgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBBRD reduces a complex general m-by-n band matrix A to real upper\n* bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) COMPLEX array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) COMPLEX array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) COMPLEX array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) COMPLEX array, dimension (max(M,N))\n*\n* RWORK (workspace) REAL array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.cgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
+ m = ldab;
+ ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = m;
+ rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ {
+ int shape[2];
+ shape[0] = ldpt;
+ shape[1] = n;
+ rblapack_pt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ pt = NA_PTR_TYPE(rblapack_pt, complex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (MAX(m,n)));
+ rwork = ALLOC_N(real, (MAX(m,n)));
+
+ cgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
+}
+
+void
+init_lapack_cgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbbrd", rblapack_cgbbrd, -1);
+}
diff --git a/ext/cgbcon.c b/ext/cgbcon.c
new file mode 100644
index 0000000..2823e9f
--- /dev/null
+++ b/ext/cgbcon.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID cgbcon_(char* norm, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, integer* ipiv, real* anorm, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ 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.cgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBCON estimates the reciprocal of the condition number of a complex\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by CGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\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/(norm(A) * norm(inv(A))).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cgbcon( norm, kl, ku, ab, ipiv, anorm, [: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_norm = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_anorm = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbcon", rblapack_cgbcon, -1);
+}
diff --git a/ext/cgbequ.c b/ext/cgbequ.c
new file mode 100644
index 0000000..1f03088
--- /dev/null
+++ b/ext/cgbequ.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID cgbequ_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cgbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequ( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,m);
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ cgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbequ", rblapack_cgbequ, -1);
+}
diff --git a/ext/cgbequb.c b/ext/cgbequb.c
new file mode 100644
index 0000000..ca141fa
--- /dev/null
+++ b/ext/cgbequb.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID cgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cgbequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from CGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequb( kl, ku, ab, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ m = ldab;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ cgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbequb", rblapack_cgbequb, -1);
+}
diff --git a/ext/cgbrfs.c b/ext/cgbrfs.c
new file mode 100644
index 0000000..7a8dc20
--- /dev/null
+++ b/ext/cgbrfs.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID cgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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.cgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGBTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbrfs", rblapack_cgbrfs, -1);
+}
diff --git a/ext/cgbrfsx.c b/ext/cgbrfsx.c
new file mode 100644
index 0000000..eaf857b
--- /dev/null
+++ b/ext/cgbrfsx.c
@@ -0,0 +1,249 @@
+#include "rb_lapack.h"
+
+extern VOID cgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgbrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.cgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.cgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [: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_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_x = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ 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_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*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ 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*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (8th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_cgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbrfsx", rblapack_cgbrfsx, -1);
+}
diff --git a/ext/cgbsv.c b/ext/cgbsv.c
new file mode 100644
index 0000000..1edeeba
--- /dev/null
+++ b/ext/cgbsv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID cgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cgbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, ab, b = NumRu::Lapack.cgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGBSV computes the solution to a complex system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL CGBTRF, CGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.cgbsv( kl, ku, ab, b, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ ku = NUM2INT(rblapack_ku);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_cgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbsv", rblapack_cgbsv, -1);
+}
diff --git a/ext/cgbsvx.c b/ext/cgbsvx.c
new file mode 100644
index 0000000..2757af2
--- /dev/null
+++ b/ext/cgbsvx.c
@@ -0,0 +1,286 @@
+#include "rb_lapack.h"
+
+extern VOID cgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_afb_out__;
+ complex *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.cgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) COMPLEX array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace/output) REAL array, dimension (N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n* Moved setting of INFO = N+1 so INFO does not subsequently get\n* overwritten. Sven, 17 Mar 05. \n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.cgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 11) {
+ rblapack_afb = argv[6];
+ rblapack_ipiv = argv[7];
+ rblapack_equed = argv[8];
+ rblapack_r = argv[9];
+ rblapack_c = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_afb = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ku = NUM2INT(rblapack_ku);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ }
+ ldafb = 2*kl+ku+1;
+ if (rblapack_afb != Qnil) {
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (option) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_afb) != ldafb)
+ rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = n;
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, complex*);
+ if (rblapack_afb != Qnil) {
+ MEMCPY(afb_out__, afb, complex, NA_TOTAL(rblapack_afb));
+ }
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (2*n));
+
+ cgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_cgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbsvx", rblapack_cgbsvx, -1);
+}
diff --git a/ext/cgbsvxx.c b/ext/cgbsvxx.c
new file mode 100644
index 0000000..e822b79
--- /dev/null
+++ b/ext/cgbsvxx.c
@@ -0,0 +1,289 @@
+#include "rb_lapack.h"
+
+extern VOID cgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgbsvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_afb_out__;
+ real *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.cgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGBSVXX uses the LU factorization to compute the solution to a\n* complex system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In SGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.cgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_equed = argv[7];
+ rblapack_r = argv[8];
+ rblapack_c = argv[9];
+ rblapack_b = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_r))
+ rb_raise(rb_eArgError, "r (9th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th 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_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (10th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ ldx = MAX(1,n);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
+ MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_cgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbsvxx", rblapack_cgbsvxx, -1);
+}
diff --git a/ext/cgbtf2.c b/ext/cgbtf2.c
new file mode 100644
index 0000000..f7eaa36
--- /dev/null
+++ b/ext/cgbtf2.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID cgbtf2_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_cgbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.cgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGBTF2 computes an LU factorization of a complex m-by-n band matrix\n* A using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.cgbtf2( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ cgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_cgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbtf2", rblapack_cgbtf2, -1);
+}
diff --git a/ext/cgbtrf.c b/ext/cgbtrf.c
new file mode 100644
index 0000000..a46dc33
--- /dev/null
+++ b/ext/cgbtrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID cgbtrf_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_cgbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.cgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGBTRF computes an LU factorization of a complex m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.cgbtrf( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ cgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_cgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbtrf", rblapack_cgbtrf, -1);
+}
diff --git a/ext/cgbtrs.c b/ext/cgbtrs.c
new file mode 100644
index 0000000..02d9c60
--- /dev/null
+++ b/ext/cgbtrs.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID cgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cgbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGBTRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general band matrix A using the LU factorization computed\n* by CGBTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.cgbtrs( trans, kl, ku, ab, ipiv, b, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgbtrs", rblapack_cgbtrs, -1);
+}
diff --git a/ext/cgebak.c b/ext/cgebak.c
new file mode 100644
index 0000000..47eef7f
--- /dev/null
+++ b/ext/cgebak.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID cgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* scale, integer* m, complex* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_cgebak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ real *scale;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ complex *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.cgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* CGEBAK forms the right or left eigenvectors of a complex general\n* matrix by backward transformation on the computed eigenvectors of the\n* balanced matrix output by CGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to CGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by CGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) REAL array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by CGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by CHSEIN or CTREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 info, v = NumRu::Lapack.cgebak( job, side, ilo, ihi, scale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_scale = argv[4];
+ rblapack_v = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_scale))
+ rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_scale) != 1)
+ rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_scale);
+ if (NA_TYPE(rblapack_scale) != NA_SFLOAT)
+ rblapack_scale = na_change_type(rblapack_scale, NA_SFLOAT);
+ scale = NA_PTR_TYPE(rblapack_scale, real*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
+ MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ cgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_cgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgebak", rblapack_cgebak, -1);
+}
diff --git a/ext/cgebal.c b/ext/cgebal.c
new file mode 100644
index 0000000..e840c55
--- /dev/null
+++ b/ext/cgebal.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID cgebal_(char* job, integer* n, complex* a, integer* lda, integer* ilo, integer* ihi, real* scale, integer* info);
+
+
+static VALUE
+rblapack_cgebal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ real *scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ilo, ihi, scale, info, a = NumRu::Lapack.cgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* CGEBAL balances a general complex matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine CBAL.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.cgebal( job, 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_job = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
+
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgebal", rblapack_cgebal, -1);
+}
diff --git a/ext/cgebd2.c b/ext/cgebd2.c
new file mode 100644
index 0000000..3906278
--- /dev/null
+++ b/ext/cgebd2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID cgebd2_(integer* m, integer* n, complex* a, integer* lda, real* d, real* e, complex* tauq, complex* taup, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgebd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tauq;
+ complex *tauq;
+ VALUE rblapack_taup;
+ complex *taup;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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 d, e, tauq, taup, info, a = NumRu::Lapack.cgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEBD2 reduces a complex general m by n matrix A to upper or lower\n* real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace) COMPLEX array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit \n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, v and u are complex vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.cgebd2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (MAX(m,n)));
+
+ cgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgebd2", rblapack_cgebd2, -1);
+}
diff --git a/ext/cgebrd.c b/ext/cgebrd.c
new file mode 100644
index 0000000..a55de2d
--- /dev/null
+++ b/ext/cgebrd.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID cgebrd_(integer* m, integer* n, complex* a, integer* lda, real* d, real* e, complex* tauq, complex* taup, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgebrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tauq;
+ complex *tauq;
+ VALUE rblapack_taup;
+ complex *taup;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 d, e, tauq, taup, work, info, a = NumRu::Lapack.cgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEBRD reduces a general complex M-by-N matrix A to upper or lower\n* bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.cgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgebrd", rblapack_cgebrd, -1);
+}
diff --git a/ext/cgecon.c b/ext/cgecon.c
new file mode 100644
index 0000000..9aa934e
--- /dev/null
+++ b/ext/cgecon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID cgecon_(char* norm, integer* n, complex* a, integer* lda, real* anorm, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgecon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ 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 rcond, info = NumRu::Lapack.cgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGECON estimates the reciprocal of the condition number of a general\n* complex matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by CGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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/(norm(A) * norm(inv(A))).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*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.cgecon( norm, a, anorm, [: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_norm = argv[0];
+ rblapack_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgecon", rblapack_cgecon, -1);
+}
diff --git a/ext/cgeequ.c b/ext/cgeequ.c
new file mode 100644
index 0000000..0bcf827
--- /dev/null
+++ b/ext/cgeequ.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID cgeequ_(integer* m, integer* n, complex* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cgeequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ cgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeequ", rblapack_cgeequ, -1);
+}
diff --git a/ext/cgeequb.c b/ext/cgeequb.c
new file mode 100644
index 0000000..0a0d69b
--- /dev/null
+++ b/ext/cgeequb.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID cgeequb_(integer* m, integer* n, complex* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cgeequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from CGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ cgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeequb", rblapack_cgeequb, -1);
+}
diff --git a/ext/cgees.c b/ext/cgees.c
new file mode 100644
index 0000000..656d35d
--- /dev/null
+++ b/ext/cgees.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(complex *arg0){
+ VALUE rblapack_arg0;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+
+ rblapack_ret = rb_yield_values(1, rblapack_arg0);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID cgees_(char* jobvs, char* sort, L_fp select, integer* n, complex* a, integer* lda, integer* sdim, complex* w, complex* vs, integer* ldvs, complex* work, integer* lwork, real* rwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_cgees(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_vs;
+ complex *vs;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, w, vs, work, info, a = NumRu::Lapack.cgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEES computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered:\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* IF SORT = 'N', SELECT is not referenced.\n* The eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues, in the same order that\n* they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged;\n* if JOBVS = 'V', VS contains the matrix which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because\n* some eigenvalues were too close to separate (the\n* problem is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Schur form no longer satisfy\n* SELECT = .TRUE.. This could also be caused by\n* underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, w, vs, work, info, a = NumRu::Lapack.cgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ cgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, w, vs, &ldvs, work, &lwork, rwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgees", rblapack_cgees, -1);
+}
diff --git a/ext/cgeesx.c b/ext/cgeesx.c
new file mode 100644
index 0000000..4091c34
--- /dev/null
+++ b/ext/cgeesx.c
@@ -0,0 +1,152 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(complex *arg0){
+ VALUE rblapack_arg0;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+
+ rblapack_ret = rb_yield_values(1, rblapack_arg0);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID cgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, complex* a, integer* lda, integer* sdim, complex* w, complex* vs, integer* ldvs, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_cgeesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_vs;
+ complex *vs;
+ VALUE rblapack_rconde;
+ real rconde;
+ VALUE rblapack_rcondv;
+ real rcondv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.cgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the N-by-N matrix A.\n* On exit, A is overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues, in the same order\n* that they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) REAL\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n* where SDIM is the number of selected eigenvalues computed by\n* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n* that an error is only returned if LWORK < max(1,2*N), but if\n* SENSE = 'E' or 'V' or 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bound on the optimal size of the\n* array WORK, returns this value as the first entry of the WORK\n* array, and no error message related to LWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) REAL array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.cgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_sense = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[0];
+ sense = StringValueCStr(rblapack_sense)[0];
+ sort = StringValueCStr(rblapack_sort)[0];
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n/2 : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ cgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, w, vs, &ldvs, &rconde, &rcondv, work, &lwork, rwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_rconde = rb_float_new((double)rconde);
+ rblapack_rcondv = rb_float_new((double)rcondv);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeesx", rblapack_cgeesx, -1);
+}
diff --git a/ext/cgeev.c b/ext/cgeev.c
new file mode 100644
index 0000000..7667d91
--- /dev/null
+++ b/ext/cgeev.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID cgeev_(char* jobvl, char* jobvr, integer* n, complex* a, integer* lda, complex* w, complex* vl, integer* ldvl, complex* vr, integer* ldvr, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgeev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 w, vl, vr, work, info, a = NumRu::Lapack.cgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements and i+1:N of W contain eigenvalues which have\n* converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, vl, vr, work, info, a = NumRu::Lapack.cgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (2*n));
+
+ cgeev_(&jobvl, &jobvr, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeev", rblapack_cgeev, -1);
+}
diff --git a/ext/cgeevx.c b/ext/cgeevx.c
new file mode 100644
index 0000000..b3e195d
--- /dev/null
+++ b/ext/cgeevx.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID cgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, complex* a, integer* lda, complex* w, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* ilo, integer* ihi, real* scale, real* abnrm, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgeevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ real *scale;
+ VALUE rblapack_abnrm;
+ real abnrm;
+ VALUE rblapack_rconde;
+ real *rconde;
+ VALUE rblapack_rcondv;
+ real *rcondv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.cgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, ie. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the Schur form of the balanced \n* version of the matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and\n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) REAL array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) REAL array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\n*\n* WORK (workspace/output) COMPLEX 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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n* LWORK >= N*N+2*N.\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of W\n* contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.cgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n+2*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (2*n));
+
+ cgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_w, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeevx", rblapack_cgeevx, -1);
+}
diff --git a/ext/cgegs.c b/ext/cgegs.c
new file mode 100644
index 0000000..f8631f2
--- /dev/null
+++ b/ext/cgegs.c
@@ -0,0 +1,166 @@
+#include "rb_lapack.h"
+
+extern VOID cgegs_(char* jobvsl, char* jobvsr, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vsl, integer* ldvsl, complex* vsr, integer* ldvsr, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgegs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_vsl;
+ complex *vsl;
+ VALUE rblapack_vsr;
+ complex *vsr;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGGES.\n*\n* CGEGS computes the eigenvalues, Schur form, and, optionally, the\n* left and or/right Schur vectors of a complex matrix pair (A,B).\n* Given two square matrices A and B, the generalized Schur\n* factorization has the form\n* \n* A = Q*S*Z**H, B = Q*T*Z**H\n* \n* where Q and Z are unitary matrices and S and T are upper triangular.\n* The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n* \n* If only the eigenvalues of (A,B) are needed, the driver routine\n* CGEGV should be used instead. See CGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper triangular matrix S from the generalized\n* Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur\n* form of A.\n*\n* BETA (output) COMPLEX array, dimension (N)\n* The non-negative real scalars beta that define the\n* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element\n* of the triangular factor T.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* VSL (output) COMPLEX array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n* the optimal LWORK is N*(NB+1).\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* RWORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from CGGBAL\n* =N+2: error return from CGEQRF\n* =N+3: error return from CUNMQR\n* =N+4: error return from CUNGQR\n* =N+5: error return from CGGHRD\n* =N+6: error return from CHGEQZ (other than failed\n* iteration)\n* =N+7: error return from CGGBAK (computing VSL)\n* =N+8: error return from CGGBAK (computing VSR)\n* =N+9: error return from CLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (3*n));
+
+ cgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgegs", rblapack_cgegs, -1);
+}
diff --git a/ext/cgegv.c b/ext/cgegv.c
new file mode 100644
index 0000000..2aed674
--- /dev/null
+++ b/ext/cgegv.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID cgegv_(char* jobvl, char* jobvr, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vl, integer* ldvl, complex* vr, integer* ldvr, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgegv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGGEV.\n*\n* CGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a complex matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n* \n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing. If no\n* eigenvectors were computed, then only the diagonal elements\n* of the Schur form will be correct. See CGGHRD and CHGEQZ\n* for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* elements of B will be correct. See CGGHRD and CHGEQZ for\n* details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP.\n*\n* BETA (output) COMPLEX array, dimension (N)\n* The complex scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n* The optimal LWORK is MAX( 2*N, N*(NB+1) ).\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* RWORK (workspace/output) REAL array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from CGGBAL\n* =N+2: error return from CGEQRF\n* =N+3: error return from CUNMQR\n* =N+4: error return from CUNGQR\n* =N+5: error return from CGGHRD\n* =N+6: error return from CHGEQZ (other than failed\n* iteration)\n* =N+7: error return from CTGEVC\n* =N+8: error return from CGGBAK (computing VL)\n* =N+9: error return from CGGBAK (computing VR)\n* =N+10: error return from CLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls CGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, CGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the complex Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] In other words, upper triangular form.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = 8*n;
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgegv", rblapack_cgegv, -1);
+}
diff --git a/ext/cgehd2.c b/ext/cgehd2.c
new file mode 100644
index 0000000..1ba61be
--- /dev/null
+++ b/ext/cgehd2.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID cgehd2_(integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgehd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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 tau, info, a = NumRu::Lapack.cgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n* by a unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to CGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgehd2( ilo, ihi, a, [: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_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n));
+
+ cgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgehd2", rblapack_cgehd2, -1);
+}
diff --git a/ext/cgehrd.c b/ext/cgehrd.c
new file mode 100644
index 0000000..24852a0
--- /dev/null
+++ b/ext/cgehrd.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cgehrd_(integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgehrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 tau, work, info, a = NumRu::Lapack.cgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n* an unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to CGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) COMPLEX array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgehrd", rblapack_cgehrd, -1);
+}
diff --git a/ext/cgelq2.c b/ext/cgelq2.c
new file mode 100644
index 0000000..9ed4b7d
--- /dev/null
+++ b/ext/cgelq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID cgelq2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgelq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELQ2 computes an LQ factorization of a complex m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgelq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (m));
+
+ cgelq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgelq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgelq2", rblapack_cgelq2, -1);
+}
diff --git a/ext/cgelqf.c b/ext/cgelqf.c
new file mode 100644
index 0000000..54fca61
--- /dev/null
+++ b/ext/cgelqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cgelqf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgelqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 tau, work, info, a = NumRu::Lapack.cgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELQF computes an LQ factorization of a complex M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGELQ2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgelqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgelqf", rblapack_cgelqf, -1);
+}
diff --git a/ext/cgels.c b/ext/cgels.c
new file mode 100644
index 0000000..cb5bf56
--- /dev/null
+++ b/ext/cgels.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID cgels_(char* trans, integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgels(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 work, info, a, b = NumRu::Lapack.cgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELS solves overdetermined or underdetermined complex linear systems\n* involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n* or LQ factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided:\n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of\n* an undetermined system A**H * X = B.\n*\n* 4. If TRANS = 'C' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**H * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'C': the linear system involves A**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by CGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by CGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'C'.\n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of the\n* modulus of elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of the modulus of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.cgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } 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 (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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(4, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cgels(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgels", rblapack_cgels, -1);
+}
diff --git a/ext/cgelsd.c b/ext/cgelsd.c
new file mode 100644
index 0000000..a6c346a
--- /dev/null
+++ b/ext/cgelsd.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID cgelsd_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, real* s, real* rcond, integer* rank, complex* work, integer* lwork, real* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_cgelsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+ integer c__9;
+ integer c__0;
+ integer liwork;
+ integer lrwork;
+ integer nlvl;
+ integer smlsiz;
+
+ 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 s, rank, work, info, b = NumRu::Lapack.cgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder tranformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX 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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 2 * N + N * NRHS\n* if M is greater than or equal to N or\n* 2 * M + M * NRHS\n* if M is less than N, the code will execute correctly.\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the array WORK and the\n* minimum sizes of the arrays RWORK and IWORK, and returns\n* these values as the first entries of the WORK, RWORK and\n* IWORK arrays, and no error message related to LWORK is issued\n* by XERBLA.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n* LRWORK >=\n* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is greater than or equal to N or\n* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, b = NumRu::Lapack.cgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ m = lda;
+ c__9 = 9;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = m>=n ? 2*n+n*nrhs : 2*m+m*nrhs;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ c__0 = 0;
+ smlsiz = ilaenv_(&c__9,"CGELSD"," ",&c__0,&c__0,&c__0,&c__0);
+ nlvl = MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)));
+ liwork = MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)));
+ lrwork = m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (MAX(1,lrwork)));
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+
+ cgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, iwork, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgelsd", rblapack_cgelsd, -1);
+}
diff --git a/ext/cgelss.c b/ext/cgelss.c
new file mode 100644
index 0000000..ceab765
--- /dev/null
+++ b/ext/cgelss.c
@@ -0,0 +1,151 @@
+#include "rb_lapack.h"
+
+extern VOID cgelss_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, real* s, real* rcond, integer* rank, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgelss(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 s, rank, work, info, a, b = NumRu::Lapack.cgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELSS computes the minimum norm solution to a complex linear\n* least squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX 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, and also:\n* LWORK >= 2*min(M,N) + max(M,N,NRHS)\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) REAL array, dimension (5*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.cgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldb = MAX(m, n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (5*MIN(m,n)));
+
+ cgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgelss", rblapack_cgelss, -1);
+}
diff --git a/ext/cgelsx.c b/ext/cgelsx.c
new file mode 100644
index 0000000..40d45b0
--- /dev/null
+++ b/ext/cgelsx.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID cgelsx_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgelsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 rank, info, a, b, jpvt = NumRu::Lapack.cgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGELSY.\n*\n* CGELSX computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) COMPLEX array, dimension\n* (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n*\n* RWORK (workspace) REAL array, dimension (2*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 rank, info, a, b, jpvt = NumRu::Lapack.cgelsx( m, a, b, jpvt, rcond, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_rcond = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(complex, (MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)));
+ rwork = ALLOC_N(real, (2*n));
+
+ cgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_cgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgelsx", rblapack_cgelsx, -1);
+}
diff --git a/ext/cgelsy.c b/ext/cgelsy.c
new file mode 100644
index 0000000..cdf9961
--- /dev/null
+++ b/ext/cgelsy.c
@@ -0,0 +1,166 @@
+#include "rb_lapack.h"
+
+extern VOID cgelsy_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgelsy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 rank, work, info, a, b, jpvt = NumRu::Lapack.cgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGELSY computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace/output) COMPLEX 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.\n* The unblocked strategy requires that:\n* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n* where MN = min(M,N).\n* The block algorithm requires that:\n* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR,\n* and CUNMRZ.\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* RWORK (workspace) REAL array, dimension (2*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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.cgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_jpvt = argv[2];
+ rblapack_rcond = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ ldb = MAX(m,n);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ rwork = ALLOC_N(real, (2*n));
+
+ cgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_cgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgelsy", rblapack_cgelsy, -1);
+}
diff --git a/ext/cgeql2.c b/ext/cgeql2.c
new file mode 100644
index 0000000..18a60a4
--- /dev/null
+++ b/ext/cgeql2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID cgeql2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgeql2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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 tau, info, a = NumRu::Lapack.cgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQL2 computes a QL factorization of a complex m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgeql2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n));
+
+ cgeql2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeql2", rblapack_cgeql2, -1);
+}
diff --git a/ext/cgeqlf.c b/ext/cgeqlf.c
new file mode 100644
index 0000000..e2855e7
--- /dev/null
+++ b/ext/cgeqlf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cgeqlf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgeqlf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 tau, work, info, a = NumRu::Lapack.cgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQLF computes a QL factorization of a complex M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQL2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeqlf", rblapack_cgeqlf, -1);
+}
diff --git a/ext/cgeqp3.c b/ext/cgeqp3.c
new file mode 100644
index 0000000..e1148a5
--- /dev/null
+++ b/ext/cgeqp3.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID cgeqp3_(integer* m, integer* n, complex* a, integer* lda, integer* jpvt, complex* tau, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgeqp3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ real *rwork;
+
+ 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 tau, work, info, a, jpvt = NumRu::Lapack.cgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* unitary matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX 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 >= N+1.\n* For optimal performance LWORK >= ( N+1 )*NB, where NB\n* is the optimal blocksize.\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* RWORK (workspace) REAL array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.cgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n+1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ rwork = ALLOC_N(real, (2*n));
+
+ cgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_cgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeqp3", rblapack_cgeqp3, -1);
+}
diff --git a/ext/cgeqpf.c b/ext/cgeqpf.c
new file mode 100644
index 0000000..6c6ecb3
--- /dev/null
+++ b/ext/cgeqpf.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID cgeqpf_(integer* m, integer* n, complex* a, integer* lda, integer* jpvt, complex* tau, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgeqpf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ complex *work;
+ real *rwork;
+
+ 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 tau, info, a, jpvt = NumRu::Lapack.cgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CGEQP3.\n*\n* CGEQPF computes a QR factorization with column pivoting of a\n* complex M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the unitary matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.cgeqpf( m, a, jpvt, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cgeqpf_(&m, &n, a, &lda, jpvt, tau, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_cgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeqpf", rblapack_cgeqpf, -1);
+}
diff --git a/ext/cgeqr2.c b/ext/cgeqr2.c
new file mode 100644
index 0000000..61b97e3
--- /dev/null
+++ b/ext/cgeqr2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID cgeqr2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgeqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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 tau, info, a = NumRu::Lapack.cgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQR2 computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgeqr2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n));
+
+ cgeqr2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeqr2", rblapack_cgeqr2, -1);
+}
diff --git a/ext/cgeqr2p.c b/ext/cgeqr2p.c
new file mode 100644
index 0000000..4c63493
--- /dev/null
+++ b/ext/cgeqr2p.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID cgeqr2p_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgeqr2p(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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 tau, info, a = NumRu::Lapack.cgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQR2P computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgeqr2p( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n));
+
+ cgeqr2p_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeqr2p", rblapack_cgeqr2p, -1);
+}
diff --git a/ext/cgeqrf.c b/ext/cgeqrf.c
new file mode 100644
index 0000000..1d6357e
--- /dev/null
+++ b/ext/cgeqrf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cgeqrf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgeqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 tau, work, info, a = NumRu::Lapack.cgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQRF computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQR2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeqrf", rblapack_cgeqrf, -1);
+}
diff --git a/ext/cgeqrfp.c b/ext/cgeqrfp.c
new file mode 100644
index 0000000..3da5245
--- /dev/null
+++ b/ext/cgeqrfp.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cgeqrfp_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgeqrfp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 tau, work, info, a = NumRu::Lapack.cgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQR2P, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgeqrfp", rblapack_cgeqrfp, -1);
+}
diff --git a/ext/cgerfs.c b/ext/cgerfs.c
new file mode 100644
index 0000000..236112a
--- /dev/null
+++ b/ext/cgerfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID cgerfs_(char* trans, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgerfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.cgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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)\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* A (input) COMPLEX array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGETRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cgerfs( trans, a, af, ipiv, 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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgerfs", rblapack_cgerfs, -1);
+}
diff --git a/ext/cgerfsx.c b/ext/cgerfsx.c
new file mode 100644
index 0000000..611a1e3
--- /dev/null
+++ b/ext/cgerfsx.c
@@ -0,0 +1,219 @@
+#include "rb_lapack.h"
+
+extern VOID cgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgerfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.cgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. \n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.cgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_r = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_x = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_x))
+ rb_raise(rb_eArgError, "x (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (6th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_cgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgerfsx", rblapack_cgerfsx, -1);
+}
diff --git a/ext/cgerq2.c b/ext/cgerq2.c
new file mode 100644
index 0000000..824b8d3
--- /dev/null
+++ b/ext/cgerq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID cgerq2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgerq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERQ2 computes an RQ factorization of a complex m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the unitary matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.cgerq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (m));
+
+ cgerq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgerq2", rblapack_cgerq2, -1);
+}
diff --git a/ext/cgerqf.c b/ext/cgerqf.c
new file mode 100644
index 0000000..a4a1e27
--- /dev/null
+++ b/ext/cgerqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cgerqf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgerqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 tau, work, info, a = NumRu::Lapack.cgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGERQF computes an RQ factorization of a complex M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL CGERQ2, CLARFB, CLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.cgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgerqf", rblapack_cgerqf, -1);
+}
diff --git a/ext/cgesc2.c b/ext/cgesc2.c
new file mode 100644
index 0000000..376d1e1
--- /dev/null
+++ b/ext/cgesc2.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID cgesc2_(integer* n, complex* a, integer* lda, complex* rhs, integer* ipiv, integer* jpiv, real* scale);
+
+
+static VALUE
+rblapack_cgesc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_rhs;
+ complex *rhs;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_rhs_out__;
+ complex *rhs_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 scale, rhs = NumRu::Lapack.cgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* CGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by CGETC2.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX array, dimension (LDA, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by CGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) COMPLEX array, dimension N.\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) REAL\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.cgesc2( a, rhs, ipiv, jpiv, [: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_a = argv[0];
+ rblapack_rhs = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_jpiv = argv[3];
+ if (argc == 4) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th 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 1 of a");
+ 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_rhs))
+ rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rhs) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_rhs) != NA_SCOMPLEX)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_SCOMPLEX);
+ rhs = NA_PTR_TYPE(rblapack_rhs, complex*);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, complex*);
+ MEMCPY(rhs_out__, rhs, complex, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ cgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
+
+ rblapack_scale = rb_float_new((double)scale);
+ return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
+}
+
+void
+init_lapack_cgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgesc2", rblapack_cgesc2, -1);
+}
diff --git a/ext/cgesdd.c b/ext/cgesdd.c
new file mode 100644
index 0000000..f357f76
--- /dev/null
+++ b/ext/cgesdd.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID cgesdd_(char* jobz, integer* m, integer* n, complex* a, integer* lda, real* s, complex* u, integer* ldu, complex* vt, integer* ldvt, complex* work, integer* lwork, real* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_cgesdd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_u;
+ complex *u;
+ VALUE rblapack_vt;
+ complex *vt;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ucol;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.cgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESDD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors, by using divide-and-conquer method. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**H, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**H are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**H are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* in the array A and all rows of V**H are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**H are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**H are computed.\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 >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**H (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* unitary matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) COMPLEX array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N unitary matrix V**H;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX 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 JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n* if JOBZ = 'O',\n* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* if JOBZ = 'S' or 'A',\n* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, a workspace query is assumed. The optimal\n* size for the WORK array is calculated and stored in WORK(1),\n* and no other work except argument checking is performed.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n* If JOBZ = 'N', LRWORK >= 5*min(M,N).\n* Otherwise, \n* LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The updating process of SBDSDC did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.cgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"N") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,"O") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
+ ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = ucol;
+ rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (MAX(1, (lsame_(&jobz,"N") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))));
+ iwork = ALLOC_N(integer, (8*MIN(m,n)));
+
+ cgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgesdd", rblapack_cgesdd, -1);
+}
diff --git a/ext/cgesv.c b/ext/cgesv.c
new file mode 100644
index 0000000..22687ca
--- /dev/null
+++ b/ext/cgesv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cgesv_(integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cgesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, a, b = NumRu::Lapack.cgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL CGETRF, CGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.cgesv( 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgesv", rblapack_cgesv, -1);
+}
diff --git a/ext/cgesvd.c b/ext/cgesvd.c
new file mode 100644
index 0000000..adc7ff1
--- /dev/null
+++ b/ext/cgesvd.c
@@ -0,0 +1,146 @@
+#include "rb_lapack.h"
+
+extern VOID cgesvd_(char* jobu, char* jobvt, integer* m, integer* n, complex* a, integer* lda, real* s, complex* u, integer* ldu, complex* vt, integer* ldvt, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgesvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobvt;
+ char jobvt;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_u;
+ complex *u;
+ VALUE rblapack_vt;
+ complex *vt;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.cgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESVD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**H, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**H:\n* = 'A': all N rows of V**H are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**H (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**H (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**H (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**H (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M unitary matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) COMPLEX array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N unitary matrix\n* V**H;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) REAL array, dimension (5*min(M,N))\n* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n* unconverged superdiagonal elements of an upper bidiagonal\n* matrix B whose diagonal is in S (not necessarily sorted).\n* B satisfies A = U * B * VT, so it has the same singular\n* values as A, and singular vectors related by U and VT.\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 CBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of RWORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.cgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobu = argv[0];
+ rblapack_jobvt = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
+ jobvt = StringValueCStr(rblapack_jobvt)[0];
+ ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(1, 2*MIN(m,n)+MAX(m,n));
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
+ rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = MAX(n, MIN(m,n));
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
+ __shape__[2] = rblapack_a;
+ na_aset(3, __shape__, rblapack_a_out__);
+ }
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (5*MIN(m,n)));
+
+ cgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
+ rblapack_a = na_aref(2, __shape__, rblapack_a);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgesvd", rblapack_cgesvd, -1);
+}
diff --git a/ext/cgesvx.c b/ext/cgesvx.c
new file mode 100644
index 0000000..f34aa73
--- /dev/null
+++ b/ext/cgesvx.c
@@ -0,0 +1,278 @@
+#include "rb_lapack.h"
+
+extern VOID cgesvx_(char* fact, char* trans, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgesvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.cgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESVX uses the LU factorization to compute the solution to a complex\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace/output) REAL array, dimension (2*N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.cgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 9) {
+ rblapack_af = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_equed = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ } else if (rblapack_options != Qnil) {
+ rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_af = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ldaf = n;
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ }
+ if (rblapack_af != Qnil) {
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (option) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_af) != ldaf)
+ rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = 2*n;
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ if (rblapack_af != Qnil) {
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ }
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (2*n));
+
+ cgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_cgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgesvx", rblapack_cgesvx, -1);
+}
diff --git a/ext/cgesvxx.c b/ext/cgesvxx.c
new file mode 100644
index 0000000..60c811c
--- /dev/null
+++ b/ext/cgesvxx.c
@@ -0,0 +1,281 @@
+#include "rb_lapack.h"
+
+extern VOID cgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgesvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.cgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGESVXX uses the LU factorization to compute the solution to a\n* complex system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In CGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.cgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_r = argv[6];
+ rblapack_c = argv[7];
+ rblapack_b = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_r))
+ rb_raise(rb_eArgError, "r (7th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ ldx = n;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_cgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgesvxx", rblapack_cgesvxx, -1);
+}
diff --git a/ext/cgetc2.c b/ext/cgetc2.c
new file mode 100644
index 0000000..3e65a29
--- /dev/null
+++ b/ext/cgetc2.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID cgetc2_(integer* n, complex* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);
+
+
+static VALUE
+rblapack_cgetc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ipiv, jpiv, info, a = NumRu::Lapack.cgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGETC2 computes an LU factorization, using complete pivoting, of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is a level 1 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the n-by-n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* IPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce overflow if\n* one tries to solve for x in Ax = b. So U is perturbed\n* to avoid the overflow.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.cgetc2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgetc2_(&n, a, &lda, ipiv, jpiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgetc2", rblapack_cgetc2, -1);
+}
diff --git a/ext/cgetf2.c b/ext/cgetf2.c
new file mode 100644
index 0000000..7ff469c
--- /dev/null
+++ b/ext/cgetf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID cgetf2_(integer* m, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_cgetf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ipiv, info, a = NumRu::Lapack.cgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.cgetf2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgetf2_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgetf2", rblapack_cgetf2, -1);
+}
diff --git a/ext/cgetrf.c b/ext/cgetrf.c
new file mode 100644
index 0000000..db9b6ee
--- /dev/null
+++ b/ext/cgetrf.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID cgetrf_(integer* m, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_cgetrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ipiv, info, a = NumRu::Lapack.cgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.cgetrf( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgetrf_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgetrf", rblapack_cgetrf, -1);
+}
diff --git a/ext/cgetri.c b/ext/cgetri.c
new file mode 100644
index 0000000..b9b517e
--- /dev/null
+++ b/ext/cgetri.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cgetri_(integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgetri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 work, info, a = NumRu::Lapack.cgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGETRI computes the inverse of a matrix using the LU factorization\n* computed by CGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_a = argv[0];
+ rblapack_ipiv = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (2th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgetri", rblapack_cgetri, -1);
+}
diff --git a/ext/cgetrs.c b/ext/cgetrs.c
new file mode 100644
index 0000000..5f94caa
--- /dev/null
+++ b/ext/cgetrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cgetrs_(char* trans, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cgetrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGETRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by CGETRF.\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)\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* A (input) COMPLEX array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by CGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from CGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.cgetrs( trans, a, ipiv, b, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgetrs", rblapack_cgetrs, -1);
+}
diff --git a/ext/cggbak.c b/ext/cggbak.c
new file mode 100644
index 0000000..062ab35
--- /dev/null
+++ b/ext/cggbak.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID cggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* lscale, real* rscale, integer* m, complex* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_cggbak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ real *lscale;
+ VALUE rblapack_rscale;
+ real *rscale;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ complex *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.cggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* CGGBAK forms the right or left eigenvectors of a complex generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* CGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to CGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by CGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by CGGBAL.\n*\n* RSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by CGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by CTGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSSCAL, CSWAP, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.cggbak( job, side, ilo, ihi, lscale, rscale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_lscale = argv[4];
+ rblapack_rscale = argv[5];
+ rblapack_v = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_lscale))
+ rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_lscale) != 1)
+ rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_lscale);
+ if (NA_TYPE(rblapack_lscale) != NA_SFLOAT)
+ rblapack_lscale = na_change_type(rblapack_lscale, NA_SFLOAT);
+ lscale = NA_PTR_TYPE(rblapack_lscale, real*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_rscale))
+ rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
+ if (NA_RANK(rblapack_rscale) != 1)
+ rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rscale) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
+ if (NA_TYPE(rblapack_rscale) != NA_SFLOAT)
+ rblapack_rscale = na_change_type(rblapack_rscale, NA_SFLOAT);
+ rscale = NA_PTR_TYPE(rblapack_rscale, real*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
+ MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ cggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_cggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggbak", rblapack_cggbak, -1);
+}
diff --git a/ext/cggbal.c b/ext/cggbal.c
new file mode 100644
index 0000000..b440212
--- /dev/null
+++ b/ext/cggbal.c
@@ -0,0 +1,128 @@
+#include "rb_lapack.h"
+
+extern VOID cggbal_(char* job, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* ilo, integer* ihi, real* lscale, real* rscale, real* work, integer* info);
+
+
+static VALUE
+rblapack_cggbal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ real *lscale;
+ VALUE rblapack_rscale;
+ real *rscale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.cggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGBAL balances a pair of general complex matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i=1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j) is the scaling factor\n* applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) REAL array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.cggbal( job, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_job = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
+
+ cggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
+
+ free(work);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggbal", rblapack_cggbal, -1);
+}
diff --git a/ext/cgges.c b/ext/cgges.c
new file mode 100644
index 0000000..969ba3a
--- /dev/null
+++ b/ext/cgges.c
@@ -0,0 +1,192 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(complex *arg0, complex *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+ rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID cgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* sdim, complex* alpha, complex* beta, complex* vsl, integer* ldvsl, complex* vsr, integer* ldvsr, complex* work, integer* lwork, real* rwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_cgges(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_vsl;
+ complex *vsl;
+ VALUE rblapack_vsr;
+ complex *vsr;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGES computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the generalized complex Schur\n* form (S, T), and optionally left and/or right Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T. The leading\n* columns of VSL and VSR then form an unitary basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* CGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0, and even for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if S\n* and T are upper triangular and, in addition, the diagonal elements\n* of T are non-negative real numbers.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue ALPHA(j)/BETA(j) is selected if\n* SELCTG(ALPHA(j),BETA(j)) is true.\n*\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+2 (See INFO below).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),\n* j=1,...,N are the diagonals of the complex Schur form (A,B)\n* output by CGGES. The BETA(j) will be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) REAL array, dimension (8*N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in CHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering falied in CTGSEN.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (8*n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ cgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgges", rblapack_cgges, -1);
+}
diff --git a/ext/cggesx.c b/ext/cggesx.c
new file mode 100644
index 0000000..ddfb575
--- /dev/null
+++ b/ext/cggesx.c
@@ -0,0 +1,230 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(complex *arg0, complex *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+ rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID cggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* sdim, complex* alpha, complex* beta, complex* vsl, integer* ldvsl, complex* vsr, integer* ldvsr, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, integer* iwork, integer* liwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_cggesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_vsl;
+ complex *vsl;
+ VALUE rblapack_vsr;
+ complex *vsr;
+ VALUE rblapack_rconde;
+ real *rconde;
+ VALUE rblapack_rcondv;
+ real *rcondv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.cggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n* and, optionally, the left and/or right matrices of Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if T is\n* upper triangular with non-negative diagonal and S is upper\n* triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3 see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are\n* the diagonals of the complex Schur form (S,T). BETA(j) will\n* be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) REAL array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition number for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX 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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n* not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) REAL array, dimension ( 8*N )\n* Real workspace.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array WORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+2.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in CHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in CTGSEN.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.cggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 8) {
+ rblapack_lwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+2;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(2*n,n*n/2) : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, complex*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (8*n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ cggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, rwork, iwork, &liwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggesx", rblapack_cggesx, -1);
+}
diff --git a/ext/cggev.c b/ext/cggev.c
new file mode 100644
index 0000000..c373beb
--- /dev/null
+++ b/ext/cggev.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID cggev_(char* jobvl, char* jobvr, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vl, integer* ldvl, complex* vr, integer* ldvr, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cggev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right generalized eigenvector v(j) corresponding to the\n* generalized eigenvalue lambda(j) of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left generalized eigenvector u(j) corresponding to the\n* generalized eigenvalues lambda(j) of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace/output) REAL array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: =N+1: other then QZ iteration failed in SHGEQZ,\n* =N+2: error return from STGEVC.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(1,2*n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = 8*n;
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggev", rblapack_cggev, -1);
+}
diff --git a/ext/cggevx.c b/ext/cggevx.c
new file mode 100644
index 0000000..18d8db2
--- /dev/null
+++ b/ext/cggevx.c
@@ -0,0 +1,226 @@
+#include "rb_lapack.h"
+
+extern VOID cggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* ilo, integer* ihi, real* lscale, real* rscale, real* abnrm, real* bbnrm, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, integer* iwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_cggevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ real *lscale;
+ VALUE rblapack_rscale;
+ real *rscale;
+ VALUE rblapack_abnrm;
+ real abnrm;
+ VALUE rblapack_bbnrm;
+ real bbnrm;
+ VALUE rblapack_rconde;
+ real *rconde;
+ VALUE rblapack_rcondv;
+ real *rcondv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+ integer *iwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+ integer lrwork;
+
+ 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 alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.cggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B) the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* Optionally, it also computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* A * v(j) = lambda(j) * B * v(j) .\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed:\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the complex Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the complex\n* Schur form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n* eigenvalues.\n*\n* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio ALPHA/BETA.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) REAL\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) REAL array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) REAL array, dimension (N)\n* If SENSE = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. If the eigenvalues cannot be reordered to\n* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n* when the true value would be very small anyway. \n* If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,2*N).\n* If SENSE = 'E', LWORK >= max(1,4*N).\n* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*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* RWORK (workspace) REAL array, dimension (lrwork)\n* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n* and at least max(1,2*N) otherwise.\n* Real workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be correct\n* for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in CHGEQZ.\n* =N+2: error return from CTGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.cggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ lrwork = ((lsame_(&balanc,"S")) || (lsame_(&balanc,"B"))) ? MAX(1,6*n) : MAX(1,2*n);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&sense,"E") ? 4*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+2*n : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (lrwork));
+ iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+2));
+ bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
+
+ cggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, rwork, iwork, bwork, &info);
+
+ free(rwork);
+ free(iwork);
+ free(bwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_bbnrm = rb_float_new((double)bbnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(16, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggevx", rblapack_cggevx, -1);
+}
diff --git a/ext/cggglm.c b/ext/cggglm.c
new file mode 100644
index 0000000..599388c
--- /dev/null
+++ b/ext/cggglm.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID cggglm_(integer* n, integer* m, integer* p, complex* a, integer* lda, complex* b, integer* ldb, complex* d, complex* x, complex* y, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cggglm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_d_out__;
+ complex *d_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ integer p;
+ 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 x, y, work, info, a, b, d = NumRu::Lapack.cggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) COMPLEX array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) COMPLEX array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX array, dimension (M)\n* Y (output) COMPLEX array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.cggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_d = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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);
+ p = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_y = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
+ MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+
+ cggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
+}
+
+void
+init_lapack_cggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggglm", rblapack_cggglm, -1);
+}
diff --git a/ext/cgghrd.c b/ext/cgghrd.c
new file mode 100644
index 0000000..b85a7ab
--- /dev/null
+++ b/ext/cgghrd.c
@@ -0,0 +1,167 @@
+#include "rb_lapack.h"
+
+extern VOID cgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* b, integer* ldb, complex* q, integer* ldq, complex* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_cgghrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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, b, q, z = NumRu::Lapack.cgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* CGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n* Hessenberg form using unitary transformations, where A is a\n* general matrix and B is upper triangular. The form of the generalized\n* eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the unitary matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**H*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**H*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**H*x.\n*\n* The unitary matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n* If Q1 is the unitary matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then CGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to CGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**H B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n* from the QR factorization of B.\n* On exit, if COMPQ='I', the unitary matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1.\n* On exit, if COMPZ='I', the unitary matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and van Loan (Johns Hopkins Press).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.cgghrd( compq, compz, ilo, ihi, a, b, q, z, [: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_compq = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ cgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_cgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgghrd", rblapack_cgghrd, -1);
+}
diff --git a/ext/cgglse.c b/ext/cgglse.c
new file mode 100644
index 0000000..fd2c957
--- /dev/null
+++ b/ext/cgglse.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID cgglse_(integer* m, integer* n, integer* p, complex* a, integer* lda, complex* b, integer* ldb, complex* c, complex* d, complex* x, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cgglse(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ VALUE rblapack_d_out__;
+ complex *d_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer m;
+ 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 x, work, info, a, b, c, d = NumRu::Lapack.cgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( (A) ) = N.\n* ( (B) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) COMPLEX array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) COMPLEX array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX array, dimension (N)\n* On exit, X is the solution of the LSE problem.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.cgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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);
+ p = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
+ MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+
+ cgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
+}
+
+void
+init_lapack_cgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgglse", rblapack_cgglse, -1);
+}
diff --git a/ext/cggqrf.c b/ext/cggqrf.c
new file mode 100644
index 0000000..034b9e6
--- /dev/null
+++ b/ext/cggqrf.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID cggqrf_(integer* n, integer* m, integer* p, complex* a, integer* lda, complex* taua, complex* b, integer* ldb, complex* taub, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cggqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ complex *taua;
+ VALUE rblapack_taub;
+ complex *taub;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.cggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n* and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the unitary matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) COMPLEX array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the unitary\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) COMPLEX array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of CUNMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine CUNGQR.\n* To use Q to update another matrix, use LAPACK subroutine CUNMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine CUNGRQ.\n* To use Z to update another matrix, use LAPACK subroutine CUNMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQRF, CGERQF, CUNMQR, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.cggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_n = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ p = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(n,m);
+ rblapack_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(n,p);
+ rblapack_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggqrf", rblapack_cggqrf, -1);
+}
diff --git a/ext/cggrqf.c b/ext/cggrqf.c
new file mode 100644
index 0000000..8c4005f
--- /dev/null
+++ b/ext/cggrqf.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID cggrqf_(integer* m, integer* p, integer* n, complex* a, integer* lda, complex* taua, complex* b, integer* ldb, complex* taub, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cggrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_p;
+ integer p;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ complex *taua;
+ VALUE rblapack_taub;
+ complex *taub;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.cggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the unitary\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the unitary matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) COMPLEX array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of CUNMRQ.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine CUNGRQ.\n* To use Q to update another matrix, use LAPACK subroutine CUNMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine CUNGQR.\n* To use Z to update another matrix, use LAPACK subroutine CUNMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL CGEQRF, CGERQF, CUNMRQ, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.cggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_m = argv[0];
+ rblapack_p = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ p = NUM2INT(rblapack_p);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, complex*);
+ {
+ int shape[1];
+ shape[0] = MIN(p,n);
+ rblapack_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggrqf", rblapack_cggrqf, -1);
+}
diff --git a/ext/cggsvd.c b/ext/cggsvd.c
new file mode 100644
index 0000000..cbfb9dc
--- /dev/null
+++ b/ext/cggsvd.c
@@ -0,0 +1,184 @@
+#include "rb_lapack.h"
+
+extern VOID cggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, complex* a, integer* lda, complex* b, integer* ldb, real* alpha, real* beta, complex* u, integer* ldu, complex* v, integer* ldv, complex* q, integer* ldq, complex* work, real* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_cggsvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_alpha;
+ real *alpha;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_u;
+ complex *u;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.cggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N complex matrix A and P-by-N complex matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are unitary matrices, and Z' means the conjugate\n* transpose of Z. Let K+L = the effective numerical rank of the\n* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n* matrices and of the following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the unitary\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n* equal to the CS decomposition of A and B. Furthermore, the GSVD can\n* be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) )\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains part of the triangular matrix R if\n* M-K-L < 0. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) COMPLEX array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P)+N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine CTGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA REAL\n* TOLB REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n REAL CLANGE, SLAMCH\n EXTERNAL LSAME, CLANGE, SLAMCH\n* ..\n* .. External Subroutines ..\n EXTERNAL CGGSVP, CTGSJA, SCOPY, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.cggsvd( jobu, jobv, jobq, a, b, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, complex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (MAX(3*n,m)*(p)+n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, rwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggsvd", rblapack_cggsvd, -1);
+}
diff --git a/ext/cggsvp.c b/ext/cggsvp.c
new file mode 100644
index 0000000..854af91
--- /dev/null
+++ b/ext/cggsvp.c
@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID cggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* tola, real* tolb, integer* k, integer* l, complex* u, integer* ldu, complex* v, integer* ldv, complex* q, integer* ldq, integer* iwork, real* rwork, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cggsvp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_tola;
+ real tola;
+ VALUE rblapack_tolb;
+ real tolb;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_u;
+ complex *u;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ integer *iwork;
+ real *rwork;
+ complex *tau;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, u, v, q, info, a, b = NumRu::Lapack.cggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGGSVP computes unitary matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* conjugate transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* CGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) COMPLEX array, dimension (LDU,M)\n* If JOBU = 'U', U contains the unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX array, dimension (LDV,P)\n* If JOBV = 'V', V contains the unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* TAU (workspace) COMPLEX array, dimension (N)\n*\n* WORK (workspace) COMPLEX array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine CGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.cggsvp( jobu, jobv, jobq, a, b, tola, tolb, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_tola = argv[5];
+ rblapack_tolb = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ tolb = (real)NUM2DBL(rblapack_tolb);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ tola = (real)NUM2DBL(rblapack_tola);
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, complex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+ rwork = ALLOC_N(real, (2*n));
+ tau = ALLOC_N(complex, (n));
+ work = ALLOC_N(complex, (MAX(3*n,m)*(p)));
+
+ cggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, rwork, tau, work, &info);
+
+ free(iwork);
+ free(rwork);
+ free(tau);
+ free(work);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cggsvp", rblapack_cggsvp, -1);
+}
diff --git a/ext/cgtcon.c b/ext/cgtcon.c
new file mode 100644
index 0000000..55064b3
--- /dev/null
+++ b/ext/cgtcon.c
@@ -0,0 +1,121 @@
+#include "rb_lapack.h"
+
+extern VOID cgtcon_(char* norm, integer* n, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cgtcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_du2;
+ complex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *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 rcond, info = NumRu::Lapack.cgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CGTCON estimates the reciprocal of the condition number of a complex\n* tridiagonal matrix A using the LU factorization as computed by\n* CGTTRF.\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) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by CGTTRF.\n*\n* D (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX 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) COMPLEX array, dimension (2*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.cgtcon( 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ 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_SCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, complex*);
+ 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(complex, (2*n));
+
+ cgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgtcon", rblapack_cgtcon, -1);
+}
diff --git a/ext/cgtrfs.c b/ext/cgtrfs.c
new file mode 100644
index 0000000..15cb128
--- /dev/null
+++ b/ext/cgtrfs.c
@@ -0,0 +1,209 @@
+#include "rb_lapack.h"
+
+extern VOID cgtrfs_(char* trans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* dlf, complex* df, complex* duf, complex* du2, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgtrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_dlf;
+ complex *dlf;
+ VALUE rblapack_df;
+ complex *df;
+ VALUE rblapack_duf;
+ complex *duf;
+ VALUE rblapack_du2;
+ complex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ 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.cgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGTRFS 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)\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) COMPLEX array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by CGTTRF.\n*\n* DF (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CGTTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cgtrfs( 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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_SCOMPLEX)
+ rblapack_df = na_change_type(rblapack_df, NA_SCOMPLEX);
+ df = NA_PTR_TYPE(rblapack_df, complex*);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ 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_SCOMPLEX)
+ rblapack_dlf = na_change_type(rblapack_dlf, NA_SCOMPLEX);
+ dlf = NA_PTR_TYPE(rblapack_dlf, complex*);
+ 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_SCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, complex*);
+ 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_duf = na_change_type(rblapack_duf, NA_SCOMPLEX);
+ duf = NA_PTR_TYPE(rblapack_duf, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgtrfs", rblapack_cgtrfs, -1);
+}
diff --git a/ext/cgtsv.c b/ext/cgtsv.c
new file mode 100644
index 0000000..e78456d
--- /dev/null
+++ b/ext/cgtsv.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern VOID cgtsv_(integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cgtsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ complex *dl_out__;
+ VALUE rblapack_d_out__;
+ complex *d_out__;
+ VALUE rblapack_du_out__;
+ complex *du_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, dl, d, du, b = NumRu::Lapack.cgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) COMPLEX array, dimension (N-1)\n* On entry, DL must contain the (n-1) subdiagonal elements of\n* A.\n* On exit, DL is overwritten by the (n-2) elements of the\n* second superdiagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) COMPLEX array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) COMPLEX array, dimension (N-1)\n* On entry, DU must contain the (n-1) superdiagonal elements\n* of A.\n* On exit, DU is overwritten by the (n-1) elements of the first\n* superdiagonal of U.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.cgtsv( dl, d, du, b, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, complex*);
+ MEMCPY(dl_out__, dl, complex, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
+ MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_du_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, complex*);
+ MEMCPY(du_out__, du, complex, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
+}
+
+void
+init_lapack_cgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgtsv", rblapack_cgtsv, -1);
+}
diff --git a/ext/cgtsvx.c b/ext/cgtsvx.c
new file mode 100644
index 0000000..6678415
--- /dev/null
+++ b/ext/cgtsvx.c
@@ -0,0 +1,256 @@
+#include "rb_lapack.h"
+
+extern VOID cgtsvx_(char* fact, char* trans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* dlf, complex* df, complex* duf, complex* du2, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cgtsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_dlf;
+ complex *dlf;
+ VALUE rblapack_df;
+ complex *df;
+ VALUE rblapack_duf;
+ complex *duf;
+ VALUE rblapack_du2;
+ complex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dlf_out__;
+ complex *dlf_out__;
+ VALUE rblapack_df_out__;
+ complex *df_out__;
+ VALUE rblapack_duf_out__;
+ complex *duf_out__;
+ VALUE rblapack_du2_out__;
+ complex *du2_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ complex *work;
+ real *rwork;
+
+ 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 x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.cgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CGTSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form\n* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n* be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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)\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) COMPLEX array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX array, dimension (N)\n* The n diagonal elements of A.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input or output) COMPLEX array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by CGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) COMPLEX array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) COMPLEX array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) COMPLEX array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by CGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.cgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_dlf = argv[5];
+ rblapack_df = argv[6];
+ rblapack_duf = argv[7];
+ rblapack_du2 = argv[8];
+ rblapack_ipiv = argv[9];
+ rblapack_b = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (7th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (7th 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_SCOMPLEX)
+ rblapack_df = na_change_type(rblapack_df, NA_SCOMPLEX);
+ df = NA_PTR_TYPE(rblapack_df, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (10th 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*);
+ ldx = MAX(1,n);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ if (!NA_IsNArray(rblapack_duf))
+ rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
+ if (NA_RANK(rblapack_duf) != 1)
+ rb_raise(rb_eArgError, "rank of duf (8th 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_SCOMPLEX)
+ rblapack_duf = na_change_type(rblapack_duf, NA_SCOMPLEX);
+ duf = NA_PTR_TYPE(rblapack_duf, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ if (!NA_IsNArray(rblapack_du2))
+ rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_du2) != 1)
+ rb_raise(rb_eArgError, "rank of du2 (9th 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_SCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, complex*);
+ if (!NA_IsNArray(rblapack_dlf))
+ rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_dlf) != 1)
+ rb_raise(rb_eArgError, "rank of dlf (6th 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_SCOMPLEX)
+ rblapack_dlf = na_change_type(rblapack_dlf, NA_SCOMPLEX);
+ dlf = NA_PTR_TYPE(rblapack_dlf, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = n-1;
+ rblapack_dlf_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, complex*);
+ MEMCPY(dlf_out__, dlf, complex, NA_TOTAL(rblapack_dlf));
+ rblapack_dlf = rblapack_dlf_out__;
+ dlf = dlf_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, complex*);
+ MEMCPY(df_out__, df, complex, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_duf_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, complex*);
+ MEMCPY(duf_out__, duf, complex, NA_TOTAL(rblapack_duf));
+ rblapack_duf = rblapack_duf_out__;
+ duf = duf_out__;
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, complex*);
+ MEMCPY(du2_out__, du2, complex, NA_TOTAL(rblapack_du2));
+ rblapack_du2 = rblapack_du2_out__;
+ du2 = du2_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
+}
+
+void
+init_lapack_cgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgtsvx", rblapack_cgtsvx, -1);
+}
diff --git a/ext/cgttrf.c b/ext/cgttrf.c
new file mode 100644
index 0000000..bcd3a08
--- /dev/null
+++ b/ext/cgttrf.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID cgttrf_(integer* n, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_cgttrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_du2;
+ complex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ complex *dl_out__;
+ VALUE rblapack_d_out__;
+ complex *d_out__;
+ VALUE rblapack_du_out__;
+ complex *du_out__;
+
+ 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 du2, ipiv, info, dl, d, du = NumRu::Lapack.cgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CGTTRF computes an LU factorization of a complex tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) COMPLEX array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) COMPLEX array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) COMPLEX array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) COMPLEX array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.cgttrf( dl, d, du, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ du2 = NA_PTR_TYPE(rblapack_du2, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, complex*);
+ MEMCPY(dl_out__, dl, complex, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
+ MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_du_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, complex*);
+ MEMCPY(du_out__, du, complex, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+
+ cgttrf_(&n, dl, d, du, du2, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
+}
+
+void
+init_lapack_cgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgttrf", rblapack_cgttrf, -1);
+}
diff --git a/ext/cgttrs.c b/ext/cgttrs.c
new file mode 100644
index 0000000..3353b7e
--- /dev/null
+++ b/ext/cgttrs.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID cgttrs_(char* trans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cgttrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_du2;
+ complex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CGTTRS solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by CGTTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CGTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cgttrs( trans, dl, d, du, du2, ipiv, b, [: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_trans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ 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_SCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, complex*);
+ 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgttrs", rblapack_cgttrs, -1);
+}
diff --git a/ext/cgtts2.c b/ext/cgtts2.c
new file mode 100644
index 0000000..5b051af
--- /dev/null
+++ b/ext/cgtts2.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID cgtts2_(integer* itrans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, complex* b, integer* ldb);
+
+
+static VALUE
+rblapack_cgtts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itrans;
+ integer itrans;
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_du2;
+ complex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.cgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* CGTTS2 solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by CGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A**T * X = B (Transpose)\n* = 2: A**H * X = B (Conjugate transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX 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) COMPLEX array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n COMPLEX TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.cgtts2( itrans, dl, d, du, du2, ipiv, b, [: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_itrans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itrans = NUM2INT(rblapack_itrans);
+ 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ 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_SCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, complex*);
+ 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_cgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cgtts2", rblapack_cgtts2, -1);
+}
diff --git a/ext/chbev.c b/ext/chbev.c
new file mode 100644
index 0000000..dd52c4c
--- /dev/null
+++ b/ext/chbev.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID chbev_(char* jobz, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chbev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ab = NumRu::Lapack.chbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.chbev( jobz, uplo, kd, ab, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (MAX(1,3*n-2)));
+
+ chbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_chbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbev", rblapack_chbev, -1);
+}
diff --git a/ext/chbevd.c b/ext/chbevd.c
new file mode 100644
index 0000000..a0af886
--- /dev/null
+++ b/ext/chbevd.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID chbevd_(char* jobz, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_chbevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, rwork, iwork, info, ab = NumRu::Lapack.chbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab = NumRu::Lapack.chbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 7) {
+ rblapack_lwork = argv[4];
+ rblapack_lrwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ chbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_chbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbevd", rblapack_chbevd, -1);
+}
diff --git a/ext/chbevx.c b/ext/chbevx.c
new file mode 100644
index 0000000..86d3c89
--- /dev/null
+++ b/ext/chbevx.c
@@ -0,0 +1,160 @@
+#include "rb_lapack.h"
+
+extern VOID chbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, complex* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_chbevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ complex *work;
+ real *rwork;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, ifail, info, ab = NumRu::Lapack.chbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) COMPLEX array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N unitary matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.chbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vu = argv[6];
+ rblapack_il = argv[7];
+ rblapack_iu = argv[8];
+ rblapack_abstol = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ vu = (real)NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
+ range = StringValueCStr(rblapack_range)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ kd = NUM2INT(rblapack_kd);
+ il = NUM2INT(rblapack_il);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ chbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_chbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbevx", rblapack_chbevx, -1);
+}
diff --git a/ext/chbgst.c b/ext/chbgst.c
new file mode 100644
index 0000000..daedb5d
--- /dev/null
+++ b/ext/chbgst.c
@@ -0,0 +1,120 @@
+#include "rb_lapack.h"
+
+extern VOID chbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, complex* x, integer* ldx, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chbgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_bb;
+ complex *bb;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ 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 x, info, ab = NumRu::Lapack.chbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBGST reduces a complex Hermitian-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**H*S by CPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**H*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) COMPLEX array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by CPBSTF, stored in the first kb+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) COMPLEX array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL 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 x, info, ab = NumRu::Lapack.chbgst( vect, uplo, ka, kb, ab, bb, [: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_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, complex*);
+ kb = NUM2INT(rblapack_kb);
+ ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (n));
+
+ chbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_chbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbgst", rblapack_chbgst, -1);
+}
diff --git a/ext/chbgv.c b/ext/chbgv.c
new file mode 100644
index 0000000..ae310a0
--- /dev/null
+++ b/ext/chbgv.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID chbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chbgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_bb;
+ complex *bb;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_bb_out__;
+ complex *bb_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, info, ab, bb = NumRu::Lapack.chbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by CPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHBGST, CHBTRD, CPBSTF, CSTEQR, SSTERF, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.chbgv( jobz, uplo, ka, kb, ab, bb, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, complex*);
+ kb = NUM2INT(rblapack_kb);
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, complex*);
+ MEMCPY(bb_out__, bb, complex, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (3*n));
+
+ chbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_chbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbgv", rblapack_chbgv, -1);
+}
diff --git a/ext/chbgvd.c b/ext/chbgvd.c
new file mode 100644
index 0000000..7dd1134
--- /dev/null
+++ b/ext/chbgvd.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID chbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_chbgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_bb;
+ complex *bb;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_bb_out__;
+ complex *bb_out__;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.chbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by CPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.chbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 9) {
+ rblapack_lwork = argv[6];
+ rblapack_lrwork = argv[7];
+ rblapack_liwork = argv[8];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, complex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ kb = NUM2INT(rblapack_kb);
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, complex*);
+ MEMCPY(bb_out__, bb, complex, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+
+ chbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_chbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbgvd", rblapack_chbgvd, -1);
+}
diff --git a/ext/chbgvx.c b/ext/chbgvx.c
new file mode 100644
index 0000000..0e902ba
--- /dev/null
+++ b/ext/chbgvx.c
@@ -0,0 +1,189 @@
+#include "rb_lapack.h"
+
+extern VOID chbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, complex* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_chbgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_bb;
+ complex *bb;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_bb_out__;
+ complex *bb_out__;
+ complex *work;
+ real *rwork;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, ifail, info, ab, bb = NumRu::Lapack.chbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by CPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) COMPLEX array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n* <= N: then i eigenvectors failed to converge. Their\n* indices are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.chbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ka = argv[3];
+ rblapack_kb = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_bb = argv[6];
+ rblapack_vl = argv[7];
+ rblapack_vu = argv[8];
+ rblapack_il = argv[9];
+ rblapack_iu = argv[10];
+ rblapack_abstol = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kb = NUM2INT(rblapack_kb);
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ n = NA_SHAPE1(rblapack_bb);
+ if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, complex*);
+ vu = (real)NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ il = NUM2INT(rblapack_il);
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ ka = NUM2INT(rblapack_ka);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ vl = (real)NUM2DBL(rblapack_vl);
+ ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, complex*);
+ MEMCPY(bb_out__, bb, complex, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ chbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_chbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbgvx", rblapack_chbgvx, -1);
+}
diff --git a/ext/chbtrd.c b/ext/chbtrd.c
new file mode 100644
index 0000000..314b890
--- /dev/null
+++ b/ext/chbtrd.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID chbtrd_(char* vect, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* d, real* e, complex* q, integer* ldq, complex* work, integer* info);
+
+
+static VALUE
+rblapack_chbtrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ complex *work;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.chbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHBTRD reduces a complex Hermitian band matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.chbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(complex, (n));
+
+ chbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
+}
+
+void
+init_lapack_chbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chbtrd", rblapack_chbtrd, -1);
+}
diff --git a/ext/checon.c b/ext/checon.c
new file mode 100644
index 0000000..948d7df
--- /dev/null
+++ b/ext/checon.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID checon_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);
+
+
+static VALUE
+rblapack_checon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+
+ 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 rcond, info = NumRu::Lapack.checon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHECON estimates the reciprocal of the condition number of a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHETRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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.checon( uplo, a, ipiv, anorm, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(complex, (2*n));
+
+ checon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_checon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "checon", rblapack_checon, -1);
+}
diff --git a/ext/cheequb.c b/ext/cheequb.c
new file mode 100644
index 0000000..ab6d171
--- /dev/null
+++ b/ext/cheequb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID cheequb_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cheequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+
+ 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 s, scond, amax, info = NumRu::Lapack.cheequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cheequb( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ work = ALLOC_N(complex, (3*n));
+
+ cheequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
+
+ free(work);
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cheequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cheequb", rblapack_cheequb, -1);
+}
diff --git a/ext/cheev.c b/ext/cheev.c
new file mode 100644
index 0000000..76ded63
--- /dev/null
+++ b/ext/cheev.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID cheev_(char* jobz, char* uplo, integer* n, complex* a, integer* lda, real* w, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cheev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+
+ 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 w, work, info, a = NumRu::Lapack.cheev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEEV computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for CHETRD returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.cheev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
+
+ cheev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cheev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cheev", rblapack_cheev, -1);
+}
diff --git a/ext/cheevd.c b/ext/cheevd.c
new file mode 100644
index 0000000..566161e
--- /dev/null
+++ b/ext/cheevd.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID cheevd_(char* jobz, char* uplo, integer* n, complex* a, integer* lda, real* w, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_cheevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 w, work, rwork, iwork, info, a = NumRu::Lapack.cheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a = NumRu::Lapack.cheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 6) {
+ rblapack_lwork = argv[3];
+ rblapack_lrwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cheevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cheevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cheevd", rblapack_cheevd, -1);
+}
diff --git a/ext/cheevr.c b/ext/cheevr.c
new file mode 100644
index 0000000..878ab55
--- /dev/null
+++ b/ext/cheevr.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID cheevr_(char* jobz, char* range, char* uplo, integer* n, complex* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, integer* isuppz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_cheevr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.cheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* CHEEVR first reduces the matrix A to tridiagonal form T with a call\n* to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute\n* the eigenspectrum using Relatively Robust Representations. CSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see DSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of CSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** CSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* furutre releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for CHETRD and for\n* CUNMTR as returned by ILAENV.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal\n* (and minimal) LRWORK.\n*\n* LRWORK (input) INTEGER\n* The length of the array RWORK. LRWORK >= max(1,24*N).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal\n* (and minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.cheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 12) {
+ rblapack_lwork = argv[9];
+ rblapack_lrwork = argv[10];
+ rblapack_liwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = 10*n;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lrwork == Qnil)
+ lrwork = 24*n;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cheevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cheevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cheevr", rblapack_cheevr, -1);
+}
diff --git a/ext/cheevx.c b/ext/cheevx.c
new file mode 100644
index 0000000..3e159fd
--- /dev/null
+++ b/ext/cheevx.c
@@ -0,0 +1,160 @@
+#include "rb_lapack.h"
+
+extern VOID cheevx_(char* jobz, char* range, char* uplo, integer* n, complex* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_cheevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a = NumRu::Lapack.cheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHEEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 2*N.\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for CHETRD and for\n* CUNMTR as returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.cheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(real, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ cheevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cheevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cheevx", rblapack_cheevx, -1);
+}
diff --git a/ext/chegs2.c b/ext/chegs2.c
new file mode 100644
index 0000000..97f11b4
--- /dev/null
+++ b/ext/chegs2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID chegs2_(integer* itype, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_chegs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.chegs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHEGS2 reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by CPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.chegs2( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ chegs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_chegs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chegs2", rblapack_chegs2, -1);
+}
diff --git a/ext/chegst.c b/ext/chegst.c
new file mode 100644
index 0000000..624fb96
--- /dev/null
+++ b/ext/chegst.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID chegst_(integer* itype, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_chegst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.chegst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHEGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by CPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.chegst( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ chegst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_chegst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chegst", rblapack_chegst, -1);
+}
diff --git a/ext/chegv.c b/ext/chegv.c
new file mode 100644
index 0000000..4789c62
--- /dev/null
+++ b/ext/chegv.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID chegv_(integer* itype, char* jobz, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* w, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chegv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, info, a, b = NumRu::Lapack.chegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the Hermitian positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for CHETRD returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPOTRF or CHEEV returned an error code:\n* <= N: if INFO = i, CHEEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.chegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
+
+ chegv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_chegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chegv", rblapack_chegv, -1);
+}
diff --git a/ext/chegvd.c b/ext/chegvd.c
new file mode 100644
index 0000000..2aad049
--- /dev/null
+++ b/ext/chegvd.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID chegvd_(integer* itype, char* jobz, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* w, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_chegvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, rwork, iwork, info, a, b = NumRu::Lapack.chegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N + 1.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: CPOTRF or CHEEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if CHEEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a, b = NumRu::Lapack.chegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 8) {
+ rblapack_lwork = argv[5];
+ rblapack_lrwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ chegvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_chegvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chegvd", rblapack_chegvd, -1);
+}
diff --git a/ext/chegvx.c b/ext/chegvx.c
new file mode 100644
index 0000000..b05c55f
--- /dev/null
+++ b/ext/chegvx.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID chegvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_chegvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a, b = NumRu::Lapack.chegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHEGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n**\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for CHETRD returned by ILAENV.\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* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPOTRF or CHEEVX returned an error code:\n* <= N: if INFO = i, CHEEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.chegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vu = argv[7];
+ rblapack_il = argv[8];
+ rblapack_iu = argv[9];
+ rblapack_abstol = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ vu = (real)NUM2DBL(rblapack_vu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ chegvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_chegvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chegvx", rblapack_chegvx, -1);
+}
diff --git a/ext/cherfs.c b/ext/cherfs.c
new file mode 100644
index 0000000..4105209
--- /dev/null
+++ b/ext/cherfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID cherfs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cherfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.cherfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHERFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CHETRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cherfs( uplo, a, af, ipiv, 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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cherfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cherfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cherfs", rblapack_cherfs, -1);
+}
diff --git a/ext/cherfsx.c b/ext/cherfsx.c
new file mode 100644
index 0000000..66671ba
--- /dev/null
+++ b/ext/cherfsx.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID cherfsx_(char* uplo, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cherfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHERFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ n_err_bnds = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cherfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_cherfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cherfsx", rblapack_cherfsx, -1);
+}
diff --git a/ext/chesv.c b/ext/chesv.c
new file mode 100644
index 0000000..4e3f278
--- /dev/null
+++ b/ext/chesv.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID chesv_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_chesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, work, info, a, b = NumRu::Lapack.chesv( uplo, a, b, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**H or A = L*D*L**H as computed by\n* CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CHETRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* CHETRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHETRF, CHETRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.chesv( uplo, a, b, lwork, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_lwork = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ lwork = NUM2INT(rblapack_lwork);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ chesv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_chesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chesv", rblapack_chesv, -1);
+}
diff --git a/ext/chesvx.c b/ext/chesvx.c
new file mode 100644
index 0000000..7eac5b0
--- /dev/null
+++ b/ext/chesvx.c
@@ -0,0 +1,183 @@
+#include "rb_lapack.h"
+
+extern VOID chesvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chesvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.chesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHESVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHETRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CHETRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CHETRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for CHETRF.\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* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.chesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ ldx = MAX(1,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ rwork = ALLOC_N(real, (n));
+
+ chesvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
+}
+
+void
+init_lapack_chesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chesvx", rblapack_chesvx, -1);
+}
diff --git a/ext/chesvxx.c b/ext/chesvxx.c
new file mode 100644
index 0000000..a85f230
--- /dev/null
+++ b/ext/chesvxx.c
@@ -0,0 +1,258 @@
+#include "rb_lapack.h"
+
+extern VOID chesvxx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chesvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.chesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHESVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CHESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CHESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CHESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CHESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by CHETRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by CHETRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.chesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ chesvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_chesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chesvxx", rblapack_chesvxx, -1);
+}
diff --git a/ext/chetd2.c b/ext/chetd2.c
new file mode 100644
index 0000000..a84e76d
--- /dev/null
+++ b/ext/chetd2.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID chetd2_(char* uplo, integer* n, complex* a, integer* lda, real* d, real* e, complex* tau, integer* info);
+
+
+static VALUE
+rblapack_chetd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 d, e, tau, info, a = NumRu::Lapack.chetd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* CHETD2 reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q' * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.chetd2( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ chetd2_(&uplo, &n, a, &lda, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_chetd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chetd2", rblapack_chetd2, -1);
+}
diff --git a/ext/chetf2.c b/ext/chetf2.c
new file mode 100644
index 0000000..e6742fb
--- /dev/null
+++ b/ext/chetf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID chetf2_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_chetf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ipiv, info, a = NumRu::Lapack.chetf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CHETF2 computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the conjugate transpose of U, and D is\n* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.210 and l.392\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.chetf2( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ chetf2_(&uplo, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_chetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chetf2", rblapack_chetf2, -1);
+}
diff --git a/ext/chetrd.c b/ext/chetrd.c
new file mode 100644
index 0000000..3f83bd5
--- /dev/null
+++ b/ext/chetrd.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID chetrd_(char* uplo, integer* n, complex* a, integer* lda, real* d, real* e, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_chetrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 d, e, tau, work, info, a = NumRu::Lapack.chetrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRD reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX 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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.chetrd( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ chetrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_chetrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chetrd", rblapack_chetrd, -1);
+}
diff --git a/ext/chetrf.c b/ext/chetrf.c
new file mode 100644
index 0000000..00044a0
--- /dev/null
+++ b/ext/chetrf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID chetrf_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_chetrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ipiv, work, info, a = NumRu::Lapack.chetrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRF computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CHETF2, CLAHEF, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.chetrf( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ chetrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_chetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chetrf", rblapack_chetrf, -1);
+}
diff --git a/ext/chetri.c b/ext/chetri.c
new file mode 100644
index 0000000..8f75099
--- /dev/null
+++ b/ext/chetri.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID chetri_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* info);
+
+
+static VALUE
+rblapack_chetri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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.chetri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRI computes the inverse of a complex Hermitian indefinite matrix\n* A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n* CHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CHETRF.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* WORK (workspace) COMPLEX 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.chetri( uplo, a, ipiv, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n));
+
+ chetri_(&uplo, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_chetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chetri", rblapack_chetri, -1);
+}
diff --git a/ext/chetrs.c b/ext/chetrs.c
new file mode 100644
index 0000000..e869bf8
--- /dev/null
+++ b/ext/chetrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID chetrs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_chetrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.chetrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHETRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.chetrs( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ chetrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_chetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chetrs", rblapack_chetrs, -1);
+}
diff --git a/ext/chetrs2.c b/ext/chetrs2.c
new file mode 100644
index 0000000..d06221d
--- /dev/null
+++ b/ext/chetrs2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID chetrs2_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* info);
+
+
+static VALUE
+rblapack_chetrs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.chetrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHETRS2 solves a system of linear equations A*X = B with a COMPLEX\n* Hermitian matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) COMPLEX 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 info, b = NumRu::Lapack.chetrs2( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (n));
+
+ chetrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_chetrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chetrs2", rblapack_chetrs2, -1);
+}
diff --git a/ext/chfrk.c b/ext/chfrk.c
new file mode 100644
index 0000000..6840f59
--- /dev/null
+++ b/ext/chfrk.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID chfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, real* alpha, complex* a, integer* lda, real* beta, complex* c);
+
+
+static VALUE
+rblapack_chfrk(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ 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 c = NumRu::Lapack.chfrk( transr, uplo, trans, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* CHFRK performs one of the Hermitian rank--k operations\n*\n* C := alpha*A*conjg( A' ) + beta*C,\n*\n* or\n*\n* C := alpha*conjg( A' )*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n Hermitian\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.\n*\n* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with\n* TRANS = 'C' or 'c', K specifies the number of rows of the\n* matrix A. K must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n* C (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the matrix A in RFP Format. RFP Format is\n* described by TRANSR, UPLO and N. Note that the imaginary\n* parts of the diagonal elements need not be set, they are\n* assumed to be zero, and on exit they are set to zero.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.chfrk( transr, uplo, trans, k, alpha, a, beta, c, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_k = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_a = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ beta = (real)NUM2DBL(rblapack_beta);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ ldc = NA_SHAPE0(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ n = ((int)sqrtf(ldc*8+1.0f)-1)/2;
+ k = NUM2INT(rblapack_k);
+ lda = lsame_(&trans,"N") ? MAX(1,n) : MAX(1,k);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_a) != lda)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)");
+ if (NA_SHAPE1(rblapack_a) != (lsame_(&trans,"N") ? k : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = ldc;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ chfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
+
+ return rblapack_c;
+}
+
+void
+init_lapack_chfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chfrk", rblapack_chfrk, -1);
+}
diff --git a/ext/chgeqz.c b/ext/chgeqz.c
new file mode 100644
index 0000000..729ad11
--- /dev/null
+++ b/ext/chgeqz.c
@@ -0,0 +1,208 @@
+#include "rb_lapack.h"
+
+extern VOID chgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* t, integer* ldt, complex* alpha, complex* beta, complex* q, integer* ldq, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chgeqz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_t_out__;
+ complex *t_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+ real *rwork;
+
+ integer ldh;
+ integer n;
+ integer ldt;
+ integer ldq;
+ integer ldz;
+
+ 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 alpha, beta, work, info, h, t, q, z = NumRu::Lapack.chgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the single-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a complex matrix pair (A,B):\n* \n* A = Q1*H*Z1**H, B = Q1*T*Z1**H,\n* \n* as computed by CGGHRD.\n* \n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**H, T = Q*P*Z**H,\n* \n* where Q and Z are unitary matrices and S and P are upper triangular.\n* \n* Optionally, the unitary matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* unitary matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the unitary matrices from CGGHRD that reduced\n* the matrix pair (A,B) to generalized Hessenberg form, then the output\n* matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n* Schur factorization of (A,B):\n* \n* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T)\n* (equivalently, of (A,B)) are computed as a pair of complex values\n* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an\n* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* The values of alpha and beta for the i-th eigenvalue can be read\n* directly from the generalized Schur form: alpha = S(i,i),\n* beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Computer eigenvalues and the Schur form.\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain a unitary matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) COMPLEX array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper triangular\n* matrix S from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of H matches that of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) COMPLEX array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of T matches that of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(i) = S(i,i) in the generalized Schur\n* factorization.\n*\n* BETA (output) COMPLEX array, dimension (N)\n* The real non-negative scalars beta that define the\n* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized\n* Schur factorization.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of right Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,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* RWORK (workspace) REAL 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* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* We assume that complex ABS works as long as its value is less than\n* overflow.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, work, info, h, t, q, z = NumRu::Lapack.chgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_compz = argv[2];
+ rblapack_ilo = argv[3];
+ rblapack_ihi = argv[4];
+ rblapack_h = argv[5];
+ rblapack_t = argv[6];
+ rblapack_q = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ compz = StringValueCStr(rblapack_compz)[0];
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ n = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (8th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
+ MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ rwork = ALLOC_N(real, (n));
+
+ chgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alpha, beta, q, &ldq, z, &ldz, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_chgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chgeqz", rblapack_chgeqz, -1);
+}
diff --git a/ext/chla_transtype.c b/ext/chla_transtype.c
new file mode 100644
index 0000000..4e86004
--- /dev/null
+++ b/ext/chla_transtype.c
@@ -0,0 +1,51 @@
+#include "rb_lapack.h"
+
+extern VOID chla_transtype_(char *__out__, integer* trans);
+
+
+static VALUE
+rblapack_chla_transtype(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack___out__;
+ char __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 __out__ = NumRu::Lapack.chla_transtype( trans, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS )\n\n* Purpose\n* =======\n*\n* This subroutine translates from a BLAST-specified integer constant to\n* the character string specifying a transposition operation.\n*\n* CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE is 'X',\n* then input is not an integer indicating a transposition operator.\n* Otherwise CHLA_TRANSTYPE returns the constant value corresponding to\n* TRANS.\n*\n\n* Arguments\n* =========\n* TRANS (input) INTEGER\n* Specifies the form of the system of equations:\n* = BLAS_NO_TRANS = 111 : No Transpose\n* = BLAS_TRANS = 112 : Transpose\n* = BLAS_CONJ_TRANS = 113 : Conjugate Transpose\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.chla_transtype( trans, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_trans = argv[0];
+ if (argc == 1) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+
+ chla_transtype_(&__out__, &trans);
+
+ rblapack___out__ = rb_str_new(&__out__,1);
+ return rblapack___out__;
+}
+
+void
+init_lapack_chla_transtype(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chla_transtype", rblapack_chla_transtype, -1);
+}
diff --git a/ext/chpcon.c b/ext/chpcon.c
new file mode 100644
index 0000000..e339954
--- /dev/null
+++ b/ext/chpcon.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID chpcon_(char* uplo, integer* n, complex* ap, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);
+
+
+static VALUE
+rblapack_chpcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *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 rcond, info = NumRu::Lapack.chpcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPCON estimates the reciprocal of the condition number of a complex\n* Hermitian packed matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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.chpcon( uplo, ap, ipiv, anorm, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(complex, (2*n));
+
+ chpcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_chpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpcon", rblapack_chpcon, -1);
+}
diff --git a/ext/chpev.c b/ext/chpev.c
new file mode 100644
index 0000000..645dba6
--- /dev/null
+++ b/ext/chpev.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID chpev_(char* jobz, char* uplo, integer* n, complex* ap, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chpev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap = NumRu::Lapack.chpev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.chpev( jobz, uplo, ap, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
+ ldap = NA_SHAPE0(rblapack_ap);
+ if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(complex, (MAX(1, 2*n-1)));
+ rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
+
+ chpev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_chpev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpev", rblapack_chpev, -1);
+}
diff --git a/ext/chpevd.c b/ext/chpevd.c
new file mode 100644
index 0000000..42e0743
--- /dev/null
+++ b/ext/chpevd.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID chpevd_(char* jobz, char* uplo, integer* n, complex* ap, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_chpevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, rwork, iwork, info, ap = NumRu::Lapack.chpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ap = NumRu::Lapack.chpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 6) {
+ rblapack_lwork = argv[3];
+ rblapack_lrwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
+ ldap = NA_SHAPE0(rblapack_ap);
+ if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ chpevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_chpevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpevd", rblapack_chpevd, -1);
+}
diff --git a/ext/chpevx.c b/ext/chpevx.c
new file mode 100644
index 0000000..e4a47f3
--- /dev/null
+++ b/ext/chpevx.c
@@ -0,0 +1,144 @@
+#include "rb_lapack.h"
+
+extern VOID chpevx_(char* jobz, char* range, char* uplo, integer* n, complex* ap, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_chpevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ complex *work;
+ real *rwork;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap = NumRu::Lapack.chpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A in packed storage.\n* Eigenvalues/vectors can be selected by specifying either a range of\n* values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and\n* the index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.chpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ chpevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_chpevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpevx", rblapack_chpevx, -1);
+}
diff --git a/ext/chpgst.c b/ext/chpgst.c
new file mode 100644
index 0000000..aef359f
--- /dev/null
+++ b/ext/chpgst.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID chpgst_(integer* itype, char* uplo, integer* n, complex* ap, complex* bp, integer* info);
+
+
+static VALUE
+rblapack_chpgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_bp;
+ complex *bp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *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.chpgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* CHPGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by CPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by CPPTRF.\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, ap = NumRu::Lapack.chpgst( itype, uplo, n, ap, bp, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, complex*);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ chpgst_(&itype, &uplo, &n, ap, bp, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_chpgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpgst", rblapack_chpgst, -1);
+}
diff --git a/ext/chpgv.c b/ext/chpgv.c
new file mode 100644
index 0000000..88e47d1
--- /dev/null
+++ b/ext/chpgv.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID chpgv_(integer* itype, char* jobz, char* uplo, integer* n, complex* ap, complex* bp, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chpgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_bp;
+ complex *bp;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ VALUE rblapack_bp_out__;
+ complex *bp_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap, bp = NumRu::Lapack.chpgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPPTRF or CHPEV returned an error code:\n* <= N: if INFO = i, CHPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPEV, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.chpgv( itype, jobz, uplo, ap, bp, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, complex*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, complex*);
+ MEMCPY(bp_out__, bp, complex, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(complex, (MAX(1, 2*n-1)));
+ rwork = ALLOC_N(real, (MAX(1, 3*n-2)));
+
+ chpgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_chpgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpgv", rblapack_chpgv, -1);
+}
diff --git a/ext/chpgvd.c b/ext/chpgvd.c
new file mode 100644
index 0000000..83a96e2
--- /dev/null
+++ b/ext/chpgvd.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+extern VOID chpgvd_(integer* itype, char* jobz, char* uplo, integer* n, complex* ap, complex* bp, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_chpgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_bp;
+ complex *bp;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ VALUE rblapack_bp_out__;
+ complex *bp_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, iwork, info, ap, bp = NumRu::Lapack.chpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: CPPTRF or CHPEVD returned an error code:\n* <= N: if INFO = i, CHPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPEVD, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, REAL\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, iwork, info, ap, bp = NumRu::Lapack.chpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 8) {
+ rblapack_lwork = argv[5];
+ rblapack_lrwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, complex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, complex*);
+ MEMCPY(bp_out__, bp, complex, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(complex, (MAX(1,lwork)));
+ rwork = ALLOC_N(real, (MAX(1,lrwork)));
+
+ chpgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_chpgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpgvd", rblapack_chpgvd, -1);
+}
diff --git a/ext/chpgvx.c b/ext/chpgvx.c
new file mode 100644
index 0000000..ecf0928
--- /dev/null
+++ b/ext/chpgvx.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+extern VOID chpgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, complex* ap, complex* bp, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_chpgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_bp;
+ complex *bp;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ VALUE rblapack_bp_out__;
+ complex *bp_out__;
+ complex *work;
+ real *rwork;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap, bp = NumRu::Lapack.chpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CHPGVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite. Eigenvalues and eigenvectors can be selected by\n* specifying either a range of values or a range of indices for the\n* desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, N)\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: CPPTRF or CHPEVX returned an error code:\n* <= N: if INFO = i, CHPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPEVX, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.chpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_bp = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vu = argv[7];
+ rblapack_il = argv[8];
+ rblapack_iu = argv[9];
+ rblapack_abstol = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ 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);
+ ldap = NA_SHAPE0(rblapack_ap);
+ if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, complex*);
+ iu = NUM2INT(rblapack_iu);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ vu = (real)NUM2DBL(rblapack_vu);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : n;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, complex*);
+ MEMCPY(bp_out__, bp, complex, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ chpgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_chpgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpgvx", rblapack_chpgvx, -1);
+}
diff --git a/ext/chprfs.c b/ext/chprfs.c
new file mode 100644
index 0000000..4b15603
--- /dev/null
+++ b/ext/chprfs.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID chprfs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_afp;
+ complex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ 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.chprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by CHPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CHPTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.chprfs( uplo, ap, afp, ipiv, 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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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 (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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ chprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_chprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chprfs", rblapack_chprfs, -1);
+}
diff --git a/ext/chpsv.c b/ext/chpsv.c
new file mode 100644
index 0000000..536b99c
--- /dev/null
+++ b/ext/chpsv.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID chpsv_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_chpsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+ 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 ipiv, info, ap, b = NumRu::Lapack.chpsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is Hermitian and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CHPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CHPTRF, CHPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.chpsv( uplo, ap, b, [: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_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n = ldb;
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ chpsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_chpsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpsv", rblapack_chpsv, -1);
+}
diff --git a/ext/chpsvx.c b/ext/chpsvx.c
new file mode 100644
index 0000000..c766b30
--- /dev/null
+++ b/ext/chpsvx.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID chpsvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_chpsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_afp;
+ complex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_afp_out__;
+ complex *afp_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ complex *work;
+ real *rwork;
+
+ 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 x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.chpsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n* A = L*D*L**H to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N Hermitian matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CHPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CHPTRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.chpsvx( fact, uplo, ap, afp, ipiv, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ ldx = MAX(1,n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, complex*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, complex*);
+ MEMCPY(afp_out__, afp, complex, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ chpsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
+}
+
+void
+init_lapack_chpsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chpsvx", rblapack_chpsvx, -1);
+}
diff --git a/ext/chptrd.c b/ext/chptrd.c
new file mode 100644
index 0000000..c53a7f6
--- /dev/null
+++ b/ext/chptrd.c
@@ -0,0 +1,100 @@
+#include "rb_lapack.h"
+
+extern VOID chptrd_(char* uplo, integer* n, complex* ap, real* d, real* e, complex* tau, integer* info);
+
+
+static VALUE
+rblapack_chptrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+
+ 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 d, e, tau, info, ap = NumRu::Lapack.chptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRD reduces a complex Hermitian matrix A stored in packed form to\n* real symmetric tridiagonal form T by a unitary similarity\n* transformation: Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.chptrd( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ chptrd_(&uplo, &n, ap, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_chptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chptrd", rblapack_chptrd, -1);
+}
diff --git a/ext/chptrf.c b/ext/chptrf.c
new file mode 100644
index 0000000..9c71851
--- /dev/null
+++ b/ext/chptrf.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID chptrf_(char* uplo, integer* n, complex* ap, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_chptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+
+ 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 ipiv, info, ap = NumRu::Lapack.chptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRF computes the factorization of a complex Hermitian packed\n* matrix A using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.chptrf( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ chptrf_(&uplo, &n, ap, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_chptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chptrf", rblapack_chptrf, -1);
+}
diff --git a/ext/chptri.c b/ext/chptri.c
new file mode 100644
index 0000000..4ea30a9
--- /dev/null
+++ b/ext/chptri.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID chptri_(char* uplo, integer* n, complex* ap, integer* ipiv, complex* work, integer* info);
+
+
+static VALUE
+rblapack_chptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ complex *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 info, ap = NumRu::Lapack.chptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRI computes the inverse of a complex Hermitian indefinite matrix\n* A in packed storage using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by CHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CHPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* WORK (workspace) COMPLEX 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.chptri( uplo, ap, ipiv, [: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_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(complex, (n));
+
+ chptri_(&uplo, &n, ap, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_chptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chptri", rblapack_chptri, -1);
+}
diff --git a/ext/chptrs.c b/ext/chptrs.c
new file mode 100644
index 0000000..63d524b
--- /dev/null
+++ b/ext/chptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID chptrs_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_chptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.chptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CHPTRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A stored in packed format using the factorization\n* A = U*D*U**H or A = L*D*L**H computed by CHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHPTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.chptrs( uplo, ap, ipiv, b, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ chptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_chptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chptrs", rblapack_chptrs, -1);
+}
diff --git a/ext/chsein.c b/ext/chsein.c
new file mode 100644
index 0000000..97eb310
--- /dev/null
+++ b/ext/chsein.c
@@ -0,0 +1,185 @@
+#include "rb_lapack.h"
+
+extern VOID chsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, complex* h, integer* ldh, complex* w, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* mm, integer* m, complex* work, real* rwork, integer* ifaill, integer* ifailr, integer* info);
+
+
+static VALUE
+rblapack_chsein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_eigsrc;
+ char eigsrc;
+ VALUE rblapack_initv;
+ char initv;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_ifaill;
+ integer *ifaill;
+ VALUE rblapack_ifailr;
+ integer *ifailr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_w_out__;
+ complex *w_out__;
+ VALUE rblapack_vl_out__;
+ complex *vl_out__;
+ VALUE rblapack_vr_out__;
+ complex *vr_out__;
+ complex *work;
+ real *rwork;
+
+ integer n;
+ integer ldh;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.chsein( side, eigsrc, initv, select, h, w, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* CHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a complex upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in W:\n* = 'Q': the eigenvalues were found using CHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows CHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, CHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* eigenvector corresponding to the eigenvalue W(j),\n* SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input/output) COMPLEX array, dimension (N)\n* On entry, the eigenvalues of H.\n* On exit, the real parts of W may have been altered since\n* close eigenvalues are perturbed slightly in searching for\n* independent eigenvectors.\n*\n* VL (input/output) COMPLEX array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) COMPLEX array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors (= the number of .TRUE. elements in\n* SELECT).\n*\n* WORK (workspace) COMPLEX array, dimension (N*N)\n*\n* RWORK (workspace) REAL array, dimension (N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.chsein( side, eigsrc, initv, select, h, w, vl, vr, [: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_side = argv[0];
+ rblapack_eigsrc = argv[1];
+ rblapack_initv = argv[2];
+ rblapack_select = argv[3];
+ rblapack_h = argv[4];
+ rblapack_w = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vr = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ initv = StringValueCStr(rblapack_initv)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ mm = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ eigsrc = StringValueCStr(rblapack_eigsrc)[0];
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (6th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_w) != NA_SCOMPLEX)
+ rblapack_w = na_change_type(rblapack_w, NA_SCOMPLEX);
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (8th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, complex*);
+ MEMCPY(w_out__, w, complex, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, complex*);
+ MEMCPY(vl_out__, vl, complex, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, complex*);
+ MEMCPY(vr_out__, vr, complex, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(complex, (n*n));
+ rwork = ALLOC_N(real, (n));
+
+ chsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, w, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, ifaill, ifailr, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_w, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_chsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chsein", rblapack_chsein, -1);
+}
diff --git a/ext/chseqr.c b/ext/chseqr.c
new file mode 100644
index 0000000..2e287bc
--- /dev/null
+++ b/ext/chseqr.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID chseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, complex* z, integer* ldz, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_chseqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer ldh;
+ 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 w, work, info, h, z = NumRu::Lapack.chseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an unitary matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to CGEBAL, and then passed to CGEHRD\n* when the matrix output by CGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', H contains the upper\n* triangular matrix T from the Schur decomposition (the\n* Schur form). If INFO = 0 and JOB = 'E', the contents of\n* H are unspecified on exit. (The output value of H when\n* INFO.GT.0 is given under the description of INFO below.)\n*\n* Unlike earlier versions of CHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues. If JOB = 'S', the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the unitary matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the unitary matrix generated by CUNGHR\n* after the call to CGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then CHSEQR does a workspace query.\n* In this case, CHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, CHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The CLAHQR vs CLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* CLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.chseqr( job, compz, ilo, ihi, h, z, ldz, [: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_job = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_z = argv[5];
+ rblapack_ldz = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ ldz = NUM2INT(rblapack_ldz);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
+ if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = lsame_(&compz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&compz,"N") ? 0 : n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ chseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, w, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_chseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "chseqr", rblapack_chseqr, -1);
+}
diff --git a/ext/cla_gbamv.c b/ext/cla_gbamv.c
new file mode 100644
index 0000000..052c95f
--- /dev/null
+++ b/ext/cla_gbamv.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID cla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, real* alpha, real* ab, integer* ldab, real* x, integer* incx, real* beta, real* y, integer* incy);
+
+
+static VALUE
+rblapack_cla_gbamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+
+ integer ldab;
+ 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 y = NumRu::Lapack.cla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) REAL array, dimension (LDA,n)\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension at least\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension at least\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [: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_m = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_x = argv[6];
+ rblapack_incx = argv[7];
+ rblapack_beta = argv[8];
+ rblapack_y = argv[9];
+ rblapack_incy = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+ kl = NUM2INT(rblapack_kl);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ beta = (real)NUM2DBL(rblapack_beta);
+ ldab = MAX(1,m);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_ab) != ldab)
+ rb_raise(rb_eRuntimeError, "shape 0 of ab must be MAX(1,m)");
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (10th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ cla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_cla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gbamv", rblapack_cla_gbamv, -1);
+}
diff --git a/ext/cla_gbrcond_c.c b/ext/cla_gbrcond_c.c
new file mode 100644
index 0000000..1335fde
--- /dev/null
+++ b/ext/cla_gbrcond_c.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern real cla_gbrcond_c_(char* trans, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_gbrcond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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, __out__ = NumRu::Lapack.cla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_GBRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_c = argv[6];
+ rblapack_capply = argv[7];
+ rblapack_work = argv[8];
+ rblapack_rwork = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (10th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (9th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ capply = (rblapack_capply == Qtrue);
+
+ __out__ = cla_gbrcond_c_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_gbrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gbrcond_c", rblapack_cla_gbrcond_c, -1);
+}
diff --git a/ext/cla_gbrcond_x.c b/ext/cla_gbrcond_x.c
new file mode 100644
index 0000000..6e4528b
--- /dev/null
+++ b/ext/cla_gbrcond_x.c
@@ -0,0 +1,138 @@
+#include "rb_lapack.h"
+
+extern real cla_gbrcond_x_(char* trans, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_gbrcond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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, __out__ = NumRu::Lapack.cla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_GBRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_x = argv[6];
+ rblapack_work = argv[7];
+ rblapack_rwork = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (9th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (8th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_gbrcond_x_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_gbrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gbrcond_x", rblapack_cla_gbrcond_x, -1);
+}
diff --git a/ext/cla_gbrfsx_extended.c b/ext/cla_gbrfsx_extended.c
new file mode 100644
index 0000000..148ed11
--- /dev/null
+++ b/ext/cla_gbrfsx_extended.c
@@ -0,0 +1,295 @@
+#include "rb_lapack.h"
+
+extern VOID cla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_cla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ complex *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ complex *dy;
+ VALUE rblapack_y_tail;
+ complex *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+ integer ldafb;
+ integer ldab;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GBRFSX_EXTENDED ( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* AB (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AFB (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGBTRF.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 23 && argc != 23)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 23)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_colequ = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_y = argv[10];
+ rblapack_n_norms = argv[11];
+ rblapack_err_bnds_norm = argv[12];
+ rblapack_err_bnds_comp = argv[13];
+ rblapack_res = argv[14];
+ rblapack_ayb = argv[15];
+ rblapack_dy = argv[16];
+ rblapack_y_tail = argv[17];
+ rblapack_rcond = argv[18];
+ rblapack_ithresh = argv[19];
+ rblapack_rthresh = argv[20];
+ rblapack_dz_ub = argv[21];
+ rblapack_ignore_cwise = argv[22];
+ if (argc == 23) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ 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_y))
+ rb_raise(rb_eArgError, "y (11th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (13th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (15th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, complex*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (17th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ trans_type = NUM2INT(rblapack_trans_type);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ 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 y");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (14th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (14th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (18th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (18th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ ku = NUM2INT(rblapack_ku);
+ n_norms = NUM2INT(rblapack_n_norms);
+ ithresh = NUM2INT(rblapack_ithresh);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (16th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ ldab = lda = MAX(1,n);
+ ldafb = ldaf = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ cla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_cla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gbrfsx_extended", rblapack_cla_gbrfsx_extended, -1);
+}
diff --git a/ext/cla_gbrpvgrw.c b/ext/cla_gbrpvgrw.c
new file mode 100644
index 0000000..f2f9162
--- /dev/null
+++ b/ext/cla_gbrpvgrw.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern real cla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, complex* ab, integer* ldab, complex* afb, integer* ldafb);
+
+
+static VALUE
+rblapack_cla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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 __out__ = NumRu::Lapack.cla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* CLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by CGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n REAL AMAX, UMAX, RPVGRW\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_gbrpvgrw( kl, ku, ncols, ab, afb, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ncols = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+
+ __out__ = cla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_cla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gbrpvgrw", rblapack_cla_gbrpvgrw, -1);
+}
diff --git a/ext/cla_geamv.c b/ext/cla_geamv.c
new file mode 100644
index 0000000..59d525b
--- /dev/null
+++ b/ext/cla_geamv.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID cla_geamv_(integer* trans, integer* m, integer* n, real* alpha, complex* a, integer* lda, complex* x, integer* incx, real* beta, real* y, integer* incy);
+
+
+static VALUE
+rblapack_cla_geamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ real *y_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 y = NumRu::Lapack.cla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension (LDA,n)\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_trans = argv[0];
+ rblapack_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_a = argv[3];
+ rblapack_x = argv[4];
+ rblapack_incx = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_y = argv[7];
+ rblapack_incy = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ beta = (real)NUM2DBL(rblapack_beta);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ cla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_cla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_geamv", rblapack_cla_geamv, -1);
+}
diff --git a/ext/cla_gercond_c.c b/ext/cla_gercond_c.c
new file mode 100644
index 0000000..baaa358
--- /dev/null
+++ b/ext/cla_gercond_c.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern real cla_gercond_c_(char* trans, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_gercond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n* \n* CLA_GERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_c = argv[4];
+ rblapack_capply = argv[5];
+ rblapack_work = argv[6];
+ rblapack_rwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_gercond_c_(&trans, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_gercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gercond_c", rblapack_cla_gercond_c, -1);
+}
diff --git a/ext/cla_gercond_x.c b/ext/cla_gercond_x.c
new file mode 100644
index 0000000..d357427
--- /dev/null
+++ b/ext/cla_gercond_x.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern real cla_gercond_x_(char* trans, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_gercond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_gercond_x( trans, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n* \n* CLA_GERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_gercond_x( trans, a, af, ipiv, x, work, rwork, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_x = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_gercond_x_(&trans, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_gercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gercond_x", rblapack_cla_gercond_x, -1);
+}
diff --git a/ext/cla_gerfsx_extended.c b/ext/cla_gerfsx_extended.c
new file mode 100644
index 0000000..34ad75e
--- /dev/null
+++ b/ext/cla_gerfsx_extended.c
@@ -0,0 +1,281 @@
+#include "rb_lapack.h"
+
+extern VOID cla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* errs_n, real* errs_c, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_cla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_errs_n;
+ real *errs_n;
+ VALUE rblapack_errs_c;
+ real *errs_c;
+ VALUE rblapack_res;
+ complex *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ complex *dy;
+ VALUE rblapack_y_tail;
+ complex *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+ VALUE rblapack_errs_n_out__;
+ real *errs_n_out__;
+ VALUE rblapack_errs_c_out__;
+ real *errs_c_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_norms;
+ integer n_norsm;
+
+ 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 berr_out, info, y, errs_n, errs_c = NumRu::Lapack.cla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* CLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by CGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, errs_n, errs_c = NumRu::Lapack.cla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 20 && argc != 20)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_errs_n = argv[9];
+ rblapack_errs_c = argv[10];
+ rblapack_res = argv[11];
+ rblapack_ayb = argv[12];
+ rblapack_dy = argv[13];
+ rblapack_y_tail = argv[14];
+ rblapack_rcond = argv[15];
+ rblapack_ithresh = argv[16];
+ rblapack_rthresh = argv[17];
+ rblapack_dz_ub = argv[18];
+ rblapack_ignore_cwise = argv[19];
+ if (argc == 20) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ if (!NA_IsNArray(rblapack_errs_c))
+ rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
+ if (NA_RANK(rblapack_errs_c) != 2)
+ rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_errs_c) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of errs_c must be the same as shape 1 of y");
+ n_norms = NA_SHAPE1(rblapack_errs_c);
+ if (NA_TYPE(rblapack_errs_c) != NA_SFLOAT)
+ rblapack_errs_c = na_change_type(rblapack_errs_c, NA_SFLOAT);
+ errs_c = NA_PTR_TYPE(rblapack_errs_c, real*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ n_norsm = 3;
+ trans_type = NUM2INT(rblapack_trans_type);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_errs_n))
+ rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
+ if (NA_RANK(rblapack_errs_n) != 2)
+ rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_errs_n) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_errs_n) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be the same as shape 1 of errs_c");
+ if (NA_TYPE(rblapack_errs_n) != NA_SFLOAT)
+ rblapack_errs_n = na_change_type(rblapack_errs_n, NA_SFLOAT);
+ errs_n = NA_PTR_TYPE(rblapack_errs_n, real*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, complex*);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (12th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, complex*);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_errs_n_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ errs_n_out__ = NA_PTR_TYPE(rblapack_errs_n_out__, real*);
+ MEMCPY(errs_n_out__, errs_n, real, NA_TOTAL(rblapack_errs_n));
+ rblapack_errs_n = rblapack_errs_n_out__;
+ errs_n = errs_n_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_errs_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ errs_c_out__ = NA_PTR_TYPE(rblapack_errs_c_out__, real*);
+ MEMCPY(errs_c_out__, errs_c, real, NA_TOTAL(rblapack_errs_c));
+ rblapack_errs_c = rblapack_errs_c_out__;
+ errs_c = errs_c_out__;
+
+ cla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_errs_n, rblapack_errs_c);
+}
+
+void
+init_lapack_cla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_gerfsx_extended", rblapack_cla_gerfsx_extended, -1);
+}
diff --git a/ext/cla_heamv.c b/ext/cla_heamv.c
new file mode 100644
index 0000000..89e66ac
--- /dev/null
+++ b/ext/cla_heamv.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID cla_heamv_(integer* uplo, integer* n, real* alpha, real* a, integer* lda, complex* x, integer* incx, real* beta, real* y, integer* incy);
+
+
+static VALUE
+rblapack_cla_heamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ integer uplo;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ real *y_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 y = NumRu::Lapack.cla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = NUM2INT(rblapack_uplo);
+ 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);
+ n = lda;
+ if (NA_SHAPE1(rblapack_a) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be n");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ beta = (real)NUM2DBL(rblapack_beta);
+ lda = n;
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ cla_heamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_cla_heamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_heamv", rblapack_cla_heamv, -1);
+}
diff --git a/ext/cla_hercond_c.c b/ext/cla_hercond_c.c
new file mode 100644
index 0000000..af09139
--- /dev/null
+++ b/ext/cla_hercond_c.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern real cla_hercond_c_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_hercond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_HERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [: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_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_c = argv[4];
+ rblapack_capply = argv[5];
+ rblapack_work = argv[6];
+ rblapack_rwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_hercond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_hercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_hercond_c", rblapack_cla_hercond_c, -1);
+}
diff --git a/ext/cla_hercond_x.c b/ext/cla_hercond_x.c
new file mode 100644
index 0000000..69512c4
--- /dev/null
+++ b/ext/cla_hercond_x.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern real cla_hercond_x_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_hercond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_HERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_x = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_hercond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_hercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_hercond_x", rblapack_cla_hercond_x, -1);
+}
diff --git a/ext/cla_herfsx_extended.c b/ext/cla_herfsx_extended.c
new file mode 100644
index 0000000..ca807a6
--- /dev/null
+++ b/ext/cla_herfsx_extended.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID cla_herfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_cla_herfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ complex *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ complex *dy;
+ VALUE rblapack_y_tail;
+ complex *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_HERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CHERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CHETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CHETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 21 && argc != 21)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_n_norms = argv[9];
+ rblapack_err_bnds_norm = argv[10];
+ rblapack_err_bnds_comp = argv[11];
+ rblapack_res = argv[12];
+ rblapack_ayb = argv[13];
+ rblapack_dy = argv[14];
+ rblapack_y_tail = argv[15];
+ rblapack_rcond = argv[16];
+ rblapack_ithresh = argv[17];
+ rblapack_rthresh = argv[18];
+ rblapack_dz_ub = argv[19];
+ rblapack_ignore_cwise = argv[20];
+ if (argc == 21) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (13th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, complex*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ colequ = (rblapack_colequ == Qtrue);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ cla_herfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_cla_herfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_herfsx_extended", rblapack_cla_herfsx_extended, -1);
+}
diff --git a/ext/cla_herpvgrw.c b/ext/cla_herpvgrw.c
new file mode 100644
index 0000000..83d20c3
--- /dev/null
+++ b/ext/cla_herpvgrw.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern real cla_herpvgrw_(char* uplo, integer* n, integer* info, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* work);
+
+
+static VALUE
+rblapack_cla_herpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.cla_herpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* CLA_HERPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from SSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* WORK (input) COMPLEX array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER, LSAME\n COMPLEX ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, CLASET\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX, MIN\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_herpvgrw( uplo, info, a, af, ipiv, work, [: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_info = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_work = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ info = NUM2INT(rblapack_info);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_herpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_cla_herpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_herpvgrw", rblapack_cla_herpvgrw, -1);
+}
diff --git a/ext/cla_lin_berr.c b/ext/cla_lin_berr.c
new file mode 100644
index 0000000..62a04e6
--- /dev/null
+++ b/ext/cla_lin_berr.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID cla_lin_berr_(integer* n, integer* nz, integer* nrhs, doublereal* res, doublereal* ayb, complex* berr);
+
+
+static VALUE
+rblapack_cla_lin_berr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nz;
+ integer nz;
+ VALUE rblapack_res;
+ doublereal *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_berr;
+ complex *berr;
+
+ integer n;
+ integer nrhs;
+
+ 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 berr = NumRu::Lapack.cla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* CLA_LIN_BERR computes componentwise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z.\n*\n\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see cla_gerfsx_extended.f).\n* \n* BERR (output) COMPLEX array, dimension (NRHS)\n* The componentwise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL TMP\n INTEGER I, J\n COMPLEX CDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX\n* ..\n* .. External Functions ..\n EXTERNAL SLAMCH\n REAL SLAMCH\n REAL SAFE1\n* ..\n* .. Statement Functions ..\n COMPLEX CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr = NumRu::Lapack.cla_lin_berr( nz, res, ayb, [: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_nz = argv[0];
+ rblapack_res = argv[1];
+ rblapack_ayb = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nz = NUM2INT(rblapack_nz);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 2)
+ rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
+ n = NA_SHAPE0(rblapack_ayb);
+ nrhs = NA_SHAPE1(rblapack_ayb);
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (2th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 2)
+ rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
+ if (NA_SHAPE1(rblapack_res) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
+ if (NA_TYPE(rblapack_res) != NA_DFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, complex*);
+
+ cla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
+
+ return rblapack_berr;
+}
+
+void
+init_lapack_cla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_lin_berr", rblapack_cla_lin_berr, -1);
+}
diff --git a/ext/cla_porcond_c.c b/ext/cla_porcond_c.c
new file mode 100644
index 0000000..2631b1c
--- /dev/null
+++ b/ext/cla_porcond_c.c
@@ -0,0 +1,122 @@
+#include "rb_lapack.h"
+
+extern real cla_porcond_c_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, real* c, logical* capply, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_porcond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_PORCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_c = argv[3];
+ rblapack_capply = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_porcond_c_(&uplo, &n, a, &lda, af, &ldaf, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_porcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_porcond_c", rblapack_cla_porcond_c, -1);
+}
diff --git a/ext/cla_porcond_x.c b/ext/cla_porcond_x.c
new file mode 100644
index 0000000..67d6999
--- /dev/null
+++ b/ext/cla_porcond_x.c
@@ -0,0 +1,118 @@
+#include "rb_lapack.h"
+
+extern real cla_porcond_x_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, complex* x, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_porcond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_porcond_x( uplo, a, af, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_PORCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_porcond_x( uplo, a, af, x, work, rwork, [: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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_x = argv[3];
+ rblapack_work = argv[4];
+ rblapack_rwork = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (6th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (5th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_porcond_x_(&uplo, &n, a, &lda, af, &ldaf, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_porcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_porcond_x", rblapack_cla_porcond_x, -1);
+}
diff --git a/ext/cla_porfsx_extended.c b/ext/cla_porfsx_extended.c
new file mode 100644
index 0000000..cd3351b
--- /dev/null
+++ b/ext/cla_porfsx_extended.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID cla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_cla_porfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ complex *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ complex *dy;
+ VALUE rblapack_y_tail;
+ complex *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 20 && argc != 20)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_colequ = argv[4];
+ rblapack_c = argv[5];
+ rblapack_b = argv[6];
+ rblapack_y = argv[7];
+ rblapack_n_norms = argv[8];
+ rblapack_err_bnds_norm = argv[9];
+ rblapack_err_bnds_comp = argv[10];
+ rblapack_res = argv[11];
+ rblapack_ayb = argv[12];
+ rblapack_dy = argv[13];
+ rblapack_y_tail = argv[14];
+ rblapack_rcond = argv[15];
+ rblapack_ithresh = argv[16];
+ rblapack_rthresh = argv[17];
+ rblapack_dz_ub = argv[18];
+ rblapack_ignore_cwise = argv[19];
+ if (argc == 20) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, complex*);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (12th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, complex*);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ if (NA_SHAPE1(rblapack_y) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ cla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_cla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_porfsx_extended", rblapack_cla_porfsx_extended, -1);
+}
diff --git a/ext/cla_porpvgrw.c b/ext/cla_porpvgrw.c
new file mode 100644
index 0000000..3bf61d6
--- /dev/null
+++ b/ext/cla_porpvgrw.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern real cla_porpvgrw_(char* uplo, integer* ncols, complex* a, integer* lda, complex* af, integer* ldaf, complex* work);
+
+
+static VALUE
+rblapack_cla_porpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.cla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* CLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) COMPLEX array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n COMPLEX ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, CLASET\n LOGICAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_porpvgrw( uplo, ncols, a, af, work, [: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_ncols = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_work = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (5th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_cla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_porpvgrw", rblapack_cla_porpvgrw, -1);
+}
diff --git a/ext/cla_rpvgrw.c b/ext/cla_rpvgrw.c
new file mode 100644
index 0000000..94ba57d
--- /dev/null
+++ b/ext/cla_rpvgrw.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern real cla_rpvgrw_(integer* n, integer* ncols, complex* a, integer* lda, complex* af, integer* ldaf);
+
+
+static VALUE
+rblapack_cla_rpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.cla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n* \n* CLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by CGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN, ABS, REAL, AIMAG\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_rpvgrw( ncols, a, af, [: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_ncols = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+
+ __out__ = cla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_cla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_rpvgrw", rblapack_cla_rpvgrw, -1);
+}
diff --git a/ext/cla_syamv.c b/ext/cla_syamv.c
new file mode 100644
index 0000000..5d0830a
--- /dev/null
+++ b/ext/cla_syamv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID cla_syamv_(integer* uplo, integer* n, real* alpha, real* a, integer* lda, complex* x, integer* incx, real* beta, real* y, integer* incy);
+
+
+static VALUE
+rblapack_cla_syamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ integer uplo;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ real *y_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 y = NumRu::Lapack.cla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.cla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = NUM2INT(rblapack_uplo);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ lda = n;
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ beta = (real)NUM2DBL(rblapack_beta);
+ n = lda;
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ cla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_cla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_syamv", rblapack_cla_syamv, -1);
+}
diff --git a/ext/cla_syrcond_c.c b/ext/cla_syrcond_c.c
new file mode 100644
index 0000000..652ebff
--- /dev/null
+++ b/ext/cla_syrcond_c.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern real cla_syrcond_c_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_syrcond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_SYRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [: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_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_c = argv[4];
+ rblapack_capply = argv[5];
+ rblapack_work = argv[6];
+ rblapack_rwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_syrcond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_syrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_syrcond_c", rblapack_cla_syrcond_c, -1);
+}
diff --git a/ext/cla_syrcond_x.c b/ext/cla_syrcond_x.c
new file mode 100644
index 0000000..9a8513e
--- /dev/null
+++ b/ext/cla_syrcond_x.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern real cla_syrcond_x_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);
+
+
+static VALUE
+rblapack_cla_syrcond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.cla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* CLA_SYRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) REAL array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACN2, CSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.cla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_x = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_syrcond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_cla_syrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_syrcond_x", rblapack_cla_syrcond_x, -1);
+}
diff --git a/ext/cla_syrfsx_extended.c b/ext/cla_syrfsx_extended.c
new file mode 100644
index 0000000..4fb9a33
--- /dev/null
+++ b/ext/cla_syrfsx_extended.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID cla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_cla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ complex *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ complex *dy;
+ VALUE rblapack_y_tail;
+ complex *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* CLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by CSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX 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* Y (input/output) COMPLEX array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by CSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by CLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to CSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 21 && argc != 21)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_n_norms = argv[9];
+ rblapack_err_bnds_norm = argv[10];
+ rblapack_err_bnds_comp = argv[11];
+ rblapack_res = argv[12];
+ rblapack_ayb = argv[13];
+ rblapack_dy = argv[14];
+ rblapack_y_tail = argv[15];
+ rblapack_rcond = argv[16];
+ rblapack_ithresh = argv[17];
+ rblapack_rthresh = argv[18];
+ rblapack_dz_ub = argv[19];
+ rblapack_ignore_cwise = argv[20];
+ if (argc == 21) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (13th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, complex*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, complex*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ colequ = (rblapack_colequ == Qtrue);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ cla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_cla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_syrfsx_extended", rblapack_cla_syrfsx_extended, -1);
+}
diff --git a/ext/cla_syrpvgrw.c b/ext/cla_syrpvgrw.c
new file mode 100644
index 0000000..ccf2702
--- /dev/null
+++ b/ext/cla_syrpvgrw.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern real cla_syrpvgrw_(char* uplo, integer* n, integer* info, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* work);
+
+
+static VALUE
+rblapack_cla_syrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.cla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* CLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from CSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* WORK (input) COMPLEX array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX, MIN\n* ..\n* .. External Subroutines ..\n EXTERNAL LSAME, CLASET\n LOGICAL LSAME\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cla_syrpvgrw( uplo, info, a, af, ipiv, work, [: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_info = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_work = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ info = NUM2INT(rblapack_info);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+
+ __out__ = cla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_cla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_syrpvgrw", rblapack_cla_syrpvgrw, -1);
+}
diff --git a/ext/cla_wwaddw.c b/ext/cla_wwaddw.c
new file mode 100644
index 0000000..0710444
--- /dev/null
+++ b/ext/cla_wwaddw.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID cla_wwaddw_(integer* n, complex* x, complex* y, complex* w);
+
+
+static VALUE
+rblapack_cla_wwaddw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+
+ 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 x, y = NumRu::Lapack.cla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* CLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) COMPLEX array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) COMPLEX array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) COMPLEX array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n COMPLEX S\n INTEGER I\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.cla_wwaddw( x, y, w, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_w = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_SCOMPLEX)
+ rblapack_w = na_change_type(rblapack_w, NA_SCOMPLEX);
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (2th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ cla_wwaddw_(&n, x, y, w);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_cla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cla_wwaddw", rblapack_cla_wwaddw, -1);
+}
diff --git a/ext/clabrd.c b/ext/clabrd.c
new file mode 100644
index 0000000..6a0eaeb
--- /dev/null
+++ b/ext/clabrd.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID clabrd_(integer* m, integer* n, integer* nb, complex* a, integer* lda, real* d, real* e, complex* tauq, complex* taup, complex* x, integer* ldx, complex* y, integer* ldy);
+
+
+static VALUE
+rblapack_clabrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tauq;
+ complex *tauq;
+ VALUE rblapack_taup;
+ complex *taup;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldx;
+ integer ldy;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.clabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* CLABRD reduces the first NB rows and columns of a complex general\n* m by n matrix A to upper or lower real bidiagonal form by a unitary\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by CGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the unitary matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) COMPLEX array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* X (output) COMPLEX array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,M).\n*\n* Y (output) COMPLEX array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.clabrd( m, nb, a, [: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_m = argv[0];
+ rblapack_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldy = MAX(1,n);
+ nb = NUM2INT(rblapack_nb);
+ ldx = MAX(1,m);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = MAX(1,nb);
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
+
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_clabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clabrd", rblapack_clabrd, -1);
+}
diff --git a/ext/clacgv.c b/ext/clacgv.c
new file mode 100644
index 0000000..d6b3200
--- /dev/null
+++ b/ext/clacgv.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID clacgv_(integer* n, complex* x, integer* incx);
+
+
+static VALUE
+rblapack_clacgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_x_out__;
+ complex *x_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 = NumRu::Lapack.clacgv( n, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACGV( N, X, INCX )\n\n* Purpose\n* =======\n*\n* CLACGV conjugates a complex vector of length N.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vector X. N >= 0.\n*\n* X (input/output) COMPLEX array, dimension\n* (1+(N-1)*abs(INCX))\n* On entry, the vector of length N to be conjugated.\n* On exit, X is overwritten with conjg(X).\n*\n* INCX (input) INTEGER\n* The spacing between successive elements of X.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IOFF\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.clacgv( n, x, incx, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ 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)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*abs(incx);
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ clacgv_(&n, x, &incx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_clacgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clacgv", rblapack_clacgv, -1);
+}
diff --git a/ext/clacn2.c b/ext/clacn2.c
new file mode 100644
index 0000000..d0a1218
--- /dev/null
+++ b/ext/clacn2.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID clacn2_(integer* n, complex* v, complex* x, real* est, integer* kase, integer* isave);
+
+
+static VALUE
+rblapack_clacn2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_est;
+ real est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_isave;
+ integer *isave;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_isave_out__;
+ integer *isave_out__;
+ complex *v;
+
+ 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 x, est, kase, isave = NumRu::Lapack.clacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* CLACN2 estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and CLACN2 must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to CLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to CLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from CLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to SLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* This is a thread safe version of CLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* CLACON CLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.clacn2( x, est, kase, isave, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ rblapack_isave = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ kase = NUM2INT(rblapack_kase);
+ est = (real)NUM2DBL(rblapack_est);
+ if (!NA_IsNArray(rblapack_isave))
+ rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
+ if (NA_RANK(rblapack_isave) != 1)
+ rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isave) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
+ if (NA_TYPE(rblapack_isave) != NA_LINT)
+ rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
+ isave = NA_PTR_TYPE(rblapack_isave, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 3;
+ rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
+ MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
+ rblapack_isave = rblapack_isave_out__;
+ isave = isave_out__;
+ v = ALLOC_N(complex, (n));
+
+ clacn2_(&n, v, x, &est, &kase, isave);
+
+ free(v);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
+}
+
+void
+init_lapack_clacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clacn2", rblapack_clacn2, -1);
+}
diff --git a/ext/clacon.c b/ext/clacon.c
new file mode 100644
index 0000000..a374bf9
--- /dev/null
+++ b/ext/clacon.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID clacon_(integer* n, complex* v, complex* x, real* est, integer* kase);
+
+
+static VALUE
+rblapack_clacon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_est;
+ real est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *v;
+
+ 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 x, est, kase = NumRu::Lapack.clacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACON( N, V, X, EST, KASE )\n\n* Purpose\n* =======\n*\n* CLACON estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and CLACON must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to CLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to CLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from CLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.clacon( x, est, kase, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ kase = NUM2INT(rblapack_kase);
+ est = (real)NUM2DBL(rblapack_est);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ v = ALLOC_N(complex, (n));
+
+ clacon_(&n, v, x, &est, &kase);
+
+ free(v);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
+}
+
+void
+init_lapack_clacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clacon", rblapack_clacon, -1);
+}
diff --git a/ext/clacp2.c b/ext/clacp2.c
new file mode 100644
index 0000000..104d554
--- /dev/null
+++ b/ext/clacp2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID clacp2_(char* uplo, integer* m, integer* n, real* a, integer* lda, complex* b, integer* ldb);
+
+
+static VALUE
+rblapack_clacp2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ complex *b;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.clacp2( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* CLACP2 copies all or part of a real two-dimensional matrix A to a\n* complex matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.clacp2( uplo, m, a, [: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_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ m = NUM2INT(rblapack_m);
+ ldb = MAX(1,m);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+
+ clacp2_(&uplo, &m, &n, a, &lda, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_clacp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clacp2", rblapack_clacp2, -1);
+}
diff --git a/ext/clacpy.c b/ext/clacpy.c
new file mode 100644
index 0000000..96d1170
--- /dev/null
+++ b/ext/clacpy.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID clacpy_(char* uplo, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb);
+
+
+static VALUE
+rblapack_clacpy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.clacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* CLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.clacpy( uplo, m, a, [: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_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = NUM2INT(rblapack_m);
+ ldb = MAX(1,m);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+
+ clacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_clacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clacpy", rblapack_clacpy, -1);
+}
diff --git a/ext/clacrm.c b/ext/clacrm.c
new file mode 100644
index 0000000..b46b32b
--- /dev/null
+++ b/ext/clacrm.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID clacrm_(integer* m, integer* n, complex* a, integer* lda, real* b, integer* ldb, complex* c, integer* ldc, real* rwork);
+
+
+static VALUE
+rblapack_clacrm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_c;
+ complex *c;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ 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.clacrm( m, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n* Purpose\n* =======\n*\n* CLACRM performs a very simple matrix-matrix multiplication:\n* C := A * B,\n* where A is M by N and complex; B is N by N and real;\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) COMPLEX array, dimension (LDA, N)\n* A contains the M by N 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* B contains the N by N matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >=max(1,N).\n*\n* C (input) COMPLEX 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,N).\n*\n* RWORK (workspace) REAL 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.clacrm( m, a, b, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = 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*);
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldc = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ rwork = ALLOC_N(real, (2*m*n));
+
+ clacrm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
+
+ free(rwork);
+ return rblapack_c;
+}
+
+void
+init_lapack_clacrm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clacrm", rblapack_clacrm, -1);
+}
diff --git a/ext/clacrt.c b/ext/clacrt.c
new file mode 100644
index 0000000..36b2896
--- /dev/null
+++ b/ext/clacrt.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID clacrt_(integer* n, complex* cx, integer* incx, complex* cy, integer* incy, complex* c, complex* s);
+
+
+static VALUE
+rblapack_clacrt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ complex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_cy;
+ complex *cy;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_c;
+ complex c;
+ VALUE rblapack_s;
+ complex s;
+ VALUE rblapack_cx_out__;
+ complex *cx_out__;
+ VALUE rblapack_cy_out__;
+ complex *cy_out__;
+
+ 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 cx, cy = NumRu::Lapack.clacrt( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLACRT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* CLACRT performs the operation\n*\n* ( c s )( x ) ==> ( x )\n* ( -s c )( y ) ( y )\n*\n* where c and s are complex and the vectors x and y are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX array, dimension (N)\n* On input, the vector x.\n* On output, CX is overwritten with c*x + s*y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CX. INCX <> 0.\n*\n* CY (input/output) COMPLEX array, dimension (N)\n* On input, the vector y.\n* On output, CY is overwritten with -s*x + c*y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCY <> 0.\n*\n* C (input) COMPLEX\n* S (input) COMPLEX\n* C and S define the matrix\n* [ C S ].\n* [ -S C ]\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX CTEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.clacrt( cx, incx, cy, incy, c, s, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_cy = argv[2];
+ rblapack_incy = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, complex*);
+ if (!NA_IsNArray(rblapack_cy))
+ rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
+ if (NA_RANK(rblapack_cy) != 1)
+ rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
+ if (NA_TYPE(rblapack_cy) != NA_SCOMPLEX)
+ rblapack_cy = na_change_type(rblapack_cy, NA_SCOMPLEX);
+ cy = NA_PTR_TYPE(rblapack_cy, complex*);
+ c.r = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
+ c.i = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
+ incx = NUM2INT(rblapack_incx);
+ s.r = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
+ s.i = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
+ incy = NUM2INT(rblapack_incy);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, complex*);
+ MEMCPY(cx_out__, cx, complex, NA_TOTAL(rblapack_cx));
+ rblapack_cx = rblapack_cx_out__;
+ cx = cx_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cy_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, complex*);
+ MEMCPY(cy_out__, cy, complex, NA_TOTAL(rblapack_cy));
+ rblapack_cy = rblapack_cy_out__;
+ cy = cy_out__;
+
+ clacrt_(&n, cx, &incx, cy, &incy, &c, &s);
+
+ return rb_ary_new3(2, rblapack_cx, rblapack_cy);
+}
+
+void
+init_lapack_clacrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clacrt", rblapack_clacrt, -1);
+}
diff --git a/ext/cladiv.c b/ext/cladiv.c
new file mode 100644
index 0000000..eff8435
--- /dev/null
+++ b/ext/cladiv.c
@@ -0,0 +1,57 @@
+#include "rb_lapack.h"
+
+extern VOID cladiv_(complex *__out__, complex* x, complex* y);
+
+
+static VALUE
+rblapack_cladiv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ complex x;
+ VALUE rblapack_y;
+ complex y;
+ VALUE rblapack___out__;
+ complex __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 __out__ = NumRu::Lapack.cladiv( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n COMPLEX FUNCTION CLADIV( X, Y )\n\n* Purpose\n* =======\n*\n* CLADIV := X / Y, where X and Y are complex. The computation of X / Y\n* will not overflow on an intermediary step unless the results\n* overflows.\n*\n\n* Arguments\n* =========\n*\n* X (input) COMPLEX\n* Y (input) COMPLEX\n* The complex scalars X and Y.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL ZI, ZR\n* ..\n* .. External Subroutines ..\n EXTERNAL SLADIV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC AIMAG, CMPLX, REAL\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.cladiv( x, y, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x.r = (real)NUM2DBL(rb_funcall(rblapack_x, rb_intern("real"), 0));
+ x.i = (real)NUM2DBL(rb_funcall(rblapack_x, rb_intern("imag"), 0));
+ y.r = (real)NUM2DBL(rb_funcall(rblapack_y, rb_intern("real"), 0));
+ y.i = (real)NUM2DBL(rb_funcall(rblapack_y, rb_intern("imag"), 0));
+
+ cladiv_(&__out__, &x, &y);
+
+ rblapack___out__ = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(__out__.r)), rb_float_new((double)(__out__.i)));
+ return rblapack___out__;
+}
+
+void
+init_lapack_cladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cladiv", rblapack_cladiv, -1);
+}
diff --git a/ext/claed0.c b/ext/claed0.c
new file mode 100644
index 0000000..70bc248
--- /dev/null
+++ b/ext/claed0.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID claed0_(integer* qsiz, integer* n, real* d, real* e, complex* q, integer* ldq, complex* qstore, integer* ldqs, real* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_claed0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ complex *qstore;
+ real *rwork;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+ integer ldqs;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, q = NumRu::Lapack.claed0( qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using the divide and conquer method, CLAED0 computes all eigenvalues\n* of a symmetric tridiagonal matrix which is one diagonal block of\n* those from reducing a dense or band Hermitian matrix and\n* corresponding eigenvectors of the dense or band matrix.\n*\n\n* Arguments\n* =========\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, Q must contain an QSIZ x N matrix whose columns\n* unitarily orthonormal. It is a part of the unitary matrix\n* that reduces the full dense Hermitian matrix to a\n* (reducible) symmetric tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IWORK (workspace) INTEGER array,\n* the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* RWORK (workspace) REAL array,\n* dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* QSTORE (workspace) COMPLEX array, dimension (LDQS, N)\n* Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE.\n* LDQS >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* =====================================================================\n*\n* Warning: N could be as big as QSIZ!\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, q = NumRu::Lapack.claed0( qsiz, d, e, q, [: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_qsiz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_q = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (4th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of q");
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ ldqs = MAX(1,n);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ qstore = ALLOC_N(complex, (ldqs)*(n));
+ rwork = ALLOC_N(real, (1 + 3*n + 2*n*LG(n) + 3*pow(n,2)));
+ iwork = ALLOC_N(integer, (6 + 6*n + 5*n*LG(n)));
+
+ claed0_(&qsiz, &n, d, e, q, &ldq, qstore, &ldqs, rwork, iwork, &info);
+
+ free(qstore);
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_q);
+}
+
+void
+init_lapack_claed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claed0", rblapack_claed0, -1);
+}
diff --git a/ext/claed7.c b/ext/claed7.c
new file mode 100644
index 0000000..7d9286e
--- /dev/null
+++ b/ext/claed7.c
@@ -0,0 +1,247 @@
+#include "rb_lapack.h"
+
+extern VOID claed7_(integer* n, integer* cutpnt, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, real* d, complex* q, integer* ldq, real* rho, integer* indxq, real* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, real* givnum, complex* work, real* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_claed7(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_tlvls;
+ integer tlvls;
+ VALUE rblapack_curlvl;
+ integer curlvl;
+ VALUE rblapack_curpbm;
+ integer curpbm;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_qstore;
+ real *qstore;
+ VALUE rblapack_qptr;
+ integer *qptr;
+ VALUE rblapack_prmptr;
+ integer *prmptr;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ VALUE rblapack_qstore_out__;
+ real *qstore_out__;
+ VALUE rblapack_qptr_out__;
+ integer *qptr_out__;
+ complex *work;
+ real *rwork;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+
+ 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 indxq, info, d, q, qstore, qptr = NumRu::Lapack.claed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense or banded\n* Hermitian matrix that has been reduced to tridiagonal form.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine SLAED4 (as called by SLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) REAL\n* Contains the subdiagonal element used to create the rank-1\n* modification.\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order,\n* ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* RWORK (workspace) REAL array,\n* dimension (3*N+2*QSIZ*N)\n*\n* WORK (workspace) COMPLEX array, dimension (QSIZ*N)\n*\n* QSTORE (input/output) REAL array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) REAL array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, CURR, I, IDLMDA, INDX,\n $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n* ..\n* .. External Subroutines ..\n EXTERNAL CLACRM, CLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.claed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_cutpnt = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_tlvls = argv[2];
+ rblapack_curlvl = argv[3];
+ rblapack_curpbm = argv[4];
+ rblapack_d = argv[5];
+ rblapack_q = argv[6];
+ rblapack_rho = argv[7];
+ rblapack_qstore = argv[8];
+ rblapack_qptr = argv[9];
+ rblapack_prmptr = argv[10];
+ rblapack_perm = argv[11];
+ rblapack_givptr = argv[12];
+ rblapack_givcol = argv[13];
+ rblapack_givnum = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ tlvls = NUM2INT(rblapack_tlvls);
+ curpbm = NUM2INT(rblapack_curpbm);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (6th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (6th 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 1 of q");
+ 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_qstore))
+ rb_raise(rb_eArgError, "qstore (9th argument) must be NArray");
+ if (NA_RANK(rblapack_qstore) != 1)
+ rb_raise(rb_eArgError, "rank of qstore (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
+ if (NA_TYPE(rblapack_qstore) != NA_SFLOAT)
+ rblapack_qstore = na_change_type(rblapack_qstore, NA_SFLOAT);
+ qstore = NA_PTR_TYPE(rblapack_qstore, real*);
+ if (!NA_IsNArray(rblapack_prmptr))
+ rb_raise(rb_eArgError, "prmptr (11th argument) must be NArray");
+ if (NA_RANK(rblapack_prmptr) != 1)
+ rb_raise(rb_eArgError, "rank of prmptr (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_prmptr) != NA_LINT)
+ rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
+ prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (13th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (15th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (15th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
+ if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ curlvl = NUM2INT(rblapack_curlvl);
+ if (!NA_IsNArray(rblapack_qptr))
+ rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_qptr) != 1)
+ rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qptr) != (n+2))
+ rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
+ if (NA_TYPE(rblapack_qptr) != NA_LINT)
+ rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
+ qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (14th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (14th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
+ if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ {
+ 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[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = pow(n,2)+1;
+ rblapack_qstore_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, real*);
+ MEMCPY(qstore_out__, qstore, real, NA_TOTAL(rblapack_qstore));
+ rblapack_qstore = rblapack_qstore_out__;
+ qstore = qstore_out__;
+ {
+ int shape[1];
+ shape[0] = n+2;
+ rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
+ MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
+ rblapack_qptr = rblapack_qptr_out__;
+ qptr = qptr_out__;
+ work = ALLOC_N(complex, (qsiz*n));
+ rwork = ALLOC_N(real, (3*n+2*qsiz*n));
+ iwork = ALLOC_N(integer, (4*n));
+
+ claed7_(&n, &cutpnt, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, &rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
+}
+
+void
+init_lapack_claed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claed7", rblapack_claed7, -1);
+}
diff --git a/ext/claed8.c b/ext/claed8.c
new file mode 100644
index 0000000..8e8e903
--- /dev/null
+++ b/ext/claed8.c
@@ -0,0 +1,198 @@
+#include "rb_lapack.h"
+
+extern VOID claed8_(integer* k, integer* n, integer* qsiz, complex* q, integer* ldq, real* d, real* rho, integer* cutpnt, real* z, real* dlamda, complex* q2, integer* ldq2, real* w, integer* indxp, integer* indx, integer* indxq, integer* perm, integer* givptr, integer* givcol, real* givnum, integer* info);
+
+
+static VALUE
+rblapack_claed8(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_dlamda;
+ real *dlamda;
+ VALUE rblapack_q2;
+ complex *q2;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ integer *indxp;
+ integer *indx;
+
+ integer ldq;
+ integer n;
+ integer ldq2;
+
+ 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 k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.claed8( qsiz, q, d, rho, cutpnt, z, indxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n* Purpose\n* =======\n*\n* CLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* Contains the number of non-deflated eigenvalues.\n* This is the order of the related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the dense or band matrix to tridiagonal form.\n* QSIZ >= N if ICOMPQ = 1.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined. On exit, D contains the trailing (N-K) updated\n* eigenvalues (those which were deflated) sorted into increasing\n* order.\n*\n* RHO (input/output) REAL\n* Contains the off diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined. RHO is modified during the computation to\n* the value required by SLAED3.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. MIN(1,N) <= CUTPNT <= N.\n*\n* Z (input) REAL array, dimension (N)\n* On input this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix). The contents of Z are\n* destroyed during the updating process.\n*\n* DLAMDA (output) REAL array, dimension (N)\n* Contains a copy of the first K eigenvalues which will be used\n* by SLAED3 to form the secular equation.\n*\n* Q2 (output) COMPLEX array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* Contains a copy of the first K eigenvectors which will be used\n* by SLAED7 in a matrix multiply (SGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max( 1, N ).\n*\n* W (output) REAL array, dimension (N)\n* This will hold the first k values of the final\n* deflation-altered z-vector and will be passed to SLAED3.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output INDXP(1:K)\n* points to the nondeflated D-values and INDXP(K+1:N)\n* points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that elements in\n* the second half of this permutation must first have CUTPNT\n* added to their values in order to be accurate.\n*\n* PERM (output) INTEGER array, dimension (N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* Contains the number of Givens rotations which took place in\n* this subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) REAL array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.claed8( qsiz, q, d, rho, cutpnt, z, indxq, [: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_qsiz = argv[0];
+ rblapack_q = argv[1];
+ rblapack_d = argv[2];
+ rblapack_rho = argv[3];
+ rblapack_cutpnt = argv[4];
+ rblapack_z = argv[5];
+ rblapack_indxq = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ qsiz = NUM2INT(rblapack_qsiz);
+ 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*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ if (!NA_IsNArray(rblapack_indxq))
+ rb_raise(rb_eArgError, "indxq (7th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (2th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ ldq2 = MAX( 1, n );
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
+ {
+ int shape[2];
+ shape[0] = ldq2;
+ shape[1] = n;
+ rblapack_q2 = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q2 = NA_PTR_TYPE(rblapack_q2, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_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__;
+ indxp = ALLOC_N(integer, (n));
+ indx = ALLOC_N(integer, (n));
+
+ claed8_(&k, &n, &qsiz, q, &ldq, d, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, indxp, indx, indxq, perm, &givptr, givcol, givnum, &info);
+
+ free(indxp);
+ free(indx);
+ rblapack_k = INT2NUM(k);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_info = INT2NUM(info);
+ rblapack_rho = rb_float_new((double)rho);
+ return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_q, rblapack_d, rblapack_rho);
+}
+
+void
+init_lapack_claed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claed8", rblapack_claed8, -1);
+}
diff --git a/ext/claein.c b/ext/claein.c
new file mode 100644
index 0000000..06a2226
--- /dev/null
+++ b/ext/claein.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID claein_(logical* rightv, logical* noinit, integer* n, complex* h, integer* ldh, complex* w, complex* v, complex* b, integer* ldb, real* rwork, real* eps3, real* smlnum, integer* info);
+
+
+static VALUE
+rblapack_claein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_rightv;
+ logical rightv;
+ VALUE rblapack_noinit;
+ logical noinit;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_w;
+ complex w;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_eps3;
+ real eps3;
+ VALUE rblapack_smlnum;
+ real smlnum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ complex *v_out__;
+ complex *b;
+ real *rwork;
+
+ integer ldh;
+ integer n;
+ integer ldb;
+
+ 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, v = NumRu::Lapack.claein( rightv, noinit, h, w, v, eps3, smlnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n* Purpose\n* =======\n*\n* CLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue W of a complex upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in V\n* = .FALSE.: initial vector supplied in V.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input) COMPLEX\n* The eigenvalue of H whose corresponding right or left\n* eigenvector is to be computed.\n*\n* V (input/output) COMPLEX array, dimension (N)\n* On entry, if NOINIT = .FALSE., V must contain a starting\n* vector for inverse iteration; otherwise V need not be set.\n* On exit, V contains the computed eigenvector, normalized so\n* that the component of largest magnitude has magnitude 1; here\n* the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n*\n* B (workspace) COMPLEX array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* RWORK (workspace) REAL array, dimension (N)\n*\n* EPS3 (input) REAL\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) REAL\n* A machine-dependent value close to the underflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; V is set to the\n* last iterate.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.claein( rightv, noinit, h, w, v, eps3, smlnum, [: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_rightv = argv[0];
+ rblapack_noinit = argv[1];
+ rblapack_h = argv[2];
+ rblapack_w = argv[3];
+ rblapack_v = argv[4];
+ rblapack_eps3 = argv[5];
+ rblapack_smlnum = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ rightv = (rblapack_rightv == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (3th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (5th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ smlnum = (real)NUM2DBL(rblapack_smlnum);
+ noinit = (rblapack_noinit == Qtrue);
+ eps3 = (real)NUM2DBL(rblapack_eps3);
+ w.r = (real)NUM2DBL(rb_funcall(rblapack_w, rb_intern("real"), 0));
+ w.i = (real)NUM2DBL(rb_funcall(rblapack_w, rb_intern("imag"), 0));
+ ldb = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
+ MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ b = ALLOC_N(complex, (ldb)*(n));
+ rwork = ALLOC_N(real, (n));
+
+ claein_(&rightv, &noinit, &n, h, &ldh, &w, v, b, &ldb, rwork, &eps3, &smlnum, &info);
+
+ free(b);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_claein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claein", rblapack_claein, -1);
+}
diff --git a/ext/claesy.c b/ext/claesy.c
new file mode 100644
index 0000000..676137b
--- /dev/null
+++ b/ext/claesy.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID claesy_(complex* a, complex* b, complex* c, complex* rt1, complex* rt2, complex* evscal, complex* cs1, complex* sn1);
+
+
+static VALUE
+rblapack_claesy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex a;
+ VALUE rblapack_b;
+ complex b;
+ VALUE rblapack_c;
+ complex c;
+ VALUE rblapack_rt1;
+ complex rt1;
+ VALUE rblapack_rt2;
+ complex rt2;
+ VALUE rblapack_evscal;
+ complex evscal;
+ VALUE rblapack_cs1;
+ complex cs1;
+ VALUE rblapack_sn1;
+ complex sn1;
+
+
+ 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 rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.claesy( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n* ( ( A, B );( B, C ) )\n* provided the norm of the matrix of eigenvectors is larger than\n* some threshold value.\n*\n* RT1 is the eigenvalue of larger absolute value, and RT2 of\n* smaller absolute value. If the eigenvectors are computed, then\n* on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n*\n* [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]\n* [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX\n* The ( 1, 1 ) element of input matrix.\n*\n* B (input) COMPLEX\n* The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element\n* is also given by B, since the 2-by-2 matrix is symmetric.\n*\n* C (input) COMPLEX\n* The ( 2, 2 ) element of input matrix.\n*\n* RT1 (output) COMPLEX\n* The eigenvalue of larger modulus.\n*\n* RT2 (output) COMPLEX\n* The eigenvalue of smaller modulus.\n*\n* EVSCAL (output) COMPLEX\n* The complex value by which the eigenvector matrix was scaled\n* to make it orthonormal. If EVSCAL is zero, the eigenvectors\n* were not computed. This means one of two things: the 2-by-2\n* matrix could not be diagonalized, or the norm of the matrix\n* of eigenvectors before scaling was larger than the threshold\n* value THRESH (set below).\n*\n* CS1 (output) COMPLEX\n* SN1 (output) COMPLEX\n* If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector\n* for RT1.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.claesy( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a.r = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
+ a.i = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
+ c.r = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
+ c.i = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
+ b.r = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
+ b.i = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));
+
+ claesy_(&a, &b, &c, &rt1, &rt2, &evscal, &cs1, &sn1);
+
+ rblapack_rt1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt1.r)), rb_float_new((double)(rt1.i)));
+ rblapack_rt2 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt2.r)), rb_float_new((double)(rt2.i)));
+ rblapack_evscal = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(evscal.r)), rb_float_new((double)(evscal.i)));
+ rblapack_cs1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(cs1.r)), rb_float_new((double)(cs1.i)));
+ rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
+ return rb_ary_new3(5, rblapack_rt1, rblapack_rt2, rblapack_evscal, rblapack_cs1, rblapack_sn1);
+}
+
+void
+init_lapack_claesy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claesy", rblapack_claesy, -1);
+}
diff --git a/ext/claev2.c b/ext/claev2.c
new file mode 100644
index 0000000..a6c5808
--- /dev/null
+++ b/ext/claev2.c
@@ -0,0 +1,71 @@
+#include "rb_lapack.h"
+
+extern VOID claev2_(complex* a, complex* b, complex* c, real* rt1, real* rt2, real* cs1, complex* sn1);
+
+
+static VALUE
+rblapack_claev2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex a;
+ VALUE rblapack_b;
+ complex b;
+ VALUE rblapack_c;
+ complex c;
+ VALUE rblapack_rt1;
+ real rt1;
+ VALUE rblapack_rt2;
+ real rt2;
+ VALUE rblapack_cs1;
+ real cs1;
+ VALUE rblapack_sn1;
+ complex sn1;
+
+
+ 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 rt1, rt2, cs1, sn1 = NumRu::Lapack.claev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n* [ A B ]\n* [ CONJG(B) C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) COMPLEX\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) COMPLEX\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) REAL\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) REAL\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) REAL\n* SN1 (output) COMPLEX\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.claev2( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a.r = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
+ a.i = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
+ c.r = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
+ c.i = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
+ b.r = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
+ b.i = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));
+
+ claev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
+
+ rblapack_rt1 = rb_float_new((double)rt1);
+ rblapack_rt2 = rb_float_new((double)rt2);
+ rblapack_cs1 = rb_float_new((double)cs1);
+ rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
+ return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
+}
+
+void
+init_lapack_claev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claev2", rblapack_claev2, -1);
+}
diff --git a/ext/clag2z.c b/ext/clag2z.c
new file mode 100644
index 0000000..e232875
--- /dev/null
+++ b/ext/clag2z.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID clag2z_(integer* m, integer* n, complex* sa, integer* ldsa, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_clag2z(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_sa;
+ complex *sa;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldsa;
+ integer n;
+ integer lda;
+
+ 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 a, info = NumRu::Lapack.clag2z( m, sa, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A.\n*\n* Note that while it is possible to overflow while converting\n* from double to single, it is not possible to overflow when\n* converting from single to double.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* SA (input) COMPLEX array, dimension (LDSA,N)\n* On entry, the M-by-N coefficient matrix SA.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* A (output) COMPLEX*16 array, dimension (LDA,N)\n* On exit, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.clag2z( m, sa, [: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_m = argv[0];
+ rblapack_sa = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ lda = MAX(1,m);
+ if (!NA_IsNArray(rblapack_sa))
+ rb_raise(rb_eArgError, "sa (2th argument) must be NArray");
+ if (NA_RANK(rblapack_sa) != 2)
+ rb_raise(rb_eArgError, "rank of sa (2th argument) must be %d", 2);
+ ldsa = NA_SHAPE0(rblapack_sa);
+ n = NA_SHAPE1(rblapack_sa);
+ if (NA_TYPE(rblapack_sa) != NA_SCOMPLEX)
+ rblapack_sa = na_change_type(rblapack_sa, NA_SCOMPLEX);
+ sa = NA_PTR_TYPE(rblapack_sa, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+
+ clag2z_(&m, &n, sa, &ldsa, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_clag2z(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clag2z", rblapack_clag2z, -1);
+}
diff --git a/ext/clags2.c b/ext/clags2.c
new file mode 100644
index 0000000..269de53
--- /dev/null
+++ b/ext/clags2.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID clags2_(logical* upper, real* a1, complex* a2, real* a3, real* b1, complex* b2, real* b3, real* csu, complex* snu, real* csv, complex* snv, real* csq, complex* snq);
+
+
+static VALUE
+rblapack_clags2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_upper;
+ logical upper;
+ VALUE rblapack_a1;
+ real a1;
+ VALUE rblapack_a2;
+ complex a2;
+ VALUE rblapack_a3;
+ real a3;
+ VALUE rblapack_b1;
+ real b1;
+ VALUE rblapack_b2;
+ complex b2;
+ VALUE rblapack_b3;
+ real b3;
+ VALUE rblapack_csu;
+ real csu;
+ VALUE rblapack_snu;
+ complex snu;
+ VALUE rblapack_csv;
+ real csv;
+ VALUE rblapack_snv;
+ complex snv;
+ VALUE rblapack_csq;
+ real csq;
+ VALUE rblapack_snq;
+ complex snq;
+
+
+ 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 csu, snu, csv, snv, csq, snq = NumRu::Lapack.clags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n* where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ),\n* ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV )\n*\n* Q = ( CSQ SNQ )\n* ( -CONJG(SNQ) CSQ )\n*\n* Z' denotes the conjugate transpose of Z.\n*\n* The rows of the transformed A and B are parallel. Moreover, if the\n* input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n* of A is not zero. If the input matrices A and B are both not zero,\n* then the transformed (2,2) element of B is not zero, except when the\n* first rows of input A and B are parallel and the second rows are\n* zero.\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) REAL\n* A2 (input) COMPLEX\n* A3 (input) REAL\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) REAL\n* B2 (input) COMPLEX\n* B3 (input) REAL\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) REAL\n* SNU (output) COMPLEX\n* The desired unitary matrix U.\n*\n* CSV (output) REAL\n* SNV (output) COMPLEX\n* The desired unitary matrix V.\n*\n* CSQ (output) REAL\n* SNQ (output) COMPLEX\n* The desired unitary matrix Q.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.clags2( upper, a1, a2, a3, b1, b2, b3, [: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_upper = argv[0];
+ rblapack_a1 = argv[1];
+ rblapack_a2 = argv[2];
+ rblapack_a3 = argv[3];
+ rblapack_b1 = argv[4];
+ rblapack_b2 = argv[5];
+ rblapack_b3 = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ upper = (rblapack_upper == Qtrue);
+ a2.r = (real)NUM2DBL(rb_funcall(rblapack_a2, rb_intern("real"), 0));
+ a2.i = (real)NUM2DBL(rb_funcall(rblapack_a2, rb_intern("imag"), 0));
+ b1 = (real)NUM2DBL(rblapack_b1);
+ b3 = (real)NUM2DBL(rblapack_b3);
+ a1 = (real)NUM2DBL(rblapack_a1);
+ b2.r = (real)NUM2DBL(rb_funcall(rblapack_b2, rb_intern("real"), 0));
+ b2.i = (real)NUM2DBL(rb_funcall(rblapack_b2, rb_intern("imag"), 0));
+ a3 = (real)NUM2DBL(rblapack_a3);
+
+ clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
+
+ rblapack_csu = rb_float_new((double)csu);
+ rblapack_snu = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snu.r)), rb_float_new((double)(snu.i)));
+ rblapack_csv = rb_float_new((double)csv);
+ rblapack_snv = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snv.r)), rb_float_new((double)(snv.i)));
+ rblapack_csq = rb_float_new((double)csq);
+ rblapack_snq = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snq.r)), rb_float_new((double)(snq.i)));
+ return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
+}
+
+void
+init_lapack_clags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clags2", rblapack_clags2, -1);
+}
diff --git a/ext/clagtm.c b/ext/clagtm.c
new file mode 100644
index 0000000..b7d04e7
--- /dev/null
+++ b/ext/clagtm.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID clagtm_(char* trans, integer* n, integer* nrhs, real* alpha, complex* dl, complex* d, complex* du, complex* x, integer* ldx, real* beta, complex* b, integer* ldb);
+
+
+static VALUE
+rblapack_clagtm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldx;
+ integer nrhs;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.clagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* CLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A**T * X + beta * B\n* = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B\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 X and B.\n*\n* ALPHA (input) REAL\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) COMPLEX array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) COMPLEX array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) COMPLEX array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) REAL\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.clagtm( trans, alpha, dl, d, du, x, beta, b, [: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_trans = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_x = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ beta = (real)NUM2DBL(rblapack_beta);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ clagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_clagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clagtm", rblapack_clagtm, -1);
+}
diff --git a/ext/clahef.c b/ext/clahef.c
new file mode 100644
index 0000000..d5a2c70
--- /dev/null
+++ b/ext/clahef.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID clahef_(char* uplo, integer* n, integer* nb, integer* kb, complex* a, integer* lda, integer* ipiv, complex* w, integer* ldw, integer* info);
+
+
+static VALUE
+rblapack_clahef(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *w;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 kb, ipiv, info, a = NumRu::Lapack.clahef( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* CLAHEF computes a partial factorization of a complex Hermitian\n* matrix A using the Bunch-Kaufman diagonal pivoting method. The\n* partial factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the conjugate transpose of U.\n*\n* CLAHEF is an auxiliary routine called by CHETRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.clahef( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ w = ALLOC_N(complex, (ldw)*(MAX(n,nb)));
+
+ clahef_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
+
+ free(w);
+ rblapack_kb = INT2NUM(kb);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_clahef(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clahef", rblapack_clahef, -1);
+}
diff --git a/ext/clahqr.c b/ext/clahqr.c
new file mode 100644
index 0000000..70606a3
--- /dev/null
+++ b/ext/clahqr.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID clahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, integer* iloz, integer* ihiz, complex* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_clahqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer ldh;
+ 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 w, info, h, z = NumRu::Lapack.clahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* CLAHQR is an auxiliary routine called by CHSEQR to update the\n* eigenvalues and Schur decomposition already computed by CHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows and\n* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n* CLAHQR works primarily with the Hessenberg submatrix in rows\n* and columns ILO to IHI, but applies transformations to all of\n* H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., then H\n* is upper triangular in rows and columns ILO:IHI. If INFO\n* is zero and if WANTT is .FALSE., then the contents of H\n* are unspecified on exit. The output state of H in case\n* INF is positive is below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues ILO to IHI are stored in the\n* corresponding elements of W. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with W(i) = H(i,i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by CHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, CLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of W contain\n* those eigenvalues which have been successfully\n* computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix\n* rows and columns ILO thorugh INFO of the final,\n* output value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of CLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, info, h, z = NumRu::Lapack.clahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_iloz = argv[5];
+ rblapack_ihiz = argv[6];
+ rblapack_z = argv[7];
+ rblapack_ldz = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = NUM2INT(rblapack_ldz);
+ wantz = (rblapack_wantz == Qtrue);
+ iloz = NUM2INT(rblapack_iloz);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? n : 0;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ clahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_clahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clahqr", rblapack_clahqr, -1);
+}
diff --git a/ext/clahr2.c b/ext/clahr2.c
new file mode 100644
index 0000000..7977029
--- /dev/null
+++ b/ext/clahr2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID clahr2_(integer* n, integer* k, integer* nb, complex* a, integer* lda, complex* tau, complex* t, integer* ldt, complex* y, integer* ldy);
+
+
+static VALUE
+rblapack_clahr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.clahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by CGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.clahr2( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ ldy = n;
+ k = NUM2INT(rblapack_k);
+ ldt = nb;
+ 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-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_clahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clahr2", rblapack_clahr2, -1);
+}
diff --git a/ext/clahrd.c b/ext/clahrd.c
new file mode 100644
index 0000000..bbb48cf
--- /dev/null
+++ b/ext/clahrd.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID clahrd_(integer* n, integer* k, integer* nb, complex* a, integer* lda, complex* tau, complex* t, integer* ldt, complex* y, integer* ldy);
+
+
+static VALUE
+rblapack_clahrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.clahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by a unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine CLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.clahrd( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ ldy = MAX(1,n);
+ k = NUM2INT(rblapack_k);
+ ldt = nb;
+ 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-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_clahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clahrd", rblapack_clahrd, -1);
+}
diff --git a/ext/claic1.c b/ext/claic1.c
new file mode 100644
index 0000000..efa7ee2
--- /dev/null
+++ b/ext/claic1.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID claic1_(integer* job, integer* j, complex* x, real* sest, complex* w, complex* gamma, real* sestpr, complex* s, complex* c);
+
+
+static VALUE
+rblapack_claic1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ integer job;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_sest;
+ real sest;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_gamma;
+ complex gamma;
+ VALUE rblapack_sestpr;
+ real sestpr;
+ VALUE rblapack_s;
+ complex s;
+ VALUE rblapack_c;
+ complex c;
+
+ integer j;
+
+ 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 sestpr, s, c = NumRu::Lapack.claic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* CLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then CLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]\n* [ conjg(gamma) ]\n*\n* where alpha = conjg(x)'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) COMPLEX array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) REAL\n* Estimated singular value of j by j matrix L\n*\n* W (input) COMPLEX array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) COMPLEX\n* The diagonal element gamma.\n*\n* SESTPR (output) REAL\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) COMPLEX\n* Sine needed in forming xhat.\n*\n* C (output) COMPLEX\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.claic1( job, x, sest, w, gamma, [: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_job = argv[0];
+ rblapack_x = argv[1];
+ rblapack_sest = argv[2];
+ rblapack_w = argv[3];
+ rblapack_gamma = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = NUM2INT(rblapack_job);
+ sest = (real)NUM2DBL(rblapack_sest);
+ gamma.r = (real)NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("real"), 0));
+ gamma.i = (real)NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("imag"), 0));
+ 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);
+ j = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (4th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != j)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_SCOMPLEX)
+ rblapack_w = na_change_type(rblapack_w, NA_SCOMPLEX);
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+
+ claic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
+
+ rblapack_sestpr = rb_float_new((double)sestpr);
+ rblapack_s = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(s.r)), rb_float_new((double)(s.i)));
+ rblapack_c = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(c.r)), rb_float_new((double)(c.i)));
+ return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
+}
+
+void
+init_lapack_claic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claic1", rblapack_claic1, -1);
+}
diff --git a/ext/clals0.c b/ext/clals0.c
new file mode 100644
index 0000000..8850a2e
--- /dev/null
+++ b/ext/clals0.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID clals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, complex* b, integer* ldb, complex* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* poles, real* difl, real* difr, real* z, integer* k, real* c, real* s, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_clals0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_poles;
+ real *poles;
+ VALUE rblapack_difl;
+ real *difl;
+ VALUE rblapack_difr;
+ real *difr;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_s;
+ real s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *bx;
+ real *rwork;
+
+ integer ldb;
+ integer nrhs;
+ integer n;
+ integer ldgcol;
+ integer ldgnum;
+ integer k;
+ integer ldbx;
+
+ 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, b = NumRu::Lapack.clals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) COMPLEX array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) REAL array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) REAL array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) REAL array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) REAL array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* RWORK (workspace) REAL array, dimension\n* ( K*(1+NRHS) + 2*NRHS )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.clals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_b = argv[4];
+ rblapack_perm = argv[5];
+ rblapack_givptr = argv[6];
+ rblapack_givcol = argv[7];
+ rblapack_givnum = argv[8];
+ rblapack_poles = argv[9];
+ rblapack_difl = argv[10];
+ rblapack_difr = argv[11];
+ rblapack_z = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ givptr = NUM2INT(rblapack_givptr);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
+ ldgnum = NA_SHAPE0(rblapack_givnum);
+ if (NA_SHAPE1(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
+ if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 1)
+ rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_difl);
+ if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, real*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (13th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ s = (real)NUM2DBL(rblapack_s);
+ nl = NUM2INT(rblapack_nl);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_perm);
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_poles) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
+ if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, real*);
+ c = (real)NUM2DBL(rblapack_c);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_difr) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
+ if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, real*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_givcol);
+ if (NA_SHAPE1(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ ldbx = n;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ bx = ALLOC_N(complex, (ldbx)*(nrhs));
+ rwork = ALLOC_N(real, (k*(1+nrhs) + 2*nrhs));
+
+ clals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, rwork, &info);
+
+ free(bx);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_clals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clals0", rblapack_clals0, -1);
+}
diff --git a/ext/clalsa.c b/ext/clalsa.c
new file mode 100644
index 0000000..098a76f
--- /dev/null
+++ b/ext/clalsa.c
@@ -0,0 +1,270 @@
+#include "rb_lapack.h"
+
+extern VOID clalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, complex* b, integer* ldb, complex* bx, integer* ldbx, real* u, integer* ldu, real* vt, integer* k, real* difl, real* difr, real* z, real* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, real* givnum, real* c, real* s, real* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_clalsa(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_difl;
+ real *difl;
+ VALUE rblapack_difr;
+ real *difr;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_poles;
+ real *poles;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_bx;
+ complex *bx;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ real *rwork;
+ integer *iwork;
+
+ integer ldb;
+ integer nrhs;
+ integer ldu;
+ integer smlsiz;
+ integer n;
+ integer nlvl;
+ integer ldgcol;
+ integer ldbx;
+
+ 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 bx, info, b = NumRu::Lapack.clalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, CLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, CLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by CLALSA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) COMPLEX array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) REAL array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) REAL array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) REAL array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* RWORK (workspace) REAL array, dimension at least\n* MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.clalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_b = argv[1];
+ rblapack_u = argv[2];
+ rblapack_vt = argv[3];
+ rblapack_k = argv[4];
+ rblapack_difl = argv[5];
+ rblapack_difr = argv[6];
+ rblapack_z = argv[7];
+ rblapack_poles = argv[8];
+ rblapack_givptr = argv[9];
+ rblapack_givcol = argv[10];
+ rblapack_perm = argv[11];
+ rblapack_givnum = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (3th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ smlsiz = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (5th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (14th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
+ 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_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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (15th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_vt) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
+ if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, real*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, real*);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 2)
+ rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_perm);
+ if (NA_SHAPE1(rblapack_perm) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ ldbx = n;
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 2)
+ rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difl) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difl) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, real*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != ldgcol)
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
+ if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_z) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ {
+ int shape[2];
+ shape[0] = ldbx;
+ shape[1] = nrhs;
+ rblapack_bx = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ bx = NA_PTR_TYPE(rblapack_bx, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(real, (MAX(n,(smlsiz+1)*nrhs*3)));
+ iwork = ALLOC_N(integer, (3 * n));
+
+ clalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, rwork, iwork, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_clalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clalsa", rblapack_clalsa, -1);
+}
diff --git a/ext/clalsd.c b/ext/clalsd.c
new file mode 100644
index 0000000..9028666
--- /dev/null
+++ b/ext/clalsd.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID clalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, real* d, real* e, complex* b, integer* ldb, real* rcond, integer* rank, complex* work, real* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_clalsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ integer nlvl;
+ complex *work;
+ real *rwork;
+ integer *iwork;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 rank, info, d, e, b = NumRu::Lapack.clalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) REAL array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) REAL\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) COMPLEX array, dimension (N * NRHS).\n*\n* RWORK (workspace) REAL array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n* where\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*\n* IWORK (workspace) INTEGER array, dimension (3*N*NLVL + 11*N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.clalsd( uplo, smlsiz, d, e, b, rcond, [: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_smlsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_b = argv[4];
+ rblapack_rcond = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_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 (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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ nlvl = ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1;
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (n * nrhs));
+ rwork = ALLOC_N(real, (9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)));
+ iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
+
+ clalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, rwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_clalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clalsd", rblapack_clalsd, -1);
+}
diff --git a/ext/clangb.c b/ext/clangb.c
new file mode 100644
index 0000000..7f57801
--- /dev/null
+++ b/ext/clangb.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern real clangb_(char* norm, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, real* work);
+
+
+static VALUE
+rblapack_clangb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer ldab;
+ 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 __out__ = NumRu::Lapack.clangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* CLANGB returns the value\n*\n* CLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clangb( norm, kl, ku, ab, [: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_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ work = ALLOC_N(real, (MAX(1,lsame_(&norm,"I") ? n : 0)));
+
+ __out__ = clangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clangb", rblapack_clangb, -1);
+}
diff --git a/ext/clange.c b/ext/clange.c
new file mode 100644
index 0000000..490383c
--- /dev/null
+++ b/ext/clange.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern real clange_(char* norm, integer* m, integer* n, complex* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_clange(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.clange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex matrix A.\n*\n* Description\n* ===========\n*\n* CLANGE returns the value\n*\n* CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* CLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* CLANGE is set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clange( norm, m, a, [: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_norm = argv[0];
+ rblapack_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = clange_(&norm, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clange", rblapack_clange, -1);
+}
diff --git a/ext/clangt.c b/ext/clangt.c
new file mode 100644
index 0000000..0d2218b
--- /dev/null
+++ b/ext/clangt.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern real clangt_(char* norm, integer* n, complex* dl, complex* d, complex* du);
+
+
+static VALUE
+rblapack_clangt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_dl;
+ complex *dl;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_du;
+ complex *du;
+ VALUE rblapack___out__;
+ real __out__;
+
+ 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 __out__ = NumRu::Lapack.clangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* CLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* CLANGT returns the value\n*\n* CLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANGT is\n* set to zero.\n*\n* DL (input) COMPLEX array, dimension (N-1)\n* The (n-1) sub-diagonal elements of A.\n*\n* D (input) COMPLEX array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX array, dimension (N-1)\n* The (n-1) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clangt( norm, dl, d, du, [: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_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ if (argc == 4) {
+ } 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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_SCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, complex*);
+ 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_SCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, complex*);
+
+ __out__ = clangt_(&norm, &n, dl, d, du);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clangt", rblapack_clangt, -1);
+}
diff --git a/ext/clanhb.c b/ext/clanhb.c
new file mode 100644
index 0000000..4e6b076
--- /dev/null
+++ b/ext/clanhb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern real clanhb_(char* norm, char* uplo, integer* n, integer* k, complex* ab, integer* ldab, real* work);
+
+
+static VALUE
+rblapack_clanhb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.clanhb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANHB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n hermitian band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* CLANHB returns the value\n*\n* CLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the hermitian band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhb( norm, uplo, k, ab, [: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_k = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ k = NUM2INT(rblapack_k);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = clanhb_(&norm, &uplo, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clanhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clanhb", rblapack_clanhb, -1);
+}
diff --git a/ext/clanhe.c b/ext/clanhe.c
new file mode 100644
index 0000000..c806268
--- /dev/null
+++ b/ext/clanhe.c
@@ -0,0 +1,72 @@
+#include "rb_lapack.h"
+
+extern real clanhe_(char* norm, char* uplo, integer* n, complex* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_clanhe(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ 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 __out__ = NumRu::Lapack.clanhe( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANHE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A.\n*\n* Description\n* ===========\n*\n* CLANHE returns the value\n*\n* CLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHE as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHE is\n* set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The hermitian matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced. Note that the imaginary parts of the diagonal\n* elements need not be set and are assumed to be zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhe( norm, uplo, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));
+
+ __out__ = clanhe_(&norm, &uplo, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clanhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clanhe", rblapack_clanhe, -1);
+}
diff --git a/ext/clanhf.c b/ext/clanhf.c
new file mode 100644
index 0000000..b5484c6
--- /dev/null
+++ b/ext/clanhf.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern real clanhf_(char* norm, char* transr, char* uplo, integer* n, doublecomplex* a, real* work);
+
+
+static VALUE
+rblapack_clanhf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.clanhf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* CLANHF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* CLANHF returns the value\n*\n* CLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER\n* Specifies the value to be returned in CLANHF as described\n* above.\n*\n* TRANSR (input) CHARACTER\n* Specifies whether the RFP format of A is normal or\n* conjugate-transposed format.\n* = 'N': RFP format is Normal\n* = 'C': RFP format is Conjugate-transposed\n*\n* UPLO (input) CHARACTER\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n*\n* UPLO = 'U' or 'u' RFP A came from an upper triangular\n* matrix\n*\n* UPLO = 'L' or 'l' RFP A came from a lower triangular\n* matrix\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHF is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n* as defined when TRANSR = 'N'. The contents of RFP A are\n* defined by UPLO as follows: If UPLO = 'U' the RFP A\n* contains the ( N*(N+1)/2 ) elements of upper packed A\n* either in normal or conjugate-transpose Format. If\n* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n* of lower packed A either in normal or conjugate-transpose\n* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n* TRANSR is 'N' the LDA is N+1 when N is even and is N when\n* is odd. See the Note below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) REAL array, dimension (LWORK),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhf( norm, transr, uplo, n, a, [: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_norm = argv[0];
+ rblapack_transr = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ work = ALLOC_N(real, (lwork));
+
+ __out__ = clanhf_(&norm, &transr, &uplo, &n, a, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clanhf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clanhf", rblapack_clanhf, -1);
+}
diff --git a/ext/clanhp.c b/ext/clanhp.c
new file mode 100644
index 0000000..dd133ca
--- /dev/null
+++ b/ext/clanhp.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern real clanhp_(char* norm, char* uplo, integer* n, complex* ap, real* work);
+
+
+static VALUE
+rblapack_clanhp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+
+ 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 __out__ = NumRu::Lapack.clanhp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* CLANHP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* CLANHP returns the value\n*\n* CLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHP is\n* set to zero.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhp( norm, uplo, 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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ n = NUM2INT(rblapack_n);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"O")) ? n : 0)));
+
+ __out__ = clanhp_(&norm, &uplo, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clanhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clanhp", rblapack_clanhp, -1);
+}
diff --git a/ext/clanhs.c b/ext/clanhs.c
new file mode 100644
index 0000000..e93bb8b
--- /dev/null
+++ b/ext/clanhs.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern real clanhs_(char* norm, integer* n, complex* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_clanhs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.clanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* CLANHS returns the value\n*\n* CLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHS is\n* set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanhs( norm, 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_norm = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = clanhs_(&norm, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clanhs", rblapack_clanhs, -1);
+}
diff --git a/ext/clanht.c b/ext/clanht.c
new file mode 100644
index 0000000..455bddf
--- /dev/null
+++ b/ext/clanht.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern real clanht_(char* norm, integer* n, real* d, complex* e);
+
+
+static VALUE
+rblapack_clanht(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack___out__;
+ real __out__;
+
+ 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 __out__ = NumRu::Lapack.clanht( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANHT( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* CLANHT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* CLANHT returns the value\n*\n* CLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANHT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANHT is\n* set to zero.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clanht( norm, d, e, [: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_norm = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+
+ __out__ = clanht_(&norm, &n, d, e);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clanht(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clanht", rblapack_clanht, -1);
+}
diff --git a/ext/clansb.c b/ext/clansb.c
new file mode 100644
index 0000000..01cef81
--- /dev/null
+++ b/ext/clansb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern real clansb_(char* norm, char* uplo, integer* n, integer* k, complex* ab, integer* ldab, real* work);
+
+
+static VALUE
+rblapack_clansb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.clansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* CLANSB returns the value\n*\n* CLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clansb( norm, uplo, k, ab, [: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_k = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ k = NUM2INT(rblapack_k);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = clansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clansb", rblapack_clansb, -1);
+}
diff --git a/ext/clansp.c b/ext/clansp.c
new file mode 100644
index 0000000..9dc220b
--- /dev/null
+++ b/ext/clansp.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern real clansp_(char* norm, char* uplo, integer* n, complex* ap, real* work);
+
+
+static VALUE
+rblapack_clansp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+
+ 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 __out__ = NumRu::Lapack.clansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* CLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* CLANSP returns the value\n*\n* CLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANSP is\n* set to zero.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clansp( norm, uplo, 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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ n = NUM2INT(rblapack_n);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"O")) ? n : 0)));
+
+ __out__ = clansp_(&norm, &uplo, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clansp", rblapack_clansp, -1);
+}
diff --git a/ext/clansy.c b/ext/clansy.c
new file mode 100644
index 0000000..54a0eb9
--- /dev/null
+++ b/ext/clansy.c
@@ -0,0 +1,72 @@
+#include "rb_lapack.h"
+
+extern real clansy_(char* norm, char* uplo, integer* n, complex* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_clansy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ 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 __out__ = NumRu::Lapack.clansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A.\n*\n* Description\n* ===========\n*\n* CLANSY returns the value\n*\n* CLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANSY is\n* set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clansy( norm, uplo, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));
+
+ __out__ = clansy_(&norm, &uplo, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clansy", rblapack_clansy, -1);
+}
diff --git a/ext/clantb.c b/ext/clantb.c
new file mode 100644
index 0000000..b8f8c4e
--- /dev/null
+++ b/ext/clantb.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern real clantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, complex* ab, integer* ldab, real* work);
+
+
+static VALUE
+rblapack_clantb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer ldab;
+ 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 __out__ = NumRu::Lapack.clantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* CLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* CLANTB returns the value\n*\n* CLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clantb( norm, uplo, diag, k, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_k = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ k = NUM2INT(rblapack_k);
+ work = ALLOC_N(real, (MAX(1,lsame_(&norm,"I") ? n : 0)));
+
+ __out__ = clantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clantb", rblapack_clantb, -1);
+}
diff --git a/ext/clantp.c b/ext/clantp.c
new file mode 100644
index 0000000..cf1aff5
--- /dev/null
+++ b/ext/clantp.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern real clantp_(char* norm, char* uplo, char* diag, integer* n, complex* ap, real* work);
+
+
+static VALUE
+rblapack_clantp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.clantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* CLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* CLANTP returns the value\n*\n* CLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, CLANTP is\n* set to zero.\n*\n* AP (input) COMPLEX 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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clantp( norm, uplo, diag, n, ap, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_ap = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ 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) != (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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = clantp_(&norm, &uplo, &diag, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clantp", rblapack_clantp, -1);
+}
diff --git a/ext/clantr.c b/ext/clantr.c
new file mode 100644
index 0000000..a1bac0e
--- /dev/null
+++ b/ext/clantr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern real clantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, complex* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_clantr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.clantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* CLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* CLANTR returns the value\n*\n* CLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in CLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, CLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, CLANTR is set to zero.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.clantr( norm, uplo, diag, m, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_m = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = clantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_clantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clantr", rblapack_clantr, -1);
+}
diff --git a/ext/clapll.c b/ext/clapll.c
new file mode 100644
index 0000000..3540194
--- /dev/null
+++ b/ext/clapll.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID clapll_(integer* n, complex* x, integer* incx, complex* y, integer* incy, real* ssmin);
+
+
+static VALUE
+rblapack_clapll(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_ssmin;
+ real ssmin;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_y_out__;
+ complex *y_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 ssmin, x, y = NumRu::Lapack.clapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) REAL\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.clapll( n, x, incx, y, incy, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ clapll_(&n, x, &incx, y, &incy, &ssmin);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_clapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clapll", rblapack_clapll, -1);
+}
diff --git a/ext/clapmr.c b/ext/clapmr.c
new file mode 100644
index 0000000..dec975f
--- /dev/null
+++ b/ext/clapmr.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID clapmr_(logical* forwrd, integer* m, integer* n, complex* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_clapmr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ integer ldx;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.clapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* CLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n COMPLEX TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.clapmr( forwrd, x, k, [: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_forwrd = argv[0];
+ rblapack_x = argv[1];
+ rblapack_k = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (3th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ clapmr_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_clapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clapmr", rblapack_clapmr, -1);
+}
diff --git a/ext/clapmt.c b/ext/clapmt.c
new file mode 100644
index 0000000..995b33e
--- /dev/null
+++ b/ext/clapmt.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID clapmt_(logical* forwrd, integer* m, integer* n, complex* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_clapmt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ 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 x, k = NumRu::Lapack.clapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* CLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, J, IN\n COMPLEX TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.clapmt( forwrd, m, x, k, [: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_forwrd = argv[0];
+ rblapack_m = argv[1];
+ rblapack_x = argv[2];
+ rblapack_k = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (4th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_k) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ clapmt_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_clapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clapmt", rblapack_clapmt, -1);
+}
diff --git a/ext/claqgb.c b/ext/claqgb.c
new file mode 100644
index 0000000..340ffe5
--- /dev/null
+++ b/ext/claqgb.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID claqgb_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqgb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.claqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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, ab = NumRu::Lapack.claqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_r = argv[3];
+ rblapack_c = argv[4];
+ rblapack_rowcnd = argv[5];
+ rblapack_colcnd = argv[6];
+ rblapack_amax = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ colcnd = (real)NUM2DBL(rblapack_colcnd);
+ ku = NUM2INT(rblapack_ku);
+ rowcnd = (real)NUM2DBL(rblapack_rowcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (4th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ claqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_claqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqgb", rblapack_claqgb, -1);
+}
diff --git a/ext/claqge.c b/ext/claqge.c
new file mode 100644
index 0000000..b88ec3b
--- /dev/null
+++ b/ext/claqge.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID claqge_(integer* m, integer* n, complex* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqge(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.claqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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.claqge( a, r, c, rowcnd, colcnd, amax, [: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_a = argv[0];
+ rblapack_r = argv[1];
+ rblapack_c = argv[2];
+ rblapack_rowcnd = argv[3];
+ rblapack_colcnd = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ colcnd = (real)NUM2DBL(rblapack_colcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (2th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ rowcnd = (real)NUM2DBL(rblapack_rowcnd);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ claqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_a);
+}
+
+void
+init_lapack_claqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqge", rblapack_claqge, -1);
+}
diff --git a/ext/claqhb.c b/ext/claqhb.c
new file mode 100644
index 0000000..917327f
--- /dev/null
+++ b/ext/claqhb.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID claqhb_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqhb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ 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 s, equed, ab = NumRu::Lapack.claqhb( uplo, kd, ab, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQHB equilibrates an Hermitian band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (output) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 s, equed, ab = NumRu::Lapack.claqhb( uplo, kd, ab, 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_kd = argv[1];
+ rblapack_ab = 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_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ kd = NUM2INT(rblapack_kd);
+ scond = (real)NUM2DBL(rblapack_scond);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ claqhb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(3, rblapack_s, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_claqhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqhb", rblapack_claqhb, -1);
+}
diff --git a/ext/claqhe.c b/ext/claqhe.c
new file mode 100644
index 0000000..65e569e
--- /dev/null
+++ b/ext/claqhe.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID claqhe_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqhe(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a_out__;
+ complex *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.claqhe( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQHE equilibrates a Hermitian 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* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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.claqhe( 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ amax = (real)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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ claqhe_(&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_claqhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqhe", rblapack_claqhe, -1);
+}
diff --git a/ext/claqhp.c b/ext/claqhp.c
new file mode 100644
index 0000000..e131c03
--- /dev/null
+++ b/ext/claqhp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID claqhp_(char* uplo, integer* n, complex* ap, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqhp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+
+ 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, ap = NumRu::Lapack.claqhp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQHP equilibrates a Hermitian 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* Hermitian 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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, ap = NumRu::Lapack.claqhp( uplo, ap, 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_ap = 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ claqhp_(&uplo, &n, ap, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ap);
+}
+
+void
+init_lapack_claqhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqhp", rblapack_claqhp, -1);
+}
diff --git a/ext/claqp2.c b/ext/claqp2.c
new file mode 100644
index 0000000..67d89f4
--- /dev/null
+++ b/ext/claqp2.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID claqp2_(integer* m, integer* n, integer* offset, complex* a, integer* lda, integer* jpvt, complex* tau, real* vn1, real* vn2, complex* work);
+
+
+static VALUE
+rblapack_claqp2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ real *vn1;
+ VALUE rblapack_vn2;
+ real *vn2;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ real *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ real *vn2_out__;
+ complex *work;
+
+ 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 tau, a, jpvt, vn1, vn2 = NumRu::Lapack.claqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* CLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n* the triangular factor obtained; the elements in block\n* A(OFFSET+1:M,1:N) below the diagonal, together with the\n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.claqp2( m, offset, a, jpvt, vn1, vn2, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
+ MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
+ MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ work = ALLOC_N(complex, (n));
+
+ claqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
+
+ free(work);
+ return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
+}
+
+void
+init_lapack_claqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqp2", rblapack_claqp2, -1);
+}
diff --git a/ext/claqps.c b/ext/claqps.c
new file mode 100644
index 0000000..459f3c9
--- /dev/null
+++ b/ext/claqps.c
@@ -0,0 +1,208 @@
+#include "rb_lapack.h"
+
+extern VOID claqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, complex* a, integer* lda, integer* jpvt, complex* tau, real* vn1, real* vn2, complex* auxv, complex* f, integer* ldf);
+
+
+static VALUE
+rblapack_claqps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ real *vn1;
+ VALUE rblapack_vn2;
+ real *vn2;
+ VALUE rblapack_auxv;
+ complex *auxv;
+ VALUE rblapack_f;
+ complex *f;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ real *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ real *vn2_out__;
+ VALUE rblapack_auxv_out__;
+ complex *auxv_out__;
+ VALUE rblapack_f_out__;
+ complex *f_out__;
+
+ integer lda;
+ integer n;
+ integer nb;
+ 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 kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.claqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* CLAQPS computes a step of QR factorization with column pivoting\n* of a complex M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) COMPLEX array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) COMPLEX array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) COMPLEX array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.claqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ rblapack_auxv = argv[6];
+ rblapack_f = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
+ if (!NA_IsNArray(rblapack_auxv))
+ rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_auxv) != 1)
+ rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
+ nb = NA_SHAPE0(rblapack_auxv);
+ if (NA_TYPE(rblapack_auxv) != NA_SCOMPLEX)
+ rblapack_auxv = na_change_type(rblapack_auxv, NA_SCOMPLEX);
+ auxv = NA_PTR_TYPE(rblapack_auxv, complex*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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) != nb)
+ rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
+ if (NA_TYPE(rblapack_f) != NA_SCOMPLEX)
+ rblapack_f = na_change_type(rblapack_f, NA_SCOMPLEX);
+ f = NA_PTR_TYPE(rblapack_f, complex*);
+ kb = nb;
+ {
+ int shape[1];
+ shape[0] = kb;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
+ MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
+ MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ {
+ int shape[1];
+ shape[0] = nb;
+ rblapack_auxv_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, complex*);
+ MEMCPY(auxv_out__, auxv, complex, NA_TOTAL(rblapack_auxv));
+ rblapack_auxv = rblapack_auxv_out__;
+ auxv = auxv_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = nb;
+ rblapack_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, complex*);
+ MEMCPY(f_out__, f, complex, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+
+ claqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
+
+ rblapack_kb = INT2NUM(kb);
+ return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
+}
+
+void
+init_lapack_claqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqps", rblapack_claqps, -1);
+}
diff --git a/ext/claqr0.c b/ext/claqr0.c
new file mode 100644
index 0000000..9592a2c
--- /dev/null
+++ b/ext/claqr0.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID claqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, integer* iloz, integer* ihiz, complex* z, integer* ldz, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_claqr0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ihi;
+
+ 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 w, work, info, h, z = NumRu::Lapack.claqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to CGEBAL, and then passed to CGEHRD when the\n* matrix output by CGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then CLAQR0 does a workspace query.\n* In this case, CLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, CLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.claqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [: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_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_h = argv[3];
+ rblapack_iloz = argv[4];
+ rblapack_ihiz = argv[5];
+ rblapack_z = 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;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ ihi = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ wantz = (rblapack_wantz == Qtrue);
+ ihiz = NUM2INT(rblapack_ihiz);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = ihi;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ claqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_claqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqr0", rblapack_claqr0, -1);
+}
diff --git a/ext/claqr1.c b/ext/claqr1.c
new file mode 100644
index 0000000..2da0d08
--- /dev/null
+++ b/ext/claqr1.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID claqr1_(integer* n, complex* h, integer* ldh, complex* s1, complex* s2, complex* v);
+
+
+static VALUE
+rblapack_claqr1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_s1;
+ complex s1;
+ VALUE rblapack_s2;
+ complex s2;
+ VALUE rblapack_v;
+ complex *v;
+
+ integer ldh;
+ 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 v = NumRu::Lapack.claqr1( h, s1, s2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - s1*I)*(H - s2*I)\n*\n* scaling to avoid overflows and most underflows.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) COMPLEX array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* S1 (input) COMPLEX\n* S2 S1 and S2 are the shifts defining K in (*) above.\n*\n* V (output) COMPLEX array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n v = NumRu::Lapack.claqr1( h, s1, s2, [: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_h = argv[0];
+ rblapack_s1 = argv[1];
+ rblapack_s2 = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (1th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ s2.r = (real)NUM2DBL(rb_funcall(rblapack_s2, rb_intern("real"), 0));
+ s2.i = (real)NUM2DBL(rb_funcall(rblapack_s2, rb_intern("imag"), 0));
+ s1.r = (real)NUM2DBL(rb_funcall(rblapack_s1, rb_intern("real"), 0));
+ s1.i = (real)NUM2DBL(rb_funcall(rblapack_s1, rb_intern("imag"), 0));
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_v = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+
+ claqr1_(&n, h, &ldh, &s1, &s2, v);
+
+ return rblapack_v;
+}
+
+void
+init_lapack_claqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqr1", rblapack_claqr1, -1);
+}
diff --git a/ext/claqr2.c b/ext/claqr2.c
new file mode 100644
index 0000000..bb78f40
--- /dev/null
+++ b/ext/claqr2.c
@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID claqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, complex* h, integer* ldh, integer* iloz, integer* ihiz, complex* z, integer* ldz, integer* ns, integer* nd, complex* sh, complex* v, integer* ldv, integer* nh, complex* t, integer* ldt, integer* nv, complex* wv, integer* ldwv, complex* work, integer* lwork);
+
+
+static VALUE
+rblapack_claqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sh;
+ complex *sh;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+ complex *v;
+ complex *t;
+ complex *wv;
+ complex *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldwv;
+ integer ldt;
+
+ 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 ns, nd, sh, h, z = NumRu::Lapack.claqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to CLAQR3 except that it avoids\n* recursion by calling CLAHQR instead of CLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; CLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.claqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ sh = NA_PTR_TYPE(rblapack_sh, complex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
+ wv = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
+ work = ALLOC_N(complex, (MAX(1,lwork)));
+
+ claqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_claqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqr2", rblapack_claqr2, -1);
+}
diff --git a/ext/claqr3.c b/ext/claqr3.c
new file mode 100644
index 0000000..d08172c
--- /dev/null
+++ b/ext/claqr3.c
@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID claqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, complex* h, integer* ldh, integer* iloz, integer* ihiz, complex* z, integer* ldz, integer* ns, integer* nd, complex* sh, complex* v, integer* ldv, integer* nh, complex* t, integer* ldt, integer* nv, complex* wv, integer* ldwv, complex* work, integer* lwork);
+
+
+static VALUE
+rblapack_claqr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sh;
+ complex *sh;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+ complex *v;
+ complex *t;
+ complex *wv;
+ complex *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldwv;
+ integer ldt;
+
+ 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 ns, nd, sh, h, z = NumRu::Lapack.claqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; CLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.claqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ sh = NA_PTR_TYPE(rblapack_sh, complex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
+ wv = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
+ work = ALLOC_N(complex, (MAX(1,lwork)));
+
+ claqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_claqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqr3", rblapack_claqr3, -1);
+}
diff --git a/ext/claqr4.c b/ext/claqr4.c
new file mode 100644
index 0000000..9251422
--- /dev/null
+++ b/ext/claqr4.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID claqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, integer* iloz, integer* ihiz, complex* z, integer* ldz, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_claqr4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ihi;
+
+ 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 w, work, info, h, z = NumRu::Lapack.claqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to CGEBAL, and then passed to CGEHRD when the\n* matrix output by CGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then CLAQR4 does a workspace query.\n* In this case, CLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, CLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.claqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [: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_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_h = argv[3];
+ rblapack_iloz = argv[4];
+ rblapack_ihiz = argv[5];
+ rblapack_z = 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;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ ihi = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ wantz = (rblapack_wantz == Qtrue);
+ ihiz = NUM2INT(rblapack_ihiz);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = ihi;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ claqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_claqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqr4", rblapack_claqr4, -1);
+}
diff --git a/ext/claqr5.c b/ext/claqr5.c
new file mode 100644
index 0000000..f1c4e54
--- /dev/null
+++ b/ext/claqr5.c
@@ -0,0 +1,179 @@
+#include "rb_lapack.h"
+
+extern VOID claqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, complex* s, complex* h, integer* ldh, integer* iloz, integer* ihiz, complex* z, integer* ldz, complex* v, integer* ldv, complex* u, integer* ldu, integer* nv, complex* wv, integer* ldwv, integer* nh, complex* wh, integer* ldwh);
+
+
+static VALUE
+rblapack_claqr5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_kacc22;
+ integer kacc22;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_s;
+ complex *s;
+ VALUE rblapack_h;
+ complex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_s_out__;
+ complex *s_out__;
+ VALUE rblapack_h_out__;
+ complex *h_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+ complex *v;
+ complex *u;
+ complex *wv;
+ complex *wh;
+
+ integer nshfts;
+ integer ldh;
+ integer n;
+ integer ldv;
+ integer ldu;
+ integer ldwv;
+ integer ldwh;
+
+ 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 s, h, z = NumRu::Lapack.claqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by CLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the unitary Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: CLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: CLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: CLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* S (input/output) COMPLEX array of size (NSHFTS)\n* S contains the shifts of origin that define the multi-\n* shift QR sweep. On output S may be reordered.\n*\n* H (input/output) COMPLEX array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) COMPLEX array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep unitary\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) COMPLEX array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) COMPLEX array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) COMPLEX array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) COMPLEX array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, h, z = NumRu::Lapack.claqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_kacc22 = argv[2];
+ rblapack_ktop = argv[3];
+ rblapack_kbot = argv[4];
+ rblapack_s = argv[5];
+ rblapack_h = argv[6];
+ rblapack_iloz = argv[7];
+ rblapack_ihiz = argv[8];
+ rblapack_z = argv[9];
+ rblapack_ldz = argv[10];
+ rblapack_nv = argv[11];
+ rblapack_nh = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ kacc22 = NUM2INT(rblapack_kacc22);
+ kbot = NUM2INT(rblapack_kbot);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (7th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (7th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, complex*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = NUM2INT(rblapack_ldz);
+ nh = NUM2INT(rblapack_nh);
+ ldv = 3;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ nshfts = NA_SHAPE0(rblapack_s);
+ if (NA_TYPE(rblapack_s) != NA_SCOMPLEX)
+ rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
+ s = NA_PTR_TYPE(rblapack_s, complex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (10th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ ldwh = 3*nshfts-3;
+ ldu = 3*nshfts-3;
+ ktop = NUM2INT(rblapack_ktop);
+ nv = NUM2INT(rblapack_nv);
+ iloz = NUM2INT(rblapack_iloz);
+ ldwv = nv;
+ {
+ int shape[1];
+ shape[0] = nshfts;
+ rblapack_s_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, complex*);
+ MEMCPY(s_out__, s, complex, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
+ MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? ihiz : 0;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(complex, (ldv)*(nshfts/2));
+ u = ALLOC_N(complex, (ldu)*(3*nshfts-3));
+ wv = ALLOC_N(complex, (ldwv)*(3*nshfts-3));
+ wh = ALLOC_N(complex, (ldwh)*(MAX(1,nh)));
+
+ claqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, s, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
+
+ free(v);
+ free(u);
+ free(wv);
+ free(wh);
+ return rb_ary_new3(3, rblapack_s, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_claqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqr5", rblapack_claqr5, -1);
+}
diff --git a/ext/claqsb.c b/ext/claqsb.c
new file mode 100644
index 0000000..edd05f9
--- /dev/null
+++ b/ext/claqsb.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID claqsb_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqsb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.claqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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, ab = NumRu::Lapack.claqsb( uplo, kd, ab, s, scond, amax, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_s = argv[3];
+ rblapack_scond = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ kd = NUM2INT(rblapack_kd);
+ amax = (real)NUM2DBL(rblapack_amax);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ claqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_claqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqsb", rblapack_claqsb, -1);
+}
diff --git a/ext/claqsp.c b/ext/claqsp.c
new file mode 100644
index 0000000..d37d61a
--- /dev/null
+++ b/ext/claqsp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID claqsp_(char* uplo, integer* n, complex* ap, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqsp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+
+ 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, ap = NumRu::Lapack.claqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQSP 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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, ap = NumRu::Lapack.claqsp( uplo, ap, 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_ap = 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ claqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ap);
+}
+
+void
+init_lapack_claqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqsp", rblapack_claqsp, -1);
+}
diff --git a/ext/claqsy.c b/ext/claqsy.c
new file mode 100644
index 0000000..117944d
--- /dev/null
+++ b/ext/claqsy.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID claqsy_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_claqsy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a_out__;
+ complex *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.claqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* CLAQSY 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 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) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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.claqsy( 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ amax = (real)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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ claqsy_(&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_claqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claqsy", rblapack_claqsy, -1);
+}
diff --git a/ext/clar1v.c b/ext/clar1v.c
new file mode 100644
index 0000000..6e0ddc4
--- /dev/null
+++ b/ext/clar1v.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID clar1v_(integer* n, integer* b1, integer* bn, real* lambda, real* d, real* l, real* ld, real* lld, real* pivmin, real* gaptol, complex* z, logical* wantnc, integer* negcnt, real* ztz, real* mingma, integer* r, integer* isuppz, real* nrminv, real* resid, real* rqcorr, real* work);
+
+
+static VALUE
+rblapack_clar1v(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_b1;
+ integer b1;
+ VALUE rblapack_bn;
+ integer bn;
+ VALUE rblapack_lambda;
+ real lambda;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_l;
+ real *l;
+ VALUE rblapack_ld;
+ real *ld;
+ VALUE rblapack_lld;
+ real *lld;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_gaptol;
+ real gaptol;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_wantnc;
+ logical wantnc;
+ VALUE rblapack_r;
+ integer r;
+ VALUE rblapack_negcnt;
+ integer negcnt;
+ VALUE rblapack_ztz;
+ real ztz;
+ VALUE rblapack_mingma;
+ real mingma;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_nrminv;
+ real nrminv;
+ VALUE rblapack_resid;
+ real resid;
+ VALUE rblapack_rqcorr;
+ real rqcorr;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+ real *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.clar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAR1V( 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* CLAR1V 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) REAL \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) REAL 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) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D.\n*\n* LD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*D(i).\n*\n* LLD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*L(i)*D(i).\n*\n* PIVMIN (input) REAL \n* The minimum pivot in the Sturm sequence.\n*\n* GAPTOL (input) REAL \n* Tolerance that indicates when eigenvector entries are negligible\n* w.r.t. their contribution to the residual.\n*\n* Z (input/output) COMPLEX 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) REAL \n* The square of the 2-norm of Z.\n*\n* MINGMA (output) REAL \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) REAL \n* NRMINV = 1/SQRT( ZTZ )\n*\n* RESID (output) REAL \n* The residual of the FP vector.\n* RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n* RQCORR (output) REAL \n* The Rayleigh Quotient correction to LAMBDA.\n* RQCORR = MINGMA*TMP\n*\n* WORK (workspace) REAL 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.clar1v( 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 = (real)NUM2DBL(rblapack_lambda);
+ pivmin = (real)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_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ r = NUM2INT(rblapack_r);
+ bn = NUM2INT(rblapack_bn);
+ gaptol = (real)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_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ 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_SFLOAT)
+ rblapack_ld = na_change_type(rblapack_ld, NA_SFLOAT);
+ ld = NA_PTR_TYPE(rblapack_ld, real*);
+ 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_SFLOAT)
+ rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
+ l = NA_PTR_TYPE(rblapack_l, real*);
+ 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_SFLOAT)
+ rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
+ lld = NA_PTR_TYPE(rblapack_lld, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(real, (4*n));
+
+ clar1v_(&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_clar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clar1v", rblapack_clar1v, -1);
+}
diff --git a/ext/clar2v.c b/ext/clar2v.c
new file mode 100644
index 0000000..8c8d961
--- /dev/null
+++ b/ext/clar2v.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID clar2v_(integer* n, complex* x, complex* y, complex* z, integer* incx, real* c, complex* s, integer* incc);
+
+
+static VALUE
+rblapack_clar2v(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ complex *s;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+ VALUE rblapack_z_out__;
+ complex *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.clar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n* Purpose\n* =======\n*\n* CLAR2V 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 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 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 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) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) COMPLEX 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 REAL CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n $ ZIR\n COMPLEX SI, T2, T3, T4, ZI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC AIMAG, CMPLX, CONJG, REAL\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.clar2v( 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ 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_SCOMPLEX)
+ rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
+ s = NA_PTR_TYPE(rblapack_s, complex*);
+ 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_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ 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_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ clar2v_(&n, x, y, z, &incx, c, s, &incc);
+
+ return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
+}
+
+void
+init_lapack_clar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clar2v", rblapack_clar2v, -1);
+}
diff --git a/ext/clarcm.c b/ext/clarcm.c
new file mode 100644
index 0000000..14d58f7
--- /dev/null
+++ b/ext/clarcm.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID clarcm_(integer* m, integer* n, real* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, real* rwork);
+
+
+static VALUE
+rblapack_clarcm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_c;
+ complex *c;
+ real *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.clarcm( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n* Purpose\n* =======\n*\n* CLARCM 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) REAL 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) REAL 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 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) REAL 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.clarcm( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ rwork = ALLOC_N(real, (2*m*n));
+
+ clarcm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
+
+ free(rwork);
+ return rblapack_c;
+}
+
+void
+init_lapack_clarcm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarcm", rblapack_clarcm, -1);
+}
diff --git a/ext/clarf.c b/ext/clarf.c
new file mode 100644
index 0000000..a972efe
--- /dev/null
+++ b/ext/clarf.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID clarf_(char* side, integer* m, integer* n, complex* v, integer* incv, complex* tau, complex* c, integer* ldc, complex* work);
+
+
+static VALUE
+rblapack_clarf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ complex tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *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 c = NumRu::Lapack.clarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* CLARF applies a complex elementary reflector H to a complex M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarf( side, m, v, incv, tau, c, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_v = argv[2];
+ rblapack_incv = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ m = NUM2INT(rblapack_m);
+ tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (3th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ clarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_clarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarf", rblapack_clarf, -1);
+}
diff --git a/ext/clarfb.c b/ext/clarfb.c
new file mode 100644
index 0000000..89a3e9b
--- /dev/null
+++ b/ext/clarfb.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID clarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, complex* v, integer* ldv, complex* t, integer* ldt, complex* c, integer* ldc, complex* work, integer* ldwork);
+
+
+static VALUE
+rblapack_clarfb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.clarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* CLARFB applies a complex block reflector H or its transpose H' to a\n* complex M-by-N matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) COMPLEX array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarfb( side, trans, direct, storev, m, v, t, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_v = argv[5];
+ rblapack_t = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (ldwork)*(k));
+
+ clarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_clarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarfb", rblapack_clarfb, -1);
+}
diff --git a/ext/clarfg.c b/ext/clarfg.c
new file mode 100644
index 0000000..5866669
--- /dev/null
+++ b/ext/clarfg.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID clarfg_(integer* n, complex* alpha, complex* x, integer* incx, complex* tau);
+
+
+static VALUE
+rblapack_clarfg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ complex tau;
+ VALUE rblapack_x_out__;
+ complex *x_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 tau, alpha, x = NumRu::Lapack.clarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* CLARFG generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, with beta real, and x is an\n* (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.clarfg( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(incx);
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ clarfg_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
+ rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_clarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarfg", rblapack_clarfg, -1);
+}
diff --git a/ext/clarfgp.c b/ext/clarfgp.c
new file mode 100644
index 0000000..4671815
--- /dev/null
+++ b/ext/clarfgp.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID clarfgp_(integer* n, complex* alpha, complex* x, integer* incx, complex* tau);
+
+
+static VALUE
+rblapack_clarfgp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ complex tau;
+ VALUE rblapack_x_out__;
+ complex *x_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 tau, alpha, x = NumRu::Lapack.clarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* CLARFGP generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is real and non-negative, and\n* x is an (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.clarfgp( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(incx);
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ clarfgp_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
+ rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_clarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarfgp", rblapack_clarfgp, -1);
+}
diff --git a/ext/clarft.c b/ext/clarft.c
new file mode 100644
index 0000000..cc00bc4
--- /dev/null
+++ b/ext/clarft.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID clarft_(char* direct, char* storev, integer* n, integer* k, complex* v, integer* ldv, complex* tau, complex* t, integer* ldt);
+
+
+static VALUE
+rblapack_clarft(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_v_out__;
+ complex *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.clarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* CLARFT forms the triangular factor T of a complex block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.clarft( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
+ MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ clarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_clarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarft", rblapack_clarft, -1);
+}
diff --git a/ext/clarfx.c b/ext/clarfx.c
new file mode 100644
index 0000000..e9144cf
--- /dev/null
+++ b/ext/clarfx.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID clarfx_(char* side, integer* m, integer* n, complex* v, complex* tau, complex* c, integer* ldc, complex* work);
+
+
+static VALUE
+rblapack_clarfx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_tau;
+ complex tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer m;
+ 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 c = NumRu::Lapack.clarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* CLARFX applies a complex elementary reflector H to a complex m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarfx( side, v, tau, c, [: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_side = argv[0];
+ rblapack_v = argv[1];
+ rblapack_tau = argv[2];
+ rblapack_c = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (2th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ clarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_clarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarfx", rblapack_clarfx, -1);
+}
diff --git a/ext/clargv.c b/ext/clargv.c
new file mode 100644
index 0000000..6f5c12f
--- /dev/null
+++ b/ext/clargv.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID clargv_(integer* n, complex* x, integer* incx, complex* y, integer* incy, real* c, integer* incc);
+
+
+static VALUE
+rblapack_clargv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_y_out__;
+ complex *y_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 c, x, y = NumRu::Lapack.clargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* CLARGV generates a vector of complex plane rotations with real\n* cosines, determined by elements of the complex vectors x and y.\n* For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( r(i) )\n* ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 )\n*\n* where c(i)**2 + ABS(s(i))**2 = 1\n*\n* The following conventions are used (these are the same as in CLARTG,\n* but differ from the BLAS1 routine CROTG):\n* If y(i)=0, then c(i)=1 and s(i)=0.\n* If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* Further Details\n* ======= =======\n*\n* 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.clargv( n, x, incx, y, incy, incc, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ rblapack_incc = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ incc = NUM2INT(rblapack_incc);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incc;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ clargv_(&n, x, &incx, y, &incy, c, &incc);
+
+ return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_clargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clargv", rblapack_clargv, -1);
+}
diff --git a/ext/clarnv.c b/ext/clarnv.c
new file mode 100644
index 0000000..a169d7b
--- /dev/null
+++ b/ext/clarnv.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID clarnv_(integer* idist, integer* iseed, integer* n, complex* x);
+
+
+static VALUE
+rblapack_clarnv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_idist;
+ integer idist;
+ VALUE rblapack_iseed;
+ integer *iseed;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_iseed_out__;
+ integer *iseed_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, iseed = NumRu::Lapack.clarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* CLARNV returns a vector of n random complex numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: real and imaginary parts each uniform (0,1)\n* = 2: real and imaginary parts each uniform (-1,1)\n* = 3: real and imaginary parts each normal (0,1)\n* = 4: uniformly distributed on the disc abs(z) < 1\n* = 5: uniformly distributed on the circle abs(z) = 1\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) COMPLEX array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine SLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.clarnv( idist, iseed, n, [: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_idist = argv[0];
+ rblapack_iseed = argv[1];
+ rblapack_n = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ idist = NUM2INT(rblapack_idist);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_iseed))
+ rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
+ if (NA_RANK(rblapack_iseed) != 1)
+ rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iseed) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
+ if (NA_TYPE(rblapack_iseed) != NA_LINT)
+ rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
+ iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = 4;
+ rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
+ MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
+ rblapack_iseed = rblapack_iseed_out__;
+ iseed = iseed_out__;
+
+ clarnv_(&idist, iseed, &n, x);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_iseed);
+}
+
+void
+init_lapack_clarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarnv", rblapack_clarnv, -1);
+}
diff --git a/ext/clarrv.c b/ext/clarrv.c
new file mode 100644
index 0000000..27a999e
--- /dev/null
+++ b/ext/clarrv.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID clarrv_(integer* n, real* vl, real* vu, real* d, real* l, real* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, real* minrgp, real* rtol1, real* rtol2, real* w, real* werr, real* wgap, integer* iblock, integer* indexw, real* gers, complex* z, integer* ldz, integer* isuppz, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_clarrv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_l;
+ real *l;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_dol;
+ integer dol;
+ VALUE rblapack_dou;
+ integer dou;
+ VALUE rblapack_minrgp;
+ real minrgp;
+ VALUE rblapack_rtol1;
+ real rtol1;
+ VALUE rblapack_rtol2;
+ real rtol2;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_werr;
+ real *werr;
+ VALUE rblapack_wgap;
+ real *wgap;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ VALUE rblapack_gers;
+ real *gers;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_l_out__;
+ real *l_out__;
+ VALUE rblapack_w_out__;
+ real *w_out__;
+ VALUE rblapack_werr_out__;
+ real *werr_out__;
+ VALUE rblapack_wgap_out__;
+ real *wgap_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+
+ 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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.clarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by SLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) REAL \n* VU (input) REAL \n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by SLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (in) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) REAL \n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) REAL array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from SLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) REAL array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) REAL array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) REAL array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in CLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in SLARRB when refining a child's eigenvalues.\n* =-2: Problem in SLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in SLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.clarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 18 && argc != 18)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
+ rblapack_vl = argv[0];
+ rblapack_vu = argv[1];
+ rblapack_d = argv[2];
+ rblapack_l = argv[3];
+ rblapack_pivmin = argv[4];
+ rblapack_isplit = argv[5];
+ rblapack_m = argv[6];
+ rblapack_dol = argv[7];
+ rblapack_dou = argv[8];
+ rblapack_minrgp = argv[9];
+ rblapack_rtol1 = argv[10];
+ rblapack_rtol2 = argv[11];
+ rblapack_w = argv[12];
+ rblapack_werr = argv[13];
+ rblapack_wgap = argv[14];
+ rblapack_iblock = argv[15];
+ rblapack_indexw = argv[16];
+ rblapack_gers = argv[17];
+ if (argc == 18) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vl = (real)NUM2DBL(rblapack_vl);
+ 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*);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ m = NUM2INT(rblapack_m);
+ dou = NUM2INT(rblapack_dou);
+ rtol1 = (real)NUM2DBL(rblapack_rtol1);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (13th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, real*);
+ if (!NA_IsNArray(rblapack_indexw))
+ rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
+ if (NA_RANK(rblapack_indexw) != 1)
+ rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indexw) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indexw) != NA_LINT)
+ rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ minrgp = (real)NUM2DBL(rblapack_minrgp);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, real*);
+ if (!NA_IsNArray(rblapack_l))
+ rb_raise(rb_eArgError, "l (4th argument) must be NArray");
+ if (NA_RANK(rblapack_l) != 1)
+ rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_l) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_l) != NA_SFLOAT)
+ rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
+ l = NA_PTR_TYPE(rblapack_l, real*);
+ rtol2 = (real)NUM2DBL(rblapack_rtol2);
+ dol = NUM2INT(rblapack_dol);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ ldz = n;
+ if (!NA_IsNArray(rblapack_gers))
+ rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
+ if (NA_RANK(rblapack_gers) != 1)
+ rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_gers) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
+ if (NA_TYPE(rblapack_gers) != NA_SFLOAT)
+ rblapack_gers = na_change_type(rblapack_gers, NA_SFLOAT);
+ gers = NA_PTR_TYPE(rblapack_gers, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ 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_l_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ l_out__ = NA_PTR_TYPE(rblapack_l_out__, real*);
+ MEMCPY(l_out__, l, real, NA_TOTAL(rblapack_l));
+ rblapack_l = rblapack_l_out__;
+ l = l_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
+ MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
+ MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
+ MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ work = ALLOC_N(real, (12*n));
+ iwork = ALLOC_N(integer, (7*n));
+
+ clarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
+}
+
+void
+init_lapack_clarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarrv", rblapack_clarrv, -1);
+}
diff --git a/ext/clarscl2.c b/ext/clarscl2.c
new file mode 100644
index 0000000..ba8327c
--- /dev/null
+++ b/ext/clarscl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID clarscl2_(integer* m, integer* n, real* d, complex* x, integer* ldx);
+
+
+static VALUE
+rblapack_clarscl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.clarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* CLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the REAL diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.clarscl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = 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_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ clarscl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_clarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarscl2", rblapack_clarscl2, -1);
+}
diff --git a/ext/clartg.c b/ext/clartg.c
new file mode 100644
index 0000000..e25b6fc
--- /dev/null
+++ b/ext/clartg.c
@@ -0,0 +1,63 @@
+#include "rb_lapack.h"
+
+extern VOID clartg_(complex* f, complex* g, real* cs, complex* sn, complex* r);
+
+
+static VALUE
+rblapack_clartg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ complex f;
+ VALUE rblapack_g;
+ complex g;
+ VALUE rblapack_cs;
+ real cs;
+ VALUE rblapack_sn;
+ complex sn;
+ VALUE rblapack_r;
+ complex r;
+
+
+ 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 cs, sn, r = NumRu::Lapack.clartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* CLARTG generates a plane rotation so that\n*\n* [ CS SN ] [ F ] [ R ]\n* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a faster version of the BLAS1 routine CROTG, except for\n* the following differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0, then CS=0 and SN is chosen so that R is real.\n*\n\n* Arguments\n* =========\n*\n* F (input) COMPLEX\n* The first component of vector to be rotated.\n*\n* G (input) COMPLEX\n* The second component of vector to be rotated.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) COMPLEX\n* The sine of the rotation.\n*\n* R (output) COMPLEX\n* The nonzero component of the rotated vector.\n*\n\n* Further Details\n* ======= =======\n*\n* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.clartg( f, g, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f.r = (real)NUM2DBL(rb_funcall(rblapack_f, rb_intern("real"), 0));
+ f.i = (real)NUM2DBL(rb_funcall(rblapack_f, rb_intern("imag"), 0));
+ g.r = (real)NUM2DBL(rb_funcall(rblapack_g, rb_intern("real"), 0));
+ g.i = (real)NUM2DBL(rb_funcall(rblapack_g, rb_intern("imag"), 0));
+
+ clartg_(&f, &g, &cs, &sn, &r);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn.r)), rb_float_new((double)(sn.i)));
+ rblapack_r = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(r.r)), rb_float_new((double)(r.i)));
+ return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
+}
+
+void
+init_lapack_clartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clartg", rblapack_clartg, -1);
+}
diff --git a/ext/clartv.c b/ext/clartv.c
new file mode 100644
index 0000000..c564e70
--- /dev/null
+++ b/ext/clartv.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID clartv_(integer* n, complex* x, integer* incx, complex* y, integer* incy, real* c, complex* s, integer* incc);
+
+
+static VALUE
+rblapack_clartv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ complex *s;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_y_out__;
+ complex *y_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 = NumRu::Lapack.clartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* CLARTV applies a vector of complex plane rotations with real cosines\n* to elements of the complex vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(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 array, dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (input) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) COMPLEX 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, IY\n COMPLEX XI, YI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.clartv( n, x, incx, y, incy, 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_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = 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);
+ incy = NUM2INT(rblapack_incy);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ 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_SCOMPLEX)
+ rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
+ s = NA_PTR_TYPE(rblapack_s, complex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ clartv_(&n, x, &incx, y, &incy, c, s, &incc);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_clartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clartv", rblapack_clartv, -1);
+}
diff --git a/ext/clarz.c b/ext/clarz.c
new file mode 100644
index 0000000..20093d1
--- /dev/null
+++ b/ext/clarz.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID clarz_(char* side, integer* m, integer* n, integer* l, complex* v, integer* incv, complex* tau, complex* c, integer* ldc, complex* work);
+
+
+static VALUE
+rblapack_clarz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ complex tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *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 c = NumRu::Lapack.clarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* CLARZ applies a complex elementary reflector H to a complex\n* M-by-N matrix C, from either the left or the right. H is represented\n* in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n* H is a product of k elementary reflectors as returned by CTZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* CTZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarz( side, m, l, v, incv, 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_m = argv[1];
+ rblapack_l = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ incv = NUM2INT(rblapack_incv);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ m = NUM2INT(rblapack_m);
+ tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ clarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_clarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarz", rblapack_clarz, -1);
+}
diff --git a/ext/clarzb.c b/ext/clarzb.c
new file mode 100644
index 0000000..a625474
--- /dev/null
+++ b/ext/clarzb.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID clarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, complex* v, integer* ldv, complex* t, integer* ldt, complex* c, integer* ldc, complex* work, integer* ldwork);
+
+
+static VALUE
+rblapack_clarzb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer ldv;
+ integer nv;
+ integer ldt;
+ integer k;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.clarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* CLARZB applies a complex block reflector H or its transpose H**H\n* to a complex distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.clarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_l = argv[5];
+ rblapack_v = argv[6];
+ rblapack_t = argv[7];
+ rblapack_c = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ nv = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ l = NUM2INT(rblapack_l);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (8th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (ldwork)*(k));
+
+ clarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_clarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarzb", rblapack_clarzb, -1);
+}
diff --git a/ext/clarzt.c b/ext/clarzt.c
new file mode 100644
index 0000000..473d39f
--- /dev/null
+++ b/ext/clarzt.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID clarzt_(char* direct, char* storev, integer* n, integer* k, complex* v, integer* ldv, complex* tau, complex* t, integer* ldt);
+
+
+static VALUE
+rblapack_clarzt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_v_out__;
+ complex *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.clarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* CLARZT forms the triangular factor T of a complex block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.clarzt( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
+ MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ clarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_clarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clarzt", rblapack_clarzt, -1);
+}
diff --git a/ext/clascl.c b/ext/clascl.c
new file mode 100644
index 0000000..45dbd3b
--- /dev/null
+++ b/ext/clascl.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID clascl_(char* type, integer* kl, integer* ku, real* cfrom, real* cto, integer* m, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_clascl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_type;
+ char type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_cfrom;
+ real cfrom;
+ VALUE rblapack_cto;
+ real cto;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.clascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLASCL multiplies the M by N complex matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See CGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) REAL\n* CTO (input) REAL\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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, a = NumRu::Lapack.clascl( type, kl, ku, cfrom, cto, m, a, [: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_type = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_cfrom = argv[3];
+ rblapack_cto = argv[4];
+ rblapack_m = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ type = StringValueCStr(rblapack_type)[0];
+ ku = NUM2INT(rblapack_ku);
+ cto = (real)NUM2DBL(rblapack_cto);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ kl = NUM2INT(rblapack_kl);
+ m = NUM2INT(rblapack_m);
+ cfrom = (real)NUM2DBL(rblapack_cfrom);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_clascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clascl", rblapack_clascl, -1);
+}
diff --git a/ext/clascl2.c b/ext/clascl2.c
new file mode 100644
index 0000000..d144f65
--- /dev/null
+++ b/ext/clascl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID clascl2_(integer* m, integer* n, real* d, complex* x, integer* ldx);
+
+
+static VALUE
+rblapack_clascl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.clascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* CLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the diagonal REAL matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.clascl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = 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_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ clascl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_clascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clascl2", rblapack_clascl2, -1);
+}
diff --git a/ext/claset.c b/ext/claset.c
new file mode 100644
index 0000000..cb6234f
--- /dev/null
+++ b/ext/claset.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID claset_(char* uplo, integer* m, integer* n, complex* alpha, complex* beta, complex* a, integer* lda);
+
+
+static VALUE
+rblapack_claset(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_beta;
+ complex beta;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_a_out__;
+ complex *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 a = NumRu::Lapack.claset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* CLASET initializes a 2-D array A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set. The lower triangle\n* is unchanged.\n* = 'L': Lower triangular part is set. The upper triangle\n* is unchanged.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of A.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of A.\n*\n* ALPHA (input) COMPLEX\n* All the offdiagonal array elements are set to ALPHA.\n*\n* BETA (input) COMPLEX\n* All the diagonal array elements are set to BETA.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n* A(i,i) = BETA , 1 <= i <= min(m,n)\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.claset( uplo, m, alpha, beta, a, [: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_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_beta = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = NUM2INT(rblapack_m);
+ beta.r = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
+ beta.i = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ claset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_claset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claset", rblapack_claset, -1);
+}
diff --git a/ext/clasr.c b/ext/clasr.c
new file mode 100644
index 0000000..7b5136f
--- /dev/null
+++ b/ext/clasr.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID clasr_(char* side, char* pivot, char* direct, integer* m, integer* n, real* c, real* s, complex* a, integer* lda);
+
+
+static VALUE
+rblapack_clasr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_pivot;
+ char pivot;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_a_out__;
+ complex *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 a = NumRu::Lapack.clasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* CLASR applies a sequence of real plane rotations to a complex matrix\n* A, from either the left or the right.\n*\n* When SIDE = 'L', the transformation takes the form\n*\n* A := P*A\n*\n* and when SIDE = 'R', the transformation takes the form\n*\n* A := A*P**T\n*\n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.clasr( side, pivot, direct, m, c, s, a, [: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_pivot = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_m = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ pivot = StringValueCStr(rblapack_pivot)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_clasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clasr", rblapack_clasr, -1);
+}
diff --git a/ext/classq.c b/ext/classq.c
new file mode 100644
index 0000000..033616d
--- /dev/null
+++ b/ext/classq.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern VOID classq_(integer* n, complex* x, integer* incx, real* scale, real* sumsq);
+
+
+static VALUE
+rblapack_classq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_sumsq;
+ real sumsq;
+
+ 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 scale, sumsq = NumRu::Lapack.classq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* CLASSQ returns the values scl and ssq such that\n*\n* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n* assumed to be at least unity and the value of ssq will then satisfy\n*\n* 1.0 .le. ssq .le. ( sumsq + 2*n ).\n*\n* scale is assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n* i\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n* SCALE and SUMSQ are overwritten by scl and ssq respectively.\n*\n* The routine makes only one pass through the vector X.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) COMPLEX array, dimension (N)\n* The vector x as described above.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) REAL\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with the value scl .\n*\n* SUMSQ (input/output) REAL\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with the value ssq .\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.classq( x, incx, scale, sumsq, [: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_x = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_scale = argv[2];
+ rblapack_sumsq = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ scale = (real)NUM2DBL(rblapack_scale);
+ incx = NUM2INT(rblapack_incx);
+ sumsq = (real)NUM2DBL(rblapack_sumsq);
+
+ classq_(&n, x, &incx, &scale, &sumsq);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_sumsq = rb_float_new((double)sumsq);
+ return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
+}
+
+void
+init_lapack_classq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "classq", rblapack_classq, -1);
+}
diff --git a/ext/claswp.c b/ext/claswp.c
new file mode 100644
index 0000000..f4ea4b7
--- /dev/null
+++ b/ext/claswp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID claswp_(integer* n, complex* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);
+
+
+static VALUE
+rblapack_claswp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_k1;
+ integer k1;
+ VALUE rblapack_k2;
+ integer k2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_a_out__;
+ complex *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 a = NumRu::Lapack.claswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* CLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n COMPLEX TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.claswp( a, k1, k2, ipiv, incx, [: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_a = argv[0];
+ rblapack_k1 = argv[1];
+ rblapack_k2 = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_incx = argv[4];
+ if (argc == 5) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ k2 = NUM2INT(rblapack_k2);
+ incx = NUM2INT(rblapack_incx);
+ k1 = NUM2INT(rblapack_k1);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ claswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_claswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "claswp", rblapack_claswp, -1);
+}
diff --git a/ext/clasyf.c b/ext/clasyf.c
new file mode 100644
index 0000000..f1cfebd
--- /dev/null
+++ b/ext/clasyf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID clasyf_(char* uplo, integer* n, integer* nb, integer* kb, complex* a, integer* lda, integer* ipiv, complex* w, integer* ldw, integer* info);
+
+
+static VALUE
+rblapack_clasyf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *w;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 kb, ipiv, info, a = NumRu::Lapack.clasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* CLASYF computes a partial factorization of a complex symmetric matrix\n* A using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the transpose of U.\n*\n* CLASYF is an auxiliary routine called by CSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) COMPLEX 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.clasyf( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ w = ALLOC_N(complex, (ldw)*(MAX(1,nb)));
+
+ clasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
+
+ free(w);
+ rblapack_kb = INT2NUM(kb);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_clasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clasyf", rblapack_clasyf, -1);
+}
diff --git a/ext/clatbs.c b/ext/clatbs.c
new file mode 100644
index 0000000..293deee
--- /dev/null
+++ b/ext/clatbs.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID clatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, complex* ab, integer* ldab, complex* x, real* scale, real* cnorm, integer* info);
+
+
+static VALUE
+rblapack_clatbs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_cnorm;
+ real *cnorm;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_cnorm_out__;
+ real *cnorm_out__;
+
+ integer ldab;
+ 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 scale, info, x, cnorm = NumRu::Lapack.clatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* CLATBS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, CTBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.clatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [: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_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_kd = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_x = argv[6];
+ rblapack_cnorm = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
+ MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ clatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_clatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clatbs", rblapack_clatbs, -1);
+}
diff --git a/ext/clatdf.c b/ext/clatdf.c
new file mode 100644
index 0000000..caeac23
--- /dev/null
+++ b/ext/clatdf.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID clatdf_(integer* ijob, integer* n, complex* z, integer* ldz, complex* rhs, real* rdsum, real* rdscal, integer* ipiv, integer* jpiv);
+
+
+static VALUE
+rblapack_clatdf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_rhs;
+ complex *rhs;
+ VALUE rblapack_rdsum;
+ real rdsum;
+ VALUE rblapack_rdscal;
+ real rdscal;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_rhs_out__;
+ complex *rhs_out__;
+
+ integer ldz;
+ 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 rhs, rdsum, rdscal = NumRu::Lapack.clatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* CLATDF computes the contribution to the reciprocal Dif-estimate\n* by solving for x in Z * x = b, where b is chosen such that the norm\n* of x is as large as possible. It is assumed that LU decomposition\n* of Z has been computed by CGETC2. On entry RHS = f holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by CGETC2 has the form\n* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n* triangular with unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using CGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value of\n* 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where\n* all entries of the r.h.s. b is choosen as either +1 or\n* -1. Default.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) REAL array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by CGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) REAL array, dimension (N).\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries according to the value of IJOB (see above).\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by CTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when CTGSY2 is called by CTGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when CTGSY2 is called by\n* CTGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report UMINF-95.05, Department of\n* Computing Science, Umea University, S-901 87 Umea, Sweden,\n* 1995.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.clatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [: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_ijob = argv[0];
+ rblapack_z = argv[1];
+ rblapack_rhs = argv[2];
+ rblapack_rdsum = argv[3];
+ rblapack_rdscal = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_jpiv = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ if (!NA_IsNArray(rblapack_rhs))
+ rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_rhs);
+ if (NA_TYPE(rblapack_rhs) != NA_SCOMPLEX)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_SCOMPLEX);
+ rhs = NA_PTR_TYPE(rblapack_rhs, complex*);
+ rdscal = (real)NUM2DBL(rblapack_rdscal);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ 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 rhs");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ rdsum = (real)NUM2DBL(rblapack_rdsum);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, complex*);
+ MEMCPY(rhs_out__, rhs, complex, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ clatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
+
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_clatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clatdf", rblapack_clatdf, -1);
+}
diff --git a/ext/clatps.c b/ext/clatps.c
new file mode 100644
index 0000000..3b63b51
--- /dev/null
+++ b/ext/clatps.c
@@ -0,0 +1,124 @@
+#include "rb_lapack.h"
+
+extern VOID clatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, complex* ap, complex* x, real* scale, real* cnorm, integer* info);
+
+
+static VALUE
+rblapack_clatps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_cnorm;
+ real *cnorm;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_cnorm_out__;
+ real *cnorm_out__;
+
+ 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 scale, info, x, cnorm = NumRu::Lapack.clatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* CLATPS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A**T denotes the\n* transpose of A, A**H denotes the conjugate transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX 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*\n* X (input/output) COMPLEX array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, CTPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.clatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ 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) != (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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
+ MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ clatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_clatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clatps", rblapack_clatps, -1);
+}
diff --git a/ext/clatrd.c b/ext/clatrd.c
new file mode 100644
index 0000000..d7d29e2
--- /dev/null
+++ b/ext/clatrd.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID clatrd_(char* uplo, integer* n, integer* nb, complex* a, integer* lda, real* e, complex* tau, complex* w, integer* ldw);
+
+
+static VALUE
+rblapack_clatrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 e, tau, w, a = NumRu::Lapack.clatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* CLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n* Hermitian tridiagonal form by a unitary similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', CLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', CLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by CHETRD.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* E (output) REAL array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) COMPLEX array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) COMPLEX array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a Hermitian rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.clatrd( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = ldw;
+ shape[1] = MAX(n,nb);
+ rblapack_w = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
+
+ return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
+}
+
+void
+init_lapack_clatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clatrd", rblapack_clatrd, -1);
+}
diff --git a/ext/clatrs.c b/ext/clatrs.c
new file mode 100644
index 0000000..4dae0fd
--- /dev/null
+++ b/ext/clatrs.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID clatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, complex* a, integer* lda, complex* x, real* scale, real* cnorm, integer* info);
+
+
+static VALUE
+rblapack_clatrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_cnorm;
+ real *cnorm;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_cnorm_out__;
+ real *cnorm_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 scale, info, x, cnorm = NumRu::Lapack.clatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* CLATRS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A**T denotes the transpose of A, A**H denotes the\n* conjugate transpose of A, x and b are n-element vectors, and s is a\n* scaling factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) COMPLEX array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, CTRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.clatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_a = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
+ 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) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
+ MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ clatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_clatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clatrs", rblapack_clatrs, -1);
+}
diff --git a/ext/clatrz.c b/ext/clatrz.c
new file mode 100644
index 0000000..f3b77b2
--- /dev/null
+++ b/ext/clatrz.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID clatrz_(integer* m, integer* n, integer* l, complex* a, integer* lda, complex* tau, complex* work);
+
+
+static VALUE
+rblapack_clatrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.clatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means\n* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.clatrz( l, 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_l = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ l = NUM2INT(rblapack_l);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (m));
+
+ clatrz_(&m, &n, &l, a, &lda, tau, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_tau, rblapack_a);
+}
+
+void
+init_lapack_clatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clatrz", rblapack_clatrz, -1);
+}
diff --git a/ext/clatzm.c b/ext/clatzm.c
new file mode 100644
index 0000000..9f2f586
--- /dev/null
+++ b/ext/clatzm.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID clatzm_(char* side, integer* m, integer* n, complex* v, integer* incv, complex* tau, complex* c1, complex* c2, integer* ldc, complex* work);
+
+
+static VALUE
+rblapack_clatzm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ complex tau;
+ VALUE rblapack_c1;
+ complex *c1;
+ VALUE rblapack_c2;
+ complex *c2;
+ VALUE rblapack_c1_out__;
+ complex *c1_out__;
+ VALUE rblapack_c2_out__;
+ complex *c2_out__;
+ complex *work;
+
+ 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 c1, c2 = NumRu::Lapack.clatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CUNMRZ.\n*\n* CLATZM applies a Householder matrix generated by CTZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) COMPLEX\n* The value tau in the representation of P.\n*\n* C1 (input/output) COMPLEX array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) COMPLEX array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2.\n* LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.clatzm( side, m, n, v, incv, tau, c1, c2, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c1 = argv[6];
+ rblapack_c2 = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ n = NUM2INT(rblapack_n);
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c2))
+ rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c2) != 2)
+ rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c2);
+ if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
+ if (NA_TYPE(rblapack_c2) != NA_SCOMPLEX)
+ rblapack_c2 = na_change_type(rblapack_c2, NA_SCOMPLEX);
+ c2 = NA_PTR_TYPE(rblapack_c2, complex*);
+ m = NUM2INT(rblapack_m);
+ tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ if (!NA_IsNArray(rblapack_c1))
+ rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c1) != 2)
+ rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
+ if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
+ if (NA_TYPE(rblapack_c1) != NA_SCOMPLEX)
+ rblapack_c1 = na_change_type(rblapack_c1, NA_SCOMPLEX);
+ c1 = NA_PTR_TYPE(rblapack_c1, complex*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
+ rblapack_c1_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, complex*);
+ MEMCPY(c1_out__, c1, complex, NA_TOTAL(rblapack_c1));
+ rblapack_c1 = rblapack_c1_out__;
+ c1 = c1_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
+ rblapack_c2_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, complex*);
+ MEMCPY(c2_out__, c2, complex, NA_TOTAL(rblapack_c2));
+ rblapack_c2 = rblapack_c2_out__;
+ c2 = c2_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ clatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_c1, rblapack_c2);
+}
+
+void
+init_lapack_clatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clatzm", rblapack_clatzm, -1);
+}
diff --git a/ext/clauu2.c b/ext/clauu2.c
new file mode 100644
index 0000000..a966f33
--- /dev/null
+++ b/ext/clauu2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID clauu2_(char* uplo, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_clauu2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.clauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLAUU2 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) COMPLEX 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.clauu2( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clauu2_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_clauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clauu2", rblapack_clauu2, -1);
+}
diff --git a/ext/clauum.c b/ext/clauum.c
new file mode 100644
index 0000000..76fd74c
--- /dev/null
+++ b/ext/clauum.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID clauum_(char* uplo, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_clauum(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.clauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CLAUUM 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) COMPLEX 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.clauum( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ clauum_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_clauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "clauum", rblapack_clauum, -1);
+}
diff --git a/ext/cpbcon.c b/ext/cpbcon.c
new file mode 100644
index 0000000..0676de4
--- /dev/null
+++ b/ext/cpbcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID cpbcon_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* anorm, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cpbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ 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.cpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite band matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* CPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the Hermitian band 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cpbcon( uplo, kd, ab, anorm, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ kd = NUM2INT(rblapack_kd);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cpbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbcon", rblapack_cpbcon, -1);
+}
diff --git a/ext/cpbequ.c b/ext/cpbequ.c
new file mode 100644
index 0000000..a5ed160
--- /dev/null
+++ b/ext/cpbequ.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID cpbequ_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cpbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 s, scond, amax, info = NumRu::Lapack.cpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPBEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cpbequ( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ cpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cpbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbequ", rblapack_cpbequ, -1);
+}
diff --git a/ext/cpbrfs.c b/ext/cpbrfs.c
new file mode 100644
index 0000000..40402f0
--- /dev/null
+++ b/ext/cpbrfs.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID cpbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cpbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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.cpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) COMPLEX array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A as computed by\n* CPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPBTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cpbrfs( uplo, kd, ab, afb, 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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_afb = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ kd = NUM2INT(rblapack_kd);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cpbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbrfs", rblapack_cpbrfs, -1);
+}
diff --git a/ext/cpbstf.c b/ext/cpbstf.c
new file mode 100644
index 0000000..88130d4
--- /dev/null
+++ b/ext/cpbstf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID cpbstf_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_cpbstf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.cpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* CPBSTF computes a split Cholesky factorization of a complex\n* Hermitian positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with CHBGST.\n*\n* The factorization has the form A = S**H*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**H*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine; s12' denotes\n* conjg(s12); the diagonal elements of S are real.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.cpbstf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ cpbstf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_cpbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbstf", rblapack_cpbstf, -1);
+}
diff --git a/ext/cpbsv.c b/ext/cpbsv.c
new file mode 100644
index 0000000..b2dd7c0
--- /dev/null
+++ b/ext/cpbsv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cpbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cpbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, ab, b = NumRu::Lapack.cpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPBSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CPBTRF, CPBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.cpbsv( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_cpbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbsv", rblapack_cpbsv, -1);
+}
diff --git a/ext/cpbsvx.c b/ext/cpbsvx.c
new file mode 100644
index 0000000..c505a71
--- /dev/null
+++ b/ext/cpbsvx.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID cpbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cpbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_afb;
+ complex *afb;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+ VALUE rblapack_afb_out__;
+ complex *afb_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.cpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) COMPLEX array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.cpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, complex*);
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, complex*);
+ MEMCPY(afb_out__, afb, complex, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_cpbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbsvx", rblapack_cpbsvx, -1);
+}
diff --git a/ext/cpbtf2.c b/ext/cpbtf2.c
new file mode 100644
index 0000000..0da590b
--- /dev/null
+++ b/ext/cpbtf2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID cpbtf2_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_cpbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.cpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* CPBTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the conjugate transpose\n* of U, and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.cpbtf2( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ cpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_cpbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbtf2", rblapack_cpbtf2, -1);
+}
diff --git a/ext/cpbtrf.c b/ext/cpbtrf.c
new file mode 100644
index 0000000..de74107
--- /dev/null
+++ b/ext/cpbtrf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID cpbtrf_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_cpbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ complex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.cpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* CPBTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.cpbtrf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
+ MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ cpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_cpbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbtrf", rblapack_cpbtrf, -1);
+}
diff --git a/ext/cpbtrs.c b/ext/cpbtrs.c
new file mode 100644
index 0000000..3d81825
--- /dev/null
+++ b/ext/cpbtrs.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID cpbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cpbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPBTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite band matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by CPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CTBSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpbtrs( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cpbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpbtrs", rblapack_cpbtrs, -1);
+}
diff --git a/ext/cpftrf.c b/ext/cpftrf.c
new file mode 100644
index 0000000..1fe4bab
--- /dev/null
+++ b/ext/cpftrf.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID cpftrf_(char* transr, char* uplo, integer* n, complex* a, integer* info);
+
+
+static VALUE
+rblapack_cpftrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_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, a = NumRu::Lapack.cpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* CPFTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**H*U or RFP A = L*L**H.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n* Further Notes on RFP Format:\n* ============================\n*\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\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.cpftrf( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cpftrf_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cpftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpftrf", rblapack_cpftrf, -1);
+}
diff --git a/ext/cpftri.c b/ext/cpftri.c
new file mode 100644
index 0000000..0a5d473
--- /dev/null
+++ b/ext/cpftri.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID cpftri_(char* transr, char* uplo, integer* n, complex* a, integer* info);
+
+
+static VALUE
+rblapack_cpftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_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, a = NumRu::Lapack.cpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* CPFTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by CPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the Hermitian inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cpftri( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cpftri_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cpftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpftri", rblapack_cpftri, -1);
+}
diff --git a/ext/cpftrs.c b/ext/cpftrs.c
new file mode 100644
index 0000000..b0a4dd9
--- /dev/null
+++ b/ext/cpftrs.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID cpftrs_(char* transr, char* uplo, integer* n, integer* nrhs, complex* a, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cpftrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPFTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by CPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) COMPLEX array, dimension ( N*(N+1)/2 );\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**H*U or RFP A = L*L**H, as computed by CPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpftrs( transr, uplo, n, a, b, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cpftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpftrs", rblapack_cpftrs, -1);
+}
diff --git a/ext/cpocon.c b/ext/cpocon.c
new file mode 100644
index 0000000..179524c
--- /dev/null
+++ b/ext/cpocon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID cpocon_(char* uplo, integer* n, complex* a, integer* lda, real* anorm, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cpocon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ 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 rcond, info = NumRu::Lapack.cpocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPOCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite matrix using the\n* Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the Hermitian 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cpocon( uplo, a, anorm, [: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_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cpocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpocon", rblapack_cpocon, -1);
+}
diff --git a/ext/cpoequ.c b/ext/cpoequ.c
new file mode 100644
index 0000000..33d598f
--- /dev/null
+++ b/ext/cpoequ.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID cpoequ_(integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cpoequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.cpoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPOEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N Hermitian positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cpoequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ cpoequ_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cpoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpoequ", rblapack_cpoequ, -1);
+}
diff --git a/ext/cpoequb.c b/ext/cpoequb.c
new file mode 100644
index 0000000..d86f8cb
--- /dev/null
+++ b/ext/cpoequb.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID cpoequb_(integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cpoequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.cpoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPOEQUB computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cpoequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ cpoequb_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cpoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpoequb", rblapack_cpoequb, -1);
+}
diff --git a/ext/cporfs.c b/ext/cporfs.c
new file mode 100644
index 0000000..52b8731
--- /dev/null
+++ b/ext/cporfs.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID cporfs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cporfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.cporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPOTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cporfs( uplo, a, af, b, x, [: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_af = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cporfs", rblapack_cporfs, -1);
+}
diff --git a/ext/cporfsx.c b/ext/cporfsx.c
new file mode 100644
index 0000000..207fd89
--- /dev/null
+++ b/ext/cporfsx.c
@@ -0,0 +1,206 @@
+#include "rb_lapack.h"
+
+extern VOID cporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cporfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cporfsx( uplo, equed, a, af, s, b, x, params, [: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_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_s = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (5th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_cporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cporfsx", rblapack_cporfsx, -1);
+}
diff --git a/ext/cposv.c b/ext/cposv.c
new file mode 100644
index 0000000..2c4045f
--- /dev/null
+++ b/ext/cposv.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID cposv_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cposv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPOSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CPOTRF, CPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.cposv( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_cposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cposv", rblapack_cposv, -1);
+}
diff --git a/ext/cposvx.c b/ext/cposvx.c
new file mode 100644
index 0000000..dd424e2
--- /dev/null
+++ b/ext/cposvx.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID cposvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cposvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.cposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS righthand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.cposvx( fact, uplo, a, af, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_cposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cposvx", rblapack_cposvx, -1);
+}
diff --git a/ext/cposvxx.c b/ext/cposvxx.c
new file mode 100644
index 0000000..495844a
--- /dev/null
+++ b/ext/cposvxx.c
@@ -0,0 +1,235 @@
+#include "rb_lapack.h"
+
+extern VOID cposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cposvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.cposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a complex system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.cposvxx( fact, uplo, a, af, equed, s, b, params, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ cposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_cposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cposvxx", rblapack_cposvxx, -1);
+}
diff --git a/ext/cpotf2.c b/ext/cpotf2.c
new file mode 100644
index 0000000..48ec565
--- /dev/null
+++ b/ext/cpotf2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID cpotf2_(char* uplo, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_cpotf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.cpotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CPOTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\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.cpotf2( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cpotf2_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cpotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpotf2", rblapack_cpotf2, -1);
+}
diff --git a/ext/cpotrf.c b/ext/cpotrf.c
new file mode 100644
index 0000000..5ad8f30
--- /dev/null
+++ b/ext/cpotrf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID cpotrf_(char* uplo, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_cpotrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.cpotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CPOTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\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.cpotrf( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cpotrf_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cpotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpotrf", rblapack_cpotrf, -1);
+}
diff --git a/ext/cpotri.c b/ext/cpotri.c
new file mode 100644
index 0000000..e654869
--- /dev/null
+++ b/ext/cpotri.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID cpotri_(char* uplo, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_cpotri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.cpotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CPOTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, as computed by\n* CPOTRF.\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLAUUM, CTRTRI, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cpotri( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cpotri_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cpotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpotri", rblapack_cpotri, -1);
+}
diff --git a/ext/cpotrs.c b/ext/cpotrs.c
new file mode 100644
index 0000000..0795953
--- /dev/null
+++ b/ext/cpotrs.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID cpotrs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cpotrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cpotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPOTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization \n* A = U**H*U or A = L*L**H computed by CPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.cpotrs( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cpotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpotrs", rblapack_cpotrs, -1);
+}
diff --git a/ext/cppcon.c b/ext/cppcon.c
new file mode 100644
index 0000000..2efcf76
--- /dev/null
+++ b/ext/cppcon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID cppcon_(char* uplo, integer* n, complex* ap, real* anorm, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cppcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ 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.cppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPPCON estimates the reciprocal of the condition number (in the \n* 1-norm) of a complex Hermitian positive definite packed matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* CPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the Hermitian 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cppcon( uplo, ap, anorm, [: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_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cppcon_(&uplo, &n, ap, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cppcon", rblapack_cppcon, -1);
+}
diff --git a/ext/cppequ.c b/ext/cppequ.c
new file mode 100644
index 0000000..ffbaf2b
--- /dev/null
+++ b/ext/cppequ.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID cppequ_(char* uplo, integer* n, complex* ap, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_cppequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.cppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* CPPEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.cppequ( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ cppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_cppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cppequ", rblapack_cppequ, -1);
+}
diff --git a/ext/cpprfs.c b/ext/cpprfs.c
new file mode 100644
index 0000000..f8f43a5
--- /dev/null
+++ b/ext/cpprfs.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID cpprfs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cpprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_afp;
+ complex *afp;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ 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, x = NumRu::Lapack.cpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPPTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.cpprfs( uplo, ap, afp, b, x, [: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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n = ldb;
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cpprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpprfs", rblapack_cpprfs, -1);
+}
diff --git a/ext/cppsv.c b/ext/cppsv.c
new file mode 100644
index 0000000..7451693
--- /dev/null
+++ b/ext/cppsv.c
@@ -0,0 +1,104 @@
+#include "rb_lapack.h"
+
+extern VOID cppsv_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cppsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. \n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CPPTRF, CPPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.cppsv( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_cppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cppsv", rblapack_cppsv, -1);
+}
diff --git a/ext/cppsvx.c b/ext/cppsvx.c
new file mode 100644
index 0000000..d7832e8
--- /dev/null
+++ b/ext/cppsvx.c
@@ -0,0 +1,191 @@
+#include "rb_lapack.h"
+
+extern VOID cppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cppsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_afp;
+ complex *afp;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ VALUE rblapack_afp_out__;
+ complex *afp_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+ real *rwork;
+
+ 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 x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.cppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U'* U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, L is a lower triangular\n* matrix, and ' indicates conjugate transpose.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.cppsvx( fact, uplo, ap, afp, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_s);
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, complex*);
+ MEMCPY(afp_out__, afp, complex, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_cppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cppsvx", rblapack_cppsvx, -1);
+}
diff --git a/ext/cpptrf.c b/ext/cpptrf.c
new file mode 100644
index 0000000..084b220
--- /dev/null
+++ b/ext/cpptrf.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID cpptrf_(char* uplo, integer* n, complex* ap, integer* info);
+
+
+static VALUE
+rblapack_cpptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *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.cpptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* CPPTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.cpptrf( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ cpptrf_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_cpptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpptrf", rblapack_cpptrf, -1);
+}
diff --git a/ext/cpptri.c b/ext/cpptri.c
new file mode 100644
index 0000000..2c18092
--- /dev/null
+++ b/ext/cpptri.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID cpptri_(char* uplo, integer* n, complex* ap, integer* info);
+
+
+static VALUE
+rblapack_cpptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *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.cpptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* CPPTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by CPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.cpptri( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ cpptri_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_cpptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpptri", rblapack_cpptri, -1);
+}
diff --git a/ext/cpptrs.c b/ext/cpptrs.c
new file mode 100644
index 0000000..d724fb2
--- /dev/null
+++ b/ext/cpptrs.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID cpptrs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cpptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPPTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**H*U or A = L*L**H computed by CPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpptrs( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cpptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpptrs", rblapack_cpptrs, -1);
+}
diff --git a/ext/cpstf2.c b/ext/cpstf2.c
new file mode 100644
index 0000000..340e2fa
--- /dev/null
+++ b/ext/cpstf2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID cpstf2_(char* uplo, integer* n, complex* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);
+
+
+static VALUE
+rblapack_cpstf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tol;
+ real tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.cpstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CPSTF2 computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.cpstf2( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = (real)NUM2DBL(rblapack_tol);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(real, (2*n));
+
+ cpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cpstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpstf2", rblapack_cpstf2, -1);
+}
diff --git a/ext/cpstrf.c b/ext/cpstrf.c
new file mode 100644
index 0000000..2d605a7
--- /dev/null
+++ b/ext/cpstrf.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID cpstrf_(char* uplo, integer* n, complex* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);
+
+
+static VALUE
+rblapack_cpstrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tol;
+ real tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ real *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.cpstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CPSTRF computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.cpstrf( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = (real)NUM2DBL(rblapack_tol);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(real, (2*n));
+
+ cpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cpstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpstrf", rblapack_cpstrf, -1);
+}
diff --git a/ext/cptcon.c b/ext/cptcon.c
new file mode 100644
index 0000000..328a80d
--- /dev/null
+++ b/ext/cptcon.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID cptcon_(integer* n, real* d, complex* e, real* anorm, real* rcond, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cptcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ real *rwork;
+
+ 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.cptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite tridiagonal matrix\n* using the factorization A = L*D*L**H or A = U**H*D*U computed by\n* CPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by CPTTRF.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by CPTTRF.\n*\n* ANORM (input) REAL\n* The 1-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 the\n* 1-norm of inv(A) computed in this routine.\n*\n* RWORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.cptcon( d, e, anorm, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ rwork = ALLOC_N(real, (n));
+
+ cptcon_(&n, d, e, &anorm, &rcond, rwork, &info);
+
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cptcon", rblapack_cptcon, -1);
+}
diff --git a/ext/cpteqr.c b/ext/cpteqr.c
new file mode 100644
index 0000000..98734d9
--- /dev/null
+++ b/ext/cpteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID cpteqr_(char* compz, integer* n, real* d, real* e, complex* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_cpteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+ real *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.cpteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using SPTTRF and then calling CBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band positive definite Hermitian matrix\n* can also be found if CHETRD, CHPTRD, or CHBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to\n* tridiagonal form, however, may preclude the possibility of obtaining\n* high relative accuracy in the small eigenvalues of the original\n* matrix, if these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original Hermitian\n* matrix also. Array Z contains the unitary matrix\n* used to reduce the original matrix to tridiagonal\n* form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original Hermitian matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* ====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.cpteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of z");
+ 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(real, (4*n));
+
+ cpteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_cpteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpteqr", rblapack_cpteqr, -1);
+}
diff --git a/ext/cptrfs.c b/ext/cptrfs.c
new file mode 100644
index 0000000..c9d7739
--- /dev/null
+++ b/ext/cptrfs.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID cptrfs_(char* uplo, integer* n, integer* nrhs, real* d, complex* e, real* df, complex* ef, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cptrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_df;
+ real *df;
+ VALUE rblapack_ef;
+ complex *ef;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ 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.cptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the superdiagonal or the subdiagonal of the\n* tridiagonal matrix A is stored and the form of the\n* factorization:\n* = 'U': E is the superdiagonal of A, and A = U**H*D*U;\n* = 'L': E is the subdiagonal of A, and A = L*D*L**H.\n* (The two forms are equivalent if A is real.)\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* D (input) REAL array, dimension (N)\n* The n real diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix A\n* (see UPLO).\n*\n* DF (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from\n* the factorization computed by CPTTRF.\n*\n* EF (input) COMPLEX array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal\n* factor U or L from the factorization computed by CPTTRF\n* (see UPLO).\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CPTTRS.\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 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).\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) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL 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.cptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_df = argv[3];
+ rblapack_ef = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (4th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_df);
+ 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_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 df");
+ 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_ef))
+ rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_SCOMPLEX)
+ rblapack_ef = na_change_type(rblapack_ef, NA_SCOMPLEX);
+ ef = NA_PTR_TYPE(rblapack_ef, complex*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (n));
+
+ cptrfs_(&uplo, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_cptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cptrfs", rblapack_cptrfs, -1);
+}
diff --git a/ext/cptsv.c b/ext/cptsv.c
new file mode 100644
index 0000000..5c80303
--- /dev/null
+++ b/ext/cptsv.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID cptsv_(integer* n, integer* nrhs, real* d, complex* e, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cptsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ complex *e_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.cptsv( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPTSV computes the solution to a complex system of linear equations\n* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**H, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**H.\n*\n* E (input/output) COMPLEX array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**H factorization of\n* A. E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**H*D*U factorization of A.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL CPTTRF, CPTTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.cptsv( d, e, b, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, complex*);
+ MEMCPY(e_out__, e, complex, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cptsv_(&n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_cptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cptsv", rblapack_cptsv, -1);
+}
diff --git a/ext/cptsvx.c b/ext/cptsvx.c
new file mode 100644
index 0000000..8645773
--- /dev/null
+++ b/ext/cptsvx.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID cptsvx_(char* fact, integer* n, integer* nrhs, real* d, complex* e, real* df, complex* ef, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cptsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_df;
+ real *df;
+ VALUE rblapack_ef;
+ complex *ef;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_df_out__;
+ real *df_out__;
+ VALUE rblapack_ef_out__;
+ complex *ef_out__;
+ complex *work;
+ real *rwork;
+
+ 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 x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.cptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CPTSVX uses the factorization A = L*D*L**H to compute the solution\n* to a complex system of linear equations A*X = B, where A is an\n* N-by-N Hermitian positive definite tridiagonal matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**H*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix\n* A is supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) REAL array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n*\n* EF (input or output) COMPLEX array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) REAL array, dimension (NRHS)\n* The 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).\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 any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.cptsvx( fact, d, e, df, ef, b, [: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_fact = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_df = argv[3];
+ rblapack_ef = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (4th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_df);
+ 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_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 df");
+ 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_ef))
+ rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_SCOMPLEX)
+ rblapack_ef = na_change_type(rblapack_ef, NA_SCOMPLEX);
+ ef = NA_PTR_TYPE(rblapack_ef, complex*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, real*);
+ MEMCPY(df_out__, df, real, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_ef_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, complex*);
+ MEMCPY(ef_out__, ef, complex, NA_TOTAL(rblapack_ef));
+ rblapack_ef = rblapack_ef_out__;
+ ef = ef_out__;
+ work = ALLOC_N(complex, (n));
+ rwork = ALLOC_N(real, (n));
+
+ cptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
+}
+
+void
+init_lapack_cptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cptsvx", rblapack_cptsvx, -1);
+}
diff --git a/ext/cpttrf.c b/ext/cpttrf.c
new file mode 100644
index 0000000..0c1002f
--- /dev/null
+++ b/ext/cpttrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID cpttrf_(integer* n, real* d, complex* e, integer* info);
+
+
+static VALUE
+rblapack_cpttrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ complex *e_out__;
+
+ 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, d, e = NumRu::Lapack.cpttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* CPTTRF computes the L*D*L' factorization of a complex Hermitian\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) COMPLEX array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.cpttrf( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, complex*);
+ MEMCPY(e_out__, e, complex, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ cpttrf_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_cpttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpttrf", rblapack_cpttrf, -1);
+}
diff --git a/ext/cpttrs.c b/ext/cpttrs.c
new file mode 100644
index 0000000..e805342
--- /dev/null
+++ b/ext/cpttrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID cpttrs_(char* uplo, integer* n, integer* nrhs, real* d, complex* e, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cpttrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.cpttrs( uplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 'U': A = U'*D*U, E is the superdiagonal of U\n* = 'L': A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER IUPLO, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CPTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.cpttrs( uplo, d, e, b, [: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_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cpttrs_(&uplo, &n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_cpttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cpttrs", rblapack_cpttrs, -1);
+}
diff --git a/ext/cptts2.c b/ext/cptts2.c
new file mode 100644
index 0000000..c20dee9
--- /dev/null
+++ b/ext/cptts2.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID cptts2_(integer* iuplo, integer* n, integer* nrhs, real* d, complex* e, complex* b, integer* ldb);
+
+
+static VALUE
+rblapack_cptts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_iuplo;
+ integer iuplo;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.cptts2( iuplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* CPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* IUPLO (input) INTEGER\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 1: A = U'*D*U, E is the superdiagonal of U\n* = 0: A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX array, dimension (N-1)\n* If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL CSSCAL\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.cptts2( iuplo, d, e, b, [: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_iuplo = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ iuplo = NUM2INT(rblapack_iuplo);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cptts2_(&iuplo, &n, &nrhs, d, e, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_cptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cptts2", rblapack_cptts2, -1);
+}
diff --git a/ext/crot.c b/ext/crot.c
new file mode 100644
index 0000000..5ae0c0a
--- /dev/null
+++ b/ext/crot.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID crot_(integer* n, complex* cx, integer* incx, complex* cy, integer* incy, real* c, complex* s);
+
+
+static VALUE
+rblapack_crot(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ complex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_cy;
+ complex *cy;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_s;
+ complex s;
+ VALUE rblapack_cx_out__;
+ complex *cx_out__;
+ VALUE rblapack_cy_out__;
+ complex *cy_out__;
+
+ 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 cx, cy = NumRu::Lapack.crot( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* CROT applies a plane rotation, where the cos (C) is real and the\n* sin (S) is complex, and the vectors CX and CY are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX array, dimension (N)\n* On input, the vector X.\n* On output, CX is overwritten with C*X + S*Y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* CY (input/output) COMPLEX array, dimension (N)\n* On input, the vector Y.\n* On output, CY is overwritten with -CONJG(S)*X + C*Y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* C (input) REAL\n* S (input) COMPLEX\n* C and S define a rotation\n* [ C S ]\n* [ -conjg(S) C ]\n* where C*C + S*CONJG(S) = 1.0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.crot( cx, incx, cy, incy, c, s, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_cy = argv[2];
+ rblapack_incy = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, complex*);
+ if (!NA_IsNArray(rblapack_cy))
+ rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
+ if (NA_RANK(rblapack_cy) != 1)
+ rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
+ if (NA_TYPE(rblapack_cy) != NA_SCOMPLEX)
+ rblapack_cy = na_change_type(rblapack_cy, NA_SCOMPLEX);
+ cy = NA_PTR_TYPE(rblapack_cy, complex*);
+ c = (real)NUM2DBL(rblapack_c);
+ incx = NUM2INT(rblapack_incx);
+ s.r = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
+ s.i = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
+ incy = NUM2INT(rblapack_incy);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, complex*);
+ MEMCPY(cx_out__, cx, complex, NA_TOTAL(rblapack_cx));
+ rblapack_cx = rblapack_cx_out__;
+ cx = cx_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cy_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, complex*);
+ MEMCPY(cy_out__, cy, complex, NA_TOTAL(rblapack_cy));
+ rblapack_cy = rblapack_cy_out__;
+ cy = cy_out__;
+
+ crot_(&n, cx, &incx, cy, &incy, &c, &s);
+
+ return rb_ary_new3(2, rblapack_cx, rblapack_cy);
+}
+
+void
+init_lapack_crot(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "crot", rblapack_crot, -1);
+}
diff --git a/ext/cspcon.c b/ext/cspcon.c
new file mode 100644
index 0000000..a5ce81c
--- /dev/null
+++ b/ext/cspcon.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID cspcon_(char* uplo, integer* n, complex* ap, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cspcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *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 rcond, info = NumRu::Lapack.cspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric packed matrix A using the\n* factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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.cspcon( uplo, ap, ipiv, anorm, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(complex, (2*n));
+
+ cspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_cspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cspcon", rblapack_cspcon, -1);
+}
diff --git a/ext/cspmv.c b/ext/cspmv.c
new file mode 100644
index 0000000..740b8c3
--- /dev/null
+++ b/ext/cspmv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID cspmv_(char* uplo, integer* n, complex* alpha, complex* ap, complex* x, integer* incx, complex* beta, complex* y, integer* incy);
+
+
+static VALUE
+rblapack_cspmv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ complex beta;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ complex *y_out__;
+ 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 y = NumRu::Lapack.cspmv( uplo, alpha, ap, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CSPMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* AP (input) COMPLEX array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on.\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX array, dimension at least \n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.cspmv( uplo, alpha, ap, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
+ ldap = NA_SHAPE0(rblapack_ap);
+ if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ beta.r = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
+ beta.i = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
+ n = ((integer)sqrtf(8*ldap+1.0f)-1)/2;
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + (n-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + (n-1)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + (n-1)*abs(incy)))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + (n-1)*abs(incy));
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[1];
+ shape[0] = 1 + (n-1)*abs(incy);
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ cspmv_(&uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_cspmv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cspmv", rblapack_cspmv, -1);
+}
diff --git a/ext/cspr.c b/ext/cspr.c
new file mode 100644
index 0000000..6da0527
--- /dev/null
+++ b/ext/cspr.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID cspr_(char* uplo, integer* n, complex* alpha, complex* x, integer* incx, complex* ap);
+
+
+static VALUE
+rblapack_cspr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ap_out__;
+ complex *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 ap = NumRu::Lapack.cspr( uplo, n, alpha, x, incx, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n* Purpose\n* =======\n*\n* CSPR performs the symmetric rank 1 operation\n*\n* A := alpha*x*conjg( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* AP (input/output) COMPLEX array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on. On exit, the array\n* AP is overwritten by the upper triangular part of the\n* updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on. On exit, the array\n* AP is overwritten by the lower triangular part of the\n* updated matrix.\n* Note that the imaginary parts of the diagonal elements need\n* not be set, they are assumed to be zero, and on exit they\n* are set to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ap = NumRu::Lapack.cspr( uplo, n, alpha, x, incx, ap, [: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_n = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_ap = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ incx = NUM2INT(rblapack_incx);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (6th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[1];
+ shape[0] = ( n*( n + 1 ) )/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ cspr_(&uplo, &n, &alpha, x, &incx, ap);
+
+ return rblapack_ap;
+}
+
+void
+init_lapack_cspr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cspr", rblapack_cspr, -1);
+}
diff --git a/ext/csprfs.c b/ext/csprfs.c
new file mode 100644
index 0000000..62c7533
--- /dev/null
+++ b/ext/csprfs.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID csprfs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_csprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_afp;
+ complex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ 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.csprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by CSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CSPTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.csprfs( uplo, ap, afp, ipiv, 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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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 (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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, complex*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ csprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_csprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csprfs", rblapack_csprfs, -1);
+}
diff --git a/ext/cspsv.c b/ext/cspsv.c
new file mode 100644
index 0000000..3684a75
--- /dev/null
+++ b/ext/cspsv.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID cspsv_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_cspsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+ 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 ipiv, info, ap, b = NumRu::Lapack.cspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CSPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSPTRF, CSPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.cspsv( uplo, ap, b, [: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_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ n = ldb;
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ cspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_cspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cspsv", rblapack_cspsv, -1);
+}
diff --git a/ext/cspsvx.c b/ext/cspsvx.c
new file mode 100644
index 0000000..d3f94c1
--- /dev/null
+++ b/ext/cspsvx.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID cspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_cspsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_afp;
+ complex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_afp_out__;
+ complex *afp_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ complex *work;
+ real *rwork;
+
+ 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 x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.cspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form\n* of A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CSPTRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.cspsvx( fact, uplo, ap, afp, ipiv, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ ldx = MAX(1,n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, complex*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, complex*);
+ MEMCPY(afp_out__, afp, complex, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ cspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
+}
+
+void
+init_lapack_cspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cspsvx", rblapack_cspsvx, -1);
+}
diff --git a/ext/csptrf.c b/ext/csptrf.c
new file mode 100644
index 0000000..5686dd8
--- /dev/null
+++ b/ext/csptrf.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID csptrf_(char* uplo, integer* n, complex* ap, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_csptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+
+ 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 ipiv, info, ap = NumRu::Lapack.csptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CSPTRF computes the factorization of a complex symmetric matrix A\n* stored in packed format using the Bunch-Kaufman diagonal pivoting\n* method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.csptrf( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ csptrf_(&uplo, &n, ap, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_csptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csptrf", rblapack_csptrf, -1);
+}
diff --git a/ext/csptri.c b/ext/csptri.c
new file mode 100644
index 0000000..aea3d46
--- /dev/null
+++ b/ext/csptri.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID csptri_(char* uplo, integer* n, complex* ap, integer* ipiv, complex* work, integer* info);
+
+
+static VALUE
+rblapack_csptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *ap_out__;
+ complex *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 info, ap = NumRu::Lapack.csptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSPTRI computes the inverse of a complex symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* WORK (workspace) COMPLEX 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.csptri( uplo, ap, ipiv, [: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_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(complex, (n));
+
+ csptri_(&uplo, &n, ap, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_csptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csptri", rblapack_csptri, -1);
+}
diff --git a/ext/csptrs.c b/ext/csptrs.c
new file mode 100644
index 0000000..1b66143
--- /dev/null
+++ b/ext/csptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID csptrs_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_csptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.csptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CSPTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSPTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.csptrs( uplo, ap, ipiv, b, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ csptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_csptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csptrs", rblapack_csptrs, -1);
+}
diff --git a/ext/csrscl.c b/ext/csrscl.c
new file mode 100644
index 0000000..3ccb367
--- /dev/null
+++ b/ext/csrscl.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID csrscl_(integer* n, real* sa, complex* sx, integer* incx);
+
+
+static VALUE
+rblapack_csrscl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_sa;
+ real sa;
+ VALUE rblapack_sx;
+ complex *sx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_sx_out__;
+ complex *sx_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 sx = NumRu::Lapack.csrscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* CSRSCL multiplies an n-element complex vector x by the real scalar\n* 1/a. This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) REAL\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) COMPLEX array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sx = NumRu::Lapack.csrscl( n, sa, sx, incx, [: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_n = argv[0];
+ rblapack_sa = argv[1];
+ rblapack_sx = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ sa = (real)NUM2DBL(rblapack_sa);
+ if (!NA_IsNArray(rblapack_sx))
+ rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
+ if (NA_RANK(rblapack_sx) != 1)
+ rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
+ if (NA_TYPE(rblapack_sx) != NA_SCOMPLEX)
+ rblapack_sx = na_change_type(rblapack_sx, NA_SCOMPLEX);
+ sx = NA_PTR_TYPE(rblapack_sx, complex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*abs(incx);
+ rblapack_sx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, complex*);
+ MEMCPY(sx_out__, sx, complex, NA_TOTAL(rblapack_sx));
+ rblapack_sx = rblapack_sx_out__;
+ sx = sx_out__;
+
+ csrscl_(&n, &sa, sx, &incx);
+
+ return rblapack_sx;
+}
+
+void
+init_lapack_csrscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csrscl", rblapack_csrscl, -1);
+}
diff --git a/ext/cstedc.c b/ext/cstedc.c
new file mode 100644
index 0000000..071803e
--- /dev/null
+++ b/ext/cstedc.c
@@ -0,0 +1,177 @@
+#include "rb_lapack.h"
+
+extern VOID cstedc_(char* compz, integer* n, real* d, real* e, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_cstedc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_rwork;
+ real *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 work, rwork, iwork, info, d, e, z = NumRu::Lapack.cstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See SLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original Hermitian matrix\n* also. On entry, Z contains the unitary matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n* Note that for COMPZ = 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be 1.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 3*N + 2*N*lg N + 3*N**2 ,\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1, LRWORK must be at least\n* 1 + 4*N + 2*N**2 .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LRWORK\n* need only be max(1,2*(N-1)).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If COMPZ = 'V' or N > 1, LIWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* If COMPZ = 'I' or N > 1, LIWORK must be at least\n* 3 + 5*N .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, rwork, iwork, info, d, e, z = NumRu::Lapack.cstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 7) {
+ rblapack_lwork = argv[4];
+ rblapack_lrwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of z");
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&compz,"N")||lsame_(&compz,"I")||n<=1) ? 1 : lsame_(&compz,"V") ? n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ cstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_cstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cstedc", rblapack_cstedc, -1);
+}
diff --git a/ext/cstegr.c b/ext/cstegr.c
new file mode 100644
index 0000000..69426a9
--- /dev/null
+++ b/ext/cstegr.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID cstegr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_cstegr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.cstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* CSTEGR is a compatability wrapper around the improved CSTEMR routine.\n* See SSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : CSTEGR and CSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in CLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* CLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL CSTEMR\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.cstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ cstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_cstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cstegr", rblapack_cstegr, -1);
+}
diff --git a/ext/cstein.c b/ext/cstein.c
new file mode 100644
index 0000000..3607885
--- /dev/null
+++ b/ext/cstein.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID cstein_(integer* n, real* d, real* e, integer* m, real* w, integer* iblock, integer* isplit, complex* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_cstein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.cstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* CSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n* Although the eigenvectors are real, they are stored in a complex\n* array, which may be passed to CUNMTR or CUPMTR for back\n* transformation to the eigenvectors of a complex Hermitian matrix\n* which was reduced to tridiagonal form.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, stored in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) REAL array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from SSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from SSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from SSTEBZ is expected here. )\n*\n* Z (output) COMPLEX array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n* The imaginary parts of the eigenvectors are set to zero.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.cstein( d, e, w, iblock, isplit, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_w = argv[2];
+ rblapack_iblock = argv[3];
+ rblapack_isplit = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ m = n;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ ldz = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = m;
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ work = ALLOC_N(real, (5*n));
+ iwork = ALLOC_N(integer, (n));
+
+ cstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
+}
+
+void
+init_lapack_cstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cstein", rblapack_cstein, -1);
+}
diff --git a/ext/cstemr.c b/ext/cstemr.c
new file mode 100644
index 0000000..ec12ea7
--- /dev/null
+++ b/ext/cstemr.c
@@ -0,0 +1,193 @@
+#include "rb_lapack.h"
+
+extern VOID cstemr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, integer* m, real* w, complex* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_cstemr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_nzc;
+ integer nzc;
+ VALUE rblapack_tryrac;
+ logical tryrac;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.cstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.CSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n* real symmetric tridiagonal form.\n*\n* (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n* and potentially complex numbers on its off-diagonals. By applying a\n* similarity transform with an appropriate diagonal matrix\n* diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n* matrix can be transformed into a real symmetric matrix and complex\n* arithmetic can be entirely avoided.)\n*\n* While the eigenvectors of the real symmetric tridiagonal matrix are real,\n* the eigenvectors of original complex Hermitean matrix have complex entries\n* in general.\n* Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n* CSTEMR accepts complex workspace to facilitate interoperability\n* with CUNMTR or CUPMTR.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in CLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* CLARRV, respectively.\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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.cstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_nzc = argv[8];
+ rblapack_tryrac = argv[9];
+ if (argc == 12) {
+ rblapack_lwork = argv[10];
+ rblapack_liwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ nzc = NUM2INT(rblapack_nzc);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ tryrac = (rblapack_tryrac == Qtrue);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ cstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ rblapack_tryrac = tryrac ? Qtrue : Qfalse;
+ return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
+}
+
+void
+init_lapack_cstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cstemr", rblapack_cstemr, -1);
+}
diff --git a/ext/csteqr.c b/ext/csteqr.c
new file mode 100644
index 0000000..8aac0aa
--- /dev/null
+++ b/ext/csteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID csteqr_(char* compz, integer* n, real* d, real* e, complex* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_csteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+ real *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.csteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* Hermitian matrix. On entry, Z must contain the\n* unitary matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is unitarily similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.csteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of z");
+ 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(real, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
+
+ csteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_csteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csteqr", rblapack_csteqr, -1);
+}
diff --git a/ext/csycon.c b/ext/csycon.c
new file mode 100644
index 0000000..c64012b
--- /dev/null
+++ b/ext/csycon.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID csycon_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);
+
+
+static VALUE
+rblapack_csycon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+
+ 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 rcond, info = NumRu::Lapack.csycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by CSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* ANORM (input) REAL\n* The 1-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) COMPLEX array, dimension (2*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.csycon( uplo, a, ipiv, anorm, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(complex, (2*n));
+
+ csycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_csycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csycon", rblapack_csycon, -1);
+}
diff --git a/ext/csyconv.c b/ext/csyconv.c
new file mode 100644
index 0000000..54d2a4d
--- /dev/null
+++ b/ext/csyconv.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID csyconv_(char* uplo, char* way, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* info);
+
+
+static VALUE
+rblapack_csyconv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_way;
+ char way;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+
+ 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 = NumRu::Lapack.csyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYCONV convert A given by TRF into L and D and vice-versa.\n* Get Non-diag elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 = NumRu::Lapack.csyconv( uplo, way, a, ipiv, [: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_way = argv[1];
+ rblapack_a = argv[2];
+ rblapack_ipiv = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ way = StringValueCStr(rblapack_way)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ work = ALLOC_N(complex, (MAX(1,n)));
+
+ csyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rblapack_info;
+}
+
+void
+init_lapack_csyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csyconv", rblapack_csyconv, -1);
+}
diff --git a/ext/csyequb.c b/ext/csyequb.c
new file mode 100644
index 0000000..7b679e9
--- /dev/null
+++ b/ext/csyequb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID csyequb_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, complex* work, integer* info);
+
+
+static VALUE
+rblapack_csyequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+
+ 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 s, scond, amax, info = NumRu::Lapack.csyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) COMPLEX array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.csyequb( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ work = ALLOC_N(complex, (3*n));
+
+ csyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
+
+ free(work);
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_csyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csyequb", rblapack_csyequb, -1);
+}
diff --git a/ext/csymv.c b/ext/csymv.c
new file mode 100644
index 0000000..911de7b
--- /dev/null
+++ b/ext/csymv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID csymv_(char* uplo, integer* n, complex* alpha, complex* a, integer* lda, complex* x, integer* incx, complex* beta, complex* y, integer* incy);
+
+
+static VALUE
+rblapack_csymv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ complex beta;
+ VALUE rblapack_y;
+ complex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ complex *y_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 y = NumRu::Lapack.csymv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* CSYMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.csymv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ beta.r = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
+ beta.i = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, complex*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
+ MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ csymv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_csymv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csymv", rblapack_csymv, -1);
+}
diff --git a/ext/csyr.c b/ext/csyr.c
new file mode 100644
index 0000000..3d655f8
--- /dev/null
+++ b/ext/csyr.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID csyr_(char* uplo, integer* n, complex* alpha, complex* x, integer* incx, complex* a, integer* lda);
+
+
+static VALUE
+rblapack_csyr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_a_out__;
+ complex *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 a = NumRu::Lapack.csyr( uplo, alpha, x, incx, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n* Purpose\n* =======\n*\n* CSYR performs the symmetric rank 1 operation\n*\n* A := alpha*x*( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* A (input/output) COMPLEX array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced. On exit, the\n* upper triangular part of the array A is overwritten by the\n* upper triangular part of the updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced. On exit, the\n* lower triangular part of the array A is overwritten by the\n* lower triangular part of the updated matrix.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.csyr( uplo, alpha, x, incx, a, [: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_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ incx = NUM2INT(rblapack_incx);
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ csyr_(&uplo, &n, &alpha, x, &incx, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_csyr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csyr", rblapack_csyr, -1);
+}
diff --git a/ext/csyrfs.c b/ext/csyrfs.c
new file mode 100644
index 0000000..16294af
--- /dev/null
+++ b/ext/csyrfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID csyrfs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_csyrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.csyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by CSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by CSYTRS.\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.csyrfs( uplo, a, af, ipiv, 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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ csyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_csyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csyrfs", rblapack_csyrfs, -1);
+}
diff --git a/ext/csyrfsx.c b/ext/csyrfsx.c
new file mode 100644
index 0000000..94ffca9
--- /dev/null
+++ b/ext/csyrfsx.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID csyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_csyrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_x_out__;
+ complex *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.csyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX 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) COMPLEX array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.csyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ n_err_bnds = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
+ MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ csyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_csyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csyrfsx", rblapack_csyrfsx, -1);
+}
diff --git a/ext/csysv.c b/ext/csysv.c
new file mode 100644
index 0000000..fff3967
--- /dev/null
+++ b/ext/csysv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID csysv_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_csysv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, work, info, a, b = NumRu::Lapack.csysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by CSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* CSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSYTRF, CSYTRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.csysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ csysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_csysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csysv", rblapack_csysv, -1);
+}
diff --git a/ext/csysvx.c b/ext/csysvx.c
new file mode 100644
index 0000000..1f1e2b6
--- /dev/null
+++ b/ext/csysvx.c
@@ -0,0 +1,183 @@
+#include "rb_lapack.h"
+
+extern VOID csysvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, integer* lwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_csysvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.csysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by CSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by CSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by CSYTRF.\n*\n* B (input) COMPLEX array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for CSYTRF.\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* RWORK (workspace) REAL 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.csysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ ldx = MAX(1,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ rwork = ALLOC_N(real, (n));
+
+ csysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
+}
+
+void
+init_lapack_csysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csysvx", rblapack_csysvx, -1);
+}
diff --git a/ext/csysvxx.c b/ext/csysvxx.c
new file mode 100644
index 0000000..89734b5
--- /dev/null
+++ b/ext/csysvxx.c
@@ -0,0 +1,258 @@
+#include "rb_lapack.h"
+
+extern VOID csysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_csysvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_af;
+ complex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_af_out__;
+ complex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.csysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. CSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* CSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* CSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what CSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.csysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, complex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
+ MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ csysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_csysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csysvxx", rblapack_csysvxx, -1);
+}
diff --git a/ext/csyswapr.c b/ext/csyswapr.c
new file mode 100644
index 0000000..1e7832c
--- /dev/null
+++ b/ext/csyswapr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID csyswapr_(char* uplo, integer* n, complex* a, integer* i1, integer* i2);
+
+
+static VALUE
+rblapack_csyswapr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_i1;
+ integer i1;
+ VALUE rblapack_i2;
+ integer i2;
+ VALUE rblapack_a_out__;
+ complex *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 a = NumRu::Lapack.csyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* CSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n COMPLEX TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CSWAP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.csyswapr( uplo, a, i1, i2, [: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_a = argv[1];
+ rblapack_i1 = argv[2];
+ rblapack_i2 = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ i1 = NUM2INT(rblapack_i1);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ i2 = NUM2INT(rblapack_i2);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ csyswapr_(&uplo, &n, a, &i1, &i2);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_csyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csyswapr", rblapack_csyswapr, -1);
+}
diff --git a/ext/csytf2.c b/ext/csytf2.c
new file mode 100644
index 0000000..b18d671
--- /dev/null
+++ b/ext/csytf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID csytf2_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_csytf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ipiv, info, a = NumRu::Lapack.csytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* CSYTF2 computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.209 and l.377\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.csytf2( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ csytf2_(&uplo, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_csytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csytf2", rblapack_csytf2, -1);
+}
diff --git a/ext/csytrf.c b/ext/csytrf.c
new file mode 100644
index 0000000..859c189
--- /dev/null
+++ b/ext/csytrf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID csytrf_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_csytrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 ipiv, work, info, a = NumRu::Lapack.csytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRF computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CLASYF, CSYTF2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.csytrf( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ csytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_csytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csytrf", rblapack_csytrf, -1);
+}
diff --git a/ext/csytri.c b/ext/csytri.c
new file mode 100644
index 0000000..9176bcf
--- /dev/null
+++ b/ext/csytri.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID csytri_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* info);
+
+
+static VALUE
+rblapack_csytri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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.csytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRI computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* CSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.csytri( uplo, a, ipiv, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (2*n));
+
+ csytri_(&uplo, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_csytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csytri", rblapack_csytri, -1);
+}
diff --git a/ext/csytri2.c b/ext/csytri2.c
new file mode 100644
index 0000000..8c03769
--- /dev/null
+++ b/ext/csytri2.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID csytri2_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_csytri2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ integer c__1;
+ integer c__m1;
+ integer nb;
+ complex *work;
+
+ 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.csytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* CSYTRF. CSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling CSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL CSYTRI2X\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.csytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ c__1 = 1;
+ 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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ c__m1 = -1;
+ nb = ilaenv_(&c__1, "CSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
+ if (rblapack_lwork == Qnil)
+ lwork = (n+nb+1)*(nb+3);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (lwork));
+
+ csytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_csytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csytri2", rblapack_csytri2, -1);
+}
diff --git a/ext/csytri2x.c b/ext/csytri2x.c
new file mode 100644
index 0000000..725ac20
--- /dev/null
+++ b/ext/csytri2x.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID csytri2x_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* nb, integer* info);
+
+
+static VALUE
+rblapack_csytri2x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ 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.csytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRI2X computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* CSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by CSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by CSYTRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.csytri2x( uplo, a, ipiv, nb, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_nb = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ nb = NUM2INT(rblapack_nb);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n+nb+1)*(nb+3));
+
+ csytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_csytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csytri2x", rblapack_csytri2x, -1);
+}
diff --git a/ext/csytrs.c b/ext/csytrs.c
new file mode 100644
index 0000000..4dad8fd
--- /dev/null
+++ b/ext/csytrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID csytrs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_csytrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.csytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.csytrs( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ csytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_csytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csytrs", rblapack_csytrs, -1);
+}
diff --git a/ext/csytrs2.c b/ext/csytrs2.c
new file mode 100644
index 0000000..2757022
--- /dev/null
+++ b/ext/csytrs2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID csytrs2_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* info);
+
+
+static VALUE
+rblapack_csytrs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.csytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CSYTRS2 solves a system of linear equations A*X = B with a COMPLEX\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by CSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CSYTRF.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) COMPLEX 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 info, b = NumRu::Lapack.csytrs2( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(complex, (n));
+
+ csytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_csytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "csytrs2", rblapack_csytrs2, -1);
+}
diff --git a/ext/ctbcon.c b/ext/ctbcon.c
new file mode 100644
index 0000000..bd8fa30
--- /dev/null
+++ b/ext/ctbcon.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID ctbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, complex* ab, integer* ldab, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ 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.ctbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.ctbcon( norm, uplo, diag, kd, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kd = NUM2INT(rblapack_kd);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ ctbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_ctbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctbcon", rblapack_ctbcon, -1);
+}
diff --git a/ext/ctbrfs.c b/ext/ctbrfs.c
new file mode 100644
index 0000000..9406e5c
--- /dev/null
+++ b/ext/ctbrfs.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID ctbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ integer ldab;
+ 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 = NumRu::Lapack.ctbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by CTBTRS or some other\n* means before entering this routine. CTBRFS 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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.ctbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ 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*);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ ctbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
+}
+
+void
+init_lapack_ctbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctbrfs", rblapack_ctbrfs, -1);
+}
diff --git a/ext/ctbtrs.c b/ext/ctbtrs.c
new file mode 100644
index 0000000..dce432a
--- /dev/null
+++ b/ext/ctbtrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID ctbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ctbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ complex *ab;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ctbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CTBTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by-NRHS matrix. A check is made to verify that A is nonsingular.\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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ctbtrs( uplo, trans, diag, kd, ab, b, [: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_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = 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_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ctbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ctbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctbtrs", rblapack_ctbtrs, -1);
+}
diff --git a/ext/ctfsm.c b/ext/ctfsm.c
new file mode 100644
index 0000000..4f9218d
--- /dev/null
+++ b/ext/ctfsm.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID ctfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, complex* alpha, complex* a, complex* b, integer* ldb);
+
+
+static VALUE
+rblapack_ctfsm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ complex alpha;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldb;
+ 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 b = NumRu::Lapack.ctfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* CTFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = conjg( A' ).\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'C' or 'c' op( A ) = conjg( A' ).\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) COMPLEX array, dimension (N*(N+1)/2)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.ctfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_transr = argv[0];
+ rblapack_side = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_trans = argv[3];
+ rblapack_diag = argv[4];
+ rblapack_m = argv[5];
+ rblapack_alpha = argv[6];
+ rblapack_a = argv[7];
+ rblapack_b = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (8th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ctfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_ctfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctfsm", rblapack_ctfsm, -1);
+}
diff --git a/ext/ctftri.c b/ext/ctftri.c
new file mode 100644
index 0000000..2a97961
--- /dev/null
+++ b/ext/ctftri.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID ctftri_(char* transr, char* uplo, char* diag, integer* n, complex* a, integer* info);
+
+
+static VALUE
+rblapack_ctftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_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, a = NumRu::Lapack.ctftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* CTFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\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* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the triangular matrix A in RFP format. RFP format\n* is described by TRANSR, UPLO, and N as follows: If TRANSR =\n* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ctftri( transr, uplo, diag, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ ctftri_(&transr, &uplo, &diag, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ctftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctftri", rblapack_ctftri, -1);
+}
diff --git a/ext/ctfttp.c b/ext/ctfttp.c
new file mode 100644
index 0000000..231c743
--- /dev/null
+++ b/ext/ctfttp.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID ctfttp_(char* transr, char* uplo, integer* n, complex* arf, complex* ap, integer* info);
+
+
+static VALUE
+rblapack_ctfttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_arf;
+ complex *arf;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 ap, info = NumRu::Lapack.ctfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* CTFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.ctfttp( transr, uplo, n, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_arf = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
+ rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
+ if (NA_TYPE(rblapack_arf) != NA_SCOMPLEX)
+ rblapack_arf = na_change_type(rblapack_arf, NA_SCOMPLEX);
+ arf = NA_PTR_TYPE(rblapack_arf, complex*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_ap = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+
+ ctfttp_(&transr, &uplo, &n, arf, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_ctfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctfttp", rblapack_ctfttp, -1);
+}
diff --git a/ext/ctfttr.c b/ext/ctfttr.c
new file mode 100644
index 0000000..6ea2b73
--- /dev/null
+++ b/ext/ctfttr.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID ctfttr_(char* transr, char* uplo, integer* n, complex* arf, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ctfttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_arf;
+ complex *arf;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldarf;
+ 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 a, info = NumRu::Lapack.ctfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* A (output) COMPLEX array, dimension ( LDA, N ) \n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.ctfttr( transr, uplo, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_arf = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
+ ldarf = NA_SHAPE0(rblapack_arf);
+ if (NA_TYPE(rblapack_arf) != NA_SCOMPLEX)
+ rblapack_arf = na_change_type(rblapack_arf, NA_SCOMPLEX);
+ arf = NA_PTR_TYPE(rblapack_arf, complex*);
+ n = ((int)sqrtf(ldarf*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+
+ ctfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_ctfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctfttr", rblapack_ctfttr, -1);
+}
diff --git a/ext/ctgevc.c b/ext/ctgevc.c
new file mode 100644
index 0000000..8eddd36
--- /dev/null
+++ b/ext/ctgevc.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID ctgevc_(char* side, char* howmny, logical* select, integer* n, complex* s, integer* lds, complex* p, integer* ldp, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* mm, integer* m, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctgevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_s;
+ complex *s;
+ VALUE rblapack_p;
+ complex *p;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_vl_out__;
+ complex *vl_out__;
+ VALUE rblapack_vr_out__;
+ complex *vr_out__;
+ complex *work;
+ real *rwork;
+
+ integer n;
+ integer lds;
+ integer ldp;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, vl, vr = NumRu::Lapack.ctgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of complex matrices (S,P), where S and P are upper triangular.\n* Matrix pairs of this type are produced by the generalized Schur\n* factorization of a complex matrix pair (A,B):\n* \n* A = Q*S*Z**H, B = Q*P*Z**H\n* \n* as computed by CGGHRD + CHGEQZ.\n* \n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal elements of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the unitary factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. The eigenvector corresponding to the j-th\n* eigenvalue is computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) COMPLEX array, dimension (LDS,N)\n* The upper triangular matrix S from a generalized Schur\n* factorization, as computed by CHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) COMPLEX array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by CHGEQZ. P must have real\n* diagonal elements.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) COMPLEX array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q\n* of left Schur vectors returned by CHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n*\n* VR (input/output) COMPLEX array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Z\n* of right Schur vectors returned by CHGEQZ).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Z*X;\n* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VR, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one column.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL array, dimension (2*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 m, info, vl, vr = NumRu::Lapack.ctgevc( side, howmny, select, s, p, vl, vr, [: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_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_s = argv[3];
+ rblapack_p = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_p))
+ rb_raise(rb_eArgError, "p (5th argument) must be NArray");
+ if (NA_RANK(rblapack_p) != 2)
+ rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
+ ldp = NA_SHAPE0(rblapack_p);
+ if (NA_SHAPE1(rblapack_p) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_p) != NA_SCOMPLEX)
+ rblapack_p = na_change_type(rblapack_p, NA_SCOMPLEX);
+ p = NA_PTR_TYPE(rblapack_p, complex*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ mm = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 2)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
+ lds = NA_SHAPE0(rblapack_s);
+ if (NA_SHAPE1(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_s) != NA_SCOMPLEX)
+ rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
+ s = NA_PTR_TYPE(rblapack_s, complex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, complex*);
+ MEMCPY(vl_out__, vl, complex, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, complex*);
+ MEMCPY(vr_out__, vr, complex, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (2*n));
+
+ ctgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_ctgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgevc", rblapack_ctgevc, -1);
+}
diff --git a/ext/ctgex2.c b/ext/ctgex2.c
new file mode 100644
index 0000000..295ff17
--- /dev/null
+++ b/ext/ctgex2.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID ctgex2_(logical* wantq, logical* wantz, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* q, integer* ldq, complex* z, integer* ldz, integer* j1, integer* info);
+
+
+static VALUE
+rblapack_ctgex2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_j1;
+ integer j1;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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, b, q, z = NumRu::Lapack.ctgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n* Purpose\n* =======\n*\n* CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n* in an upper triangular matrix pair (A, B) by an unitary equivalence\n* transformation.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX arrays, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX arrays, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDZ,N)\n* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n* the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n* the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11).\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned.\n*\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n* Department of Computing Science, Umea University, S-901 87 Umea,\n* Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n* Numerical Algorithms, 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.ctgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_ldq = argv[5];
+ rblapack_z = argv[6];
+ rblapack_ldz = argv[7];
+ rblapack_j1 = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ldq = NUM2INT(rblapack_ldq);
+ ldz = NUM2INT(rblapack_ldz);
+ wantz = (rblapack_wantz == Qtrue);
+ j1 = NUM2INT(rblapack_j1);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantq ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantq ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantq ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantq ? n : 0);
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_q) != (wantq ? ldq : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", wantq ? ldq : 0);
+ if (NA_SHAPE1(rblapack_q) != (wantq ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", wantq ? n : 0);
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = wantq ? ldq : 0;
+ shape[1] = wantq ? n : 0;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = wantq ? ldz : 0;
+ shape[1] = wantq ? n : 0;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ ctgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_ctgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgex2", rblapack_ctgex2, -1);
+}
diff --git a/ext/ctgexc.c b/ext/ctgexc.c
new file mode 100644
index 0000000..063d46a
--- /dev/null
+++ b/ext/ctgexc.c
@@ -0,0 +1,172 @@
+#include "rb_lapack.h"
+
+extern VOID ctgexc_(logical* wantq, logical* wantz, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* q, integer* ldq, complex* z, integer* ldz, integer* ifst, integer* ilst, integer* info);
+
+
+static VALUE
+rblapack_ctgexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldz;
+
+ 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, b, q, z, ilst = NumRu::Lapack.ctgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* CTGEXC reorders the generalized Schur decomposition of a complex\n* matrix pair (A,B), using an unitary equivalence transformation\n* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n* row index IFST is moved to row ILST.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the upper triangular matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the upper triangular matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the unitary matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the unitary matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* <0: if INFO = -i, the i-th argument had an illegal value.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\n*\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER HERE\n* ..\n* .. External Subroutines ..\n EXTERNAL CTGEX2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z, ilst = NumRu::Lapack.ctgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_ldq = argv[5];
+ rblapack_z = argv[6];
+ rblapack_ifst = argv[7];
+ rblapack_ilst = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldz)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ ilst = NUM2INT(rblapack_ilst);
+ wantz = (rblapack_wantz == Qtrue);
+ ldq = NUM2INT(rblapack_ldq);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ ifst = NUM2INT(rblapack_ifst);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ ctgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, &info);
+
+ rblapack_info = INT2NUM(info);
+ rblapack_ilst = INT2NUM(ilst);
+ return rb_ary_new3(6, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ilst);
+}
+
+void
+init_lapack_ctgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgexc", rblapack_ctgexc, -1);
+}
diff --git a/ext/ctgsen.c b/ext/ctgsen.c
new file mode 100644
index 0000000..a0e9bab
--- /dev/null
+++ b/ext/ctgsen.c
@@ -0,0 +1,244 @@
+#include "rb_lapack.h"
+
+extern VOID ctgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* q, integer* ldq, complex* z, integer* ldz, integer* m, real* pl, real* pr, real* dif, complex* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_ctgsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_z;
+ complex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_alpha;
+ complex *alpha;
+ VALUE rblapack_beta;
+ complex *beta;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_pl;
+ real pl;
+ VALUE rblapack_pr;
+ real pr;
+ VALUE rblapack_dif;
+ real *dif;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ VALUE rblapack_z_out__;
+ complex *z_out__;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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 alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ctgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTGSEN reorders the generalized Schur decomposition of a complex\n* matrix pair (A, B) (in terms of an unitary equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the pair (A,B). The leading\n* columns of Q and Z form unitary bases of the corresponding left and\n* right eigenspaces (deflating subspaces). (A, B) must be in\n* generalized Schur canonical form, that is, A and B are both upper\n* triangular.\n*\n* CTGSEN also computes the generalized eigenvalues\n*\n* w(j)= ALPHA(j) / BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, the routine computes estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) integer\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select an eigenvalue w(j), SELECT(j) must be set to\n* .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension(LDA,N)\n* On entry, the upper triangular matrix A, in generalized\n* Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, in generalized\n* Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX array, dimension (N)\n* BETA (output) COMPLEX array, dimension (N)\n* The diagonal elements of A and B, respectively,\n* when the pair (A,B) has been reduced to generalized Schur\n* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized\n* eigenvalues.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right\n* eigenspaces, (deflating subspaces) 0 <= M <= N.\n*\n* PL (output) REAL\n* PR (output) REAL\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspace with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3 PL, PR are not referenced.\n*\n* DIF (output) REAL array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl, computed using reversed\n* communication with CLACN2.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\n*\n* WORK (workspace/output) COMPLEX 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, 2 or 4, LWORK >= 2*M*(N-M)\n* If IJOB = 3 or 5, LWORK >= 4*M*(N-M)\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+2;\n* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n*\n\n* Further Details\n* ===============\n*\n* CTGSEN first collects the selected eigenvalues by computing unitary\n* U and W that move them to the top left corner of (A, B). In other\n* words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the conjugate transpose of U. The first\n* n1 columns of U and W span the specified pair of left and right\n* eigenspaces (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see CLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF\n* (IJOB = 2 will be used)). See CTGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ctgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 8 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+ rblapack_ijob = argv[0];
+ rblapack_wantq = argv[1];
+ rblapack_wantz = argv[2];
+ rblapack_select = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 10) {
+ rblapack_lwork = argv[8];
+ rblapack_liwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ wantq = (rblapack_wantq == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, complex*);
+ if (rblapack_liwork == Qnil)
+ liwork = (ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = (ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, complex*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
+ MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ ctgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alpha, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_pl = rb_float_new((double)pl);
+ rblapack_pr = rb_float_new((double)pr);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(13, rblapack_alpha, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_ctgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgsen", rblapack_ctgsen, -1);
+}
diff --git a/ext/ctgsja.c b/ext/ctgsja.c
new file mode 100644
index 0000000..56ce6ea
--- /dev/null
+++ b/ext/ctgsja.c
@@ -0,0 +1,227 @@
+#include "rb_lapack.h"
+
+extern VOID ctgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, complex* a, integer* lda, complex* b, integer* ldb, real* tola, real* tolb, real* alpha, real* beta, complex* u, integer* ldu, complex* v, integer* ldv, complex* q, integer* ldq, complex* work, integer* ncycle, integer* info);
+
+
+static VALUE
+rblapack_ctgsja(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_tola;
+ real tola;
+ VALUE rblapack_tolb;
+ real tolb;
+ VALUE rblapack_u;
+ complex *u;
+ VALUE rblapack_v;
+ complex *v;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_alpha;
+ real *alpha;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_ncycle;
+ integer ncycle;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+ VALUE rblapack_u_out__;
+ complex *u_out__;
+ VALUE rblapack_v_out__;
+ complex *v_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ctgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* CTGSJA computes the generalized singular value decomposition (GSVD)\n* of two complex upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine CGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are unitary matrices, Z' denotes the conjugate\n* transpose of Z, R is a nonsingular upper triangular matrix, and D1\n* and D2 are ``diagonal'' matrices, which are of the following\n* structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the unitary transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain a unitary matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* unitary matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain a unitary matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* unitary matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain a unitary matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by CTGSJA.\n* See Further Details.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) COMPLEX array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the unitary matrix returned by CGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the unitary matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) COMPLEX array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the unitary matrix returned by CGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the unitary matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the unitary matrix returned by CGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the unitary matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n* transpose of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ctgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_k = argv[3];
+ rblapack_l = argv[4];
+ rblapack_a = argv[5];
+ rblapack_b = argv[6];
+ rblapack_tola = argv[7];
+ rblapack_tolb = argv[8];
+ rblapack_u = argv[9];
+ rblapack_v = argv[10];
+ rblapack_q = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ tolb = (real)NUM2DBL(rblapack_tolb);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ p = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, complex*);
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ m = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_SCOMPLEX)
+ rblapack_u = na_change_type(rblapack_u, NA_SCOMPLEX);
+ u = NA_PTR_TYPE(rblapack_u, complex*);
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (12th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ tola = (real)NUM2DBL(rblapack_tola);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, complex*);
+ MEMCPY(u_out__, u, complex, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
+ MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(complex, (2*n));
+
+ ctgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
+
+ free(work);
+ rblapack_ncycle = INT2NUM(ncycle);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
+}
+
+void
+init_lapack_ctgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgsja", rblapack_ctgsja, -1);
+}
diff --git a/ext/ctgsna.c b/ext/ctgsna.c
new file mode 100644
index 0000000..a48725e
--- /dev/null
+++ b/ext/ctgsna.c
@@ -0,0 +1,164 @@
+#include "rb_lapack.h"
+
+extern VOID ctgsna_(char* job, char* howmny, logical* select, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* vl, integer* ldvl, complex* vr, integer* ldvr, real* s, real* dif, integer* mm, integer* m, complex* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ctgsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_dif;
+ real *dif;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ integer *iwork;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+
+ 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 s, dif, m, work, info = NumRu::Lapack.ctgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B).\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the corresponding j-th eigenvalue and/or eigenvector,\n* SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The upper triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A, B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) COMPLEX array, dimension (LDVL,M)\n* IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by CTGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; and\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX array, dimension (LDVR,M)\n* IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VR, as returned by CTGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1;\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array.\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If the eigenvalues cannot be reordered to compute DIF(j),\n* DIF(j) is set to 0; this can only occur when the true value\n* would be very small anyway.\n* For each eigenvalue/vector specified by SELECT, DIF stores\n* a Frobenius norm-based estimate of Difl.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected eigenvalue\n* one element is used. If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n* eigenvalue w = (a, b) is defined as\n*\n* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u. The pair\n* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n* matrix pair (A, B). If both a and b equal zero, then (A,B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows. Suppose\n*\n* (A, B) = ( a * ) ( b * ) 1\n* ( 0 A22 ),( 0 B22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(I) is\n*\n* Difl[(a, b), (A22, B22)] = sigma-min( Zl )\n*\n* where sigma-min(Zl) denotes the smallest singular value of\n*\n* Zl = [ kron(a, In-1) -kron(1, A22) ]\n* [ kron(b, In-1) -kron(1, B22) ].\n*\n* Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n* transpose of X. kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* We approximate the smallest singular value of Zl with an upper\n* bound. This is done by CLATDF.\n*\n* An approximate error bound for a computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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.\n* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.ctgsna( job, howmny, select, a, b, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ m = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ mm = 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 select");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n+2));
+
+ ctgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
+}
+
+void
+init_lapack_ctgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgsna", rblapack_ctgsna, -1);
+}
diff --git a/ext/ctgsy2.c b/ext/ctgsy2.c
new file mode 100644
index 0000000..0455996
--- /dev/null
+++ b/ext/ctgsy2.c
@@ -0,0 +1,176 @@
+#include "rb_lapack.h"
+
+extern VOID ctgsy2_(char* trans, integer* ijob, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, complex* d, integer* ldd, complex* e, integer* lde, complex* f, integer* ldf, real* scale, real* rdsum, real* rdscal, integer* info);
+
+
+static VALUE
+rblapack_ctgsy2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_f;
+ complex *f;
+ VALUE rblapack_rdsum;
+ real rdsum;
+ VALUE rblapack_rdscal;
+ real rdscal;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ VALUE rblapack_f_out__;
+ complex *f_out__;
+
+ 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, info, c, f, rdsum, rdscal = NumRu::Lapack.ctgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n* Purpose\n* =======\n*\n* CTGSY2 solves the generalized Sylvester equation\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F\n*\n* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n* (i.e., (A,D) and (B,E) in generalized Schur form).\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 solving equation (1) corresponds to solve\n* Zx = scale * b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n* is solved for, 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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* = sigma_min(Z) using reverse communicaton with CLACON.\n*\n* CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n* CTGSYL.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* =2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (SGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) COMPLEX array, dimension (LDA, M)\n* On entry, A contains an upper triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) COMPLEX array, dimension (LDB, N)\n* On entry, B contains an upper triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1, N).\n*\n* C (input/output) COMPLEX array, dimension (LDC, N)\n* On entry, C contains the right-hand-side of the first matrix\n* equation in (1).\n* On exit, if IJOB = 0, C has been overwritten by the solution\n* R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) COMPLEX array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) COMPLEX array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix E. LDE >= max(1, N).\n*\n* F (input/output) COMPLEX array, dimension (LDF, N)\n* On entry, F contains the right-hand-side of the second matrix\n* equation in (1).\n* On exit, if IJOB = 0, F has been overwritten by the solution\n* L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) REAL\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0.\n* Normally, SCALE = 1.\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by CTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when CTGSY2 is called by\n* CTGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when CTGSY2 is called by\n* CTGSYL.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, input argument number i is illegal.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ctgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", 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];
+ rblapack_rdsum = argv[8];
+ rblapack_rdscal = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ rdsum = (real)NUM2DBL(rblapack_rdsum);
+ 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ rdscal = (real)NUM2DBL(rblapack_rdscal);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_f = na_change_type(rblapack_f, NA_SCOMPLEX);
+ f = NA_PTR_TYPE(rblapack_f, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = n;
+ rblapack_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, complex*);
+ MEMCPY(f_out__, f, complex, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+
+ ctgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(6, rblapack_scale, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_ctgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgsy2", rblapack_ctgsy2, -1);
+}
diff --git a/ext/ctgsyl.c b/ext/ctgsyl.c
new file mode 100644
index 0000000..57e6b44
--- /dev/null
+++ b/ext/ctgsyl.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID ctgsyl_(char* trans, integer* ijob, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, complex* d, integer* ldd, complex* e, integer* lde, complex* f, integer* ldf, real* scale, real* dif, complex* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ctgsyl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_d;
+ complex *d;
+ VALUE rblapack_e;
+ complex *e;
+ VALUE rblapack_f;
+ complex *f;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_dif;
+ real dif;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ VALUE rblapack_f_out__;
+ complex *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.ctgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTGSYL( 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* CTGSYL 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 complex entries. A, B, D and E are upper\n* triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n* is an output scaling factor chosen to avoid overflow.\n*\n* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n* is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Here Ix is the identity matrix of size x and X' is the conjugate\n* transpose of X. Kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n* is solved for, 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 = 'C') 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 CLACON.\n*\n* If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of\n* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n* reciprocal of the smallest singular value of Z.\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* = 'C': solve the \"conjugate 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 is used).\n* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n* (CGECON on sub-systems is used).\n* Not referenced if TRANS = 'C'.\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) COMPLEX array, dimension (LDA, M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, M).\n*\n* B (input) COMPLEX array, dimension (LDB, N)\n* The upper 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) COMPLEX 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) COMPLEX 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) COMPLEX 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) COMPLEX 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 = 'C', DIF is not referenced.\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,\n* D and E have not been changed. If SCALE = 0, R and L will\n* hold the solutions to the homogenious system with C = F = 0.\n*\n* WORK (workspace/output) COMPLEX 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+2)\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 very close\n* 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 CCOPY by calls to CLASET.\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.ctgsyl( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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_SCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, complex*);
+ 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_SCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, complex*);
+ 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_f = na_change_type(rblapack_f, NA_SCOMPLEX);
+ f = NA_PTR_TYPE(rblapack_f, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = n;
+ rblapack_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, complex*);
+ MEMCPY(f_out__, f, complex, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+ iwork = ALLOC_N(integer, (m+n+2));
+
+ ctgsyl_(&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_ctgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctgsyl", rblapack_ctgsyl, -1);
+}
diff --git a/ext/ctpcon.c b/ext/ctpcon.c
new file mode 100644
index 0000000..f39f349
--- /dev/null
+++ b/ext/ctpcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ctpcon_(char* norm, char* uplo, char* diag, integer* n, complex* ap, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctpcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ 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.ctpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTPCON 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.ctpcon( 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ ctpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_ctpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctpcon", rblapack_ctpcon, -1);
+}
diff --git a/ext/ctprfs.c b/ext/ctprfs.c
new file mode 100644
index 0000000..63c6a27
--- /dev/null
+++ b/ext/ctprfs.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID ctprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ 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.ctprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTPRFS 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 CTPTRS or some other\n* means before entering this routine. CTPRFS 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)\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) COMPLEX 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* B (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.ctprfs( 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ 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*);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ ctprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
+}
+
+void
+init_lapack_ctprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctprfs", rblapack_ctprfs, -1);
+}
diff --git a/ext/ctptri.c b/ext/ctptri.c
new file mode 100644
index 0000000..d231886
--- /dev/null
+++ b/ext/ctptri.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ctptri_(char* uplo, char* diag, integer* n, complex* ap, integer* info);
+
+
+static VALUE
+rblapack_ctptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ complex *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.ctptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* CTPTRI computes the inverse of a complex 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) COMPLEX 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.ctptri( 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
+ MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ ctptri_(&uplo, &diag, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_ctptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctptri", rblapack_ctptri, -1);
+}
diff --git a/ext/ctptrs.c b/ext/ctptrs.c
new file mode 100644
index 0000000..72961ae
--- /dev/null
+++ b/ext/ctptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID ctptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ctptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ctptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CTPTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* AP (input) COMPLEX 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*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ctptrs( uplo, trans, diag, n, ap, b, [: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_n = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_b = 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 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ n = NUM2INT(rblapack_n);
+ 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) != (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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ctptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ctptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctptrs", rblapack_ctptrs, -1);
+}
diff --git a/ext/ctpttf.c b/ext/ctpttf.c
new file mode 100644
index 0000000..36a7a55
--- /dev/null
+++ b/ext/ctpttf.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID ctpttf_(char* transr, char* uplo, integer* n, complex* ap, complex* arf, integer* info);
+
+
+static VALUE
+rblapack_ctpttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_arf;
+ complex *arf;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 arf, info = NumRu::Lapack.ctpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* CTPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'C': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ctpttf( transr, uplo, 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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_arf = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, complex*);
+
+ ctpttf_(&transr, &uplo, &n, ap, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_ctpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctpttf", rblapack_ctpttf, -1);
+}
diff --git a/ext/ctpttr.c b/ext/ctpttr.c
new file mode 100644
index 0000000..68700b0
--- /dev/null
+++ b/ext/ctpttr.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID ctpttr_(char* uplo, integer* n, complex* ap, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ctpttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldap;
+ 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 a, info = NumRu::Lapack.ctpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) COMPLEX array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -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 a, info = NumRu::Lapack.ctpttr( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+
+ ctpttr_(&uplo, &n, ap, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_ctpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctpttr", rblapack_ctpttr, -1);
+}
diff --git a/ext/ctrcon.c b/ext/ctrcon.c
new file mode 100644
index 0000000..ba6c5a4
--- /dev/null
+++ b/ext/ctrcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ctrcon_(char* norm, char* uplo, char* diag, integer* n, complex* a, integer* lda, real* rcond, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctrcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ 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 rcond, info = NumRu::Lapack.ctrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRCON estimates the reciprocal of the condition number of a\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* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.ctrcon( norm, uplo, diag, a, [: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_a = 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_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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ ctrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_ctrcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrcon", rblapack_ctrcon, -1);
+}
diff --git a/ext/ctrevc.c b/ext/ctrevc.c
new file mode 100644
index 0000000..b1aec98
--- /dev/null
+++ b/ext/ctrevc.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID ctrevc_(char* side, char* howmny, logical* select, integer* n, complex* t, integer* ldt, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* mm, integer* m, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctrevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ complex *t_out__;
+ VALUE rblapack_vl_out__;
+ complex *vl_out__;
+ VALUE rblapack_vr_out__;
+ complex *vr_out__;
+ complex *work;
+ real *rwork;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, t, vl, vr = NumRu::Lapack.ctrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTREVC computes some or all of the right and/or left eigenvectors of\n* a complex upper triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of the vector y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the unitary factor that reduces a matrix A to\n* Schur form T, then Q*X and Q*Y are the matrices of right and left\n* eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed using the matrices supplied in\n* VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* The eigenvector corresponding to the j-th eigenvalue is\n* computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX array, dimension (LDT,N)\n* The upper triangular matrix T. T is modified, but restored\n* on exit.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) COMPLEX array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by CHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) COMPLEX array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by CHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B'; LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one\n* column.\n*\n* WORK (workspace) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, info, t, vl, vr = NumRu::Lapack.ctrevc( side, howmny, select, t, vl, vr, [: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_side = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ mm = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
+ MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, complex*);
+ MEMCPY(vl_out__, vl, complex, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, complex*);
+ MEMCPY(vr_out__, vr, complex, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ ctrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_t, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_ctrevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrevc", rblapack_ctrevc, -1);
+}
diff --git a/ext/ctrexc.c b/ext/ctrexc.c
new file mode 100644
index 0000000..f2aaa72
--- /dev/null
+++ b/ext/ctrexc.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID ctrexc_(char* compq, integer* n, complex* t, integer* ldt, complex* q, integer* ldq, integer* ifst, integer* ilst, integer* info);
+
+
+static VALUE
+rblapack_ctrexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ complex *t_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+
+ integer ldt;
+ integer n;
+ integer ldq;
+
+ 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, t, q = NumRu::Lapack.ctrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* CTREXC reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n* is moved to row ILST.\n*\n* The Schur form T is reordered by a unitary similarity transformation\n* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n* postmultplying it with Z.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, the reordered upper triangular matrix.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input) INTEGER\n* ILST (input) INTEGER\n* Specify the reordering of the diagonal elements of T:\n* The element with row index IFST is moved to row ILST by a\n* sequence of transpositions between adjacent elements.\n* 1 <= IFST <= N; 1 <= ILST <= 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* .. Local Scalars ..\n LOGICAL WANTQ\n INTEGER K, M1, M2, M3\n REAL CS\n COMPLEX SN, T11, T22, TEMP\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLARTG, CROT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.ctrexc( compq, t, q, ifst, ilst, [: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_compq = argv[0];
+ rblapack_t = argv[1];
+ rblapack_q = argv[2];
+ rblapack_ifst = argv[3];
+ rblapack_ilst = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ ilst = NUM2INT(rblapack_ilst);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (2th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ ifst = NUM2INT(rblapack_ifst);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
+ MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+
+ ctrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_ctrexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrexc", rblapack_ctrexc, -1);
+}
diff --git a/ext/ctrrfs.c b/ext/ctrrfs.c
new file mode 100644
index 0000000..5409c4a
--- /dev/null
+++ b/ext/ctrrfs.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID ctrrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctrrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_x;
+ complex *x;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ integer lda;
+ 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 = NumRu::Lapack.ctrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by CTRTRS or some other\n* means before entering this routine. CTRRFS 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)\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* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX 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) COMPLEX 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) COMPLEX array, dimension (2*N)\n*\n* RWORK (workspace) REAL 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.ctrrfs( uplo, trans, diag, a, 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_a = 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ 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_SCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, complex*);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ 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*);
+ work = ALLOC_N(complex, (2*n));
+ rwork = ALLOC_N(real, (n));
+
+ ctrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
+}
+
+void
+init_lapack_ctrrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrrfs", rblapack_ctrrfs, -1);
+}
diff --git a/ext/ctrsen.c b/ext/ctrsen.c
new file mode 100644
index 0000000..f77cc9a
--- /dev/null
+++ b/ext/ctrsen.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID ctrsen_(char* job, char* compq, logical* select, integer* n, complex* t, integer* ldt, complex* q, integer* ldq, complex* w, integer* m, real* s, real* sep, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ctrsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ complex *w;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_s;
+ real s;
+ VALUE rblapack_sep;
+ real sep;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ complex *t_out__;
+ VALUE rblapack_q_out__;
+ complex *q_out__;
+
+ integer n;
+ integer ldt;
+ integer ldq;
+
+ 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 w, m, s, sep, work, info, t, q = NumRu::Lapack.ctrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRSEN reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n* the leading positions on the diagonal of the upper triangular matrix\n* T, and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, T is overwritten by the reordered matrix T, with the\n* selected eigenvalues as the leading diagonal elements.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix which reorders T; the leading M\n* columns of Q form an orthonormal basis for the specified\n* invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* W (output) COMPLEX array, dimension (N)\n* The reordered eigenvalues of T, in the same order as they\n* appear on the diagonal of T.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 <= M <= N.\n*\n* S (output) REAL\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) REAL\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\n*\n* WORK (workspace/output) COMPLEX 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.\n* If JOB = 'N', LWORK >= 1;\n* if JOB = 'E', LWORK = max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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* CTRSEN first collects the selected eigenvalues by computing a unitary\n* transformation Z to move them to the top left corner of T. In other\n* words, the selected eigenvalues are the eigenvalues of T11 in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n* n1 columns of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the Schur factorization of a matrix\n* A = Q*T*Q', then the reordered Schur factorization of A is given by\n* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n* corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, m, s, sep, work, info, t, q = NumRu::Lapack.ctrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
+ MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
+ MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+
+ ctrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, w, &m, &s, &sep, work, &lwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_sep = rb_float_new((double)sep);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_w, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_ctrsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrsen", rblapack_ctrsen, -1);
+}
diff --git a/ext/ctrsna.c b/ext/ctrsna.c
new file mode 100644
index 0000000..f940052
--- /dev/null
+++ b/ext/ctrsna.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID ctrsna_(char* job, char* howmny, logical* select, integer* n, complex* t, integer* ldt, complex* vl, integer* ldvl, complex* vr, integer* ldvr, real* s, real* sep, integer* mm, integer* m, complex* work, integer* ldwork, real* rwork, integer* info);
+
+
+static VALUE
+rblapack_ctrsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ complex *t;
+ VALUE rblapack_vl;
+ complex *vl;
+ VALUE rblapack_vr;
+ complex *vr;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_sep;
+ real *sep;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+ integer ldwork;
+
+ 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 s, sep, m, info = NumRu::Lapack.ctrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a complex upper triangular\n* matrix T (or of any matrix Q*T*Q**H with Q unitary).\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) COMPLEX array, dimension (LDT,N)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) COMPLEX array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* CHSEIN or CTREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* CHSEIN or CTREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n* all correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) COMPLEX array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* RWORK (workspace) REAL array, dimension (N)\n* If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.ctrsna( job, howmny, select, t, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ m = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, complex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, complex*);
+ mm = m;
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, complex*);
+ ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sep = NA_PTR_TYPE(rblapack_sep, real*);
+ work = ALLOC_N(complex, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
+ rwork = ALLOC_N(real, (lsame_(&job,"E") ? 0 : n));
+
+ ctrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
+}
+
+void
+init_lapack_ctrsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrsna", rblapack_ctrsna, -1);
+}
diff --git a/ext/ctrsyl.c b/ext/ctrsyl.c
new file mode 100644
index 0000000..22e84df
--- /dev/null
+++ b/ext/ctrsyl.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID ctrsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, real* scale, integer* info);
+
+
+static VALUE
+rblapack_ctrsyl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trana;
+ char trana;
+ VALUE rblapack_tranb;
+ char tranb;
+ VALUE rblapack_isgn;
+ integer isgn;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ 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 scale, info, c = NumRu::Lapack.ctrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* CTRSYL solves the complex Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**H, and A and B are both upper triangular. A is\n* M-by-M and B is N-by-N; the right hand side C and the solution X are\n* M-by-N; and scale is an output scale factor, set <= 1 to avoid\n* overflow in X.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'C': op(A) = A**H (Conjugate transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'C': op(B) = B**H (Conjugate transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input) COMPLEX array, dimension (LDB,N)\n* The upper 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) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) REAL\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.ctrsyl( trana, tranb, isgn, a, b, c, [: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_trana = argv[0];
+ rblapack_tranb = argv[1];
+ rblapack_isgn = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trana = StringValueCStr(rblapack_trana)[0];
+ isgn = NUM2INT(rblapack_isgn);
+ 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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ tranb = StringValueCStr(rblapack_tranb)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ if (NA_SHAPE1(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ ctrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_ctrsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrsyl", rblapack_ctrsyl, -1);
+}
diff --git a/ext/ctrti2.c b/ext/ctrti2.c
new file mode 100644
index 0000000..87088e2
--- /dev/null
+++ b/ext/ctrti2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID ctrti2_(char* uplo, char* diag, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ctrti2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.ctrti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTRTI2 computes the inverse of a complex upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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.ctrti2( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ ctrti2_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ctrti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrti2", rblapack_ctrti2, -1);
+}
diff --git a/ext/ctrtri.c b/ext/ctrtri.c
new file mode 100644
index 0000000..11f6fc4
--- /dev/null
+++ b/ext/ctrtri.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID ctrtri_(char* uplo, char* diag, integer* n, complex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ctrtri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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.ctrtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* CTRTRI computes the inverse of a complex upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ctrtri( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ ctrtri_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ctrtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrtri", rblapack_ctrtri, -1);
+}
diff --git a/ext/ctrtrs.c b/ext/ctrtrs.c
new file mode 100644
index 0000000..460d422
--- /dev/null
+++ b/ext/ctrtrs.c
@@ -0,0 +1,99 @@
+#include "rb_lapack.h"
+
+extern VOID ctrtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ctrtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_b;
+ complex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ complex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ctrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* CTRTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ctrtrs( uplo, trans, diag, a, b, [: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_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } 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_SCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
+ MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ctrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ctrtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrtrs", rblapack_ctrtrs, -1);
+}
diff --git a/ext/ctrttf.c b/ext/ctrttf.c
new file mode 100644
index 0000000..3b8bf77
--- /dev/null
+++ b/ext/ctrttf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID ctrttf_(char* transr, char* uplo, integer* n, complex* a, integer* lda, doublecomplex* arf, integer* info);
+
+
+static VALUE
+rblapack_ctrttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_arf;
+ doublecomplex *arf;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 arf, info = NumRu::Lapack.ctrttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* CTRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal mode is wanted;\n* = 'C': ARF in Conjugate Transpose mode is wanted;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX array, dimension ( LDA, N ) \n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ctrttf( transr, uplo, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);
+
+ ctrttf_(&transr, &uplo, &n, a, &lda, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_ctrttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrttf", rblapack_ctrttf, -1);
+}
diff --git a/ext/ctrttp.c b/ext/ctrttp.c
new file mode 100644
index 0000000..cfb293a
--- /dev/null
+++ b/ext/ctrttp.c
@@ -0,0 +1,73 @@
+#include "rb_lapack.h"
+
+extern VOID ctrttp_(char* uplo, integer* n, complex* a, integer* lda, complex* ap, integer* info);
+
+
+static VALUE
+rblapack_ctrttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 ap, info = NumRu::Lapack.ctrttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* CTRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* On entry, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 ap, info = NumRu::Lapack.ctrttp( 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_ap = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+
+ ctrttp_(&uplo, &n, a, &lda, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_ctrttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctrttp", rblapack_ctrttp, -1);
+}
diff --git a/ext/ctzrqf.c b/ext/ctzrqf.c
new file mode 100644
index 0000000..db51c87
--- /dev/null
+++ b/ext/ctzrqf.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID ctzrqf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, integer* info);
+
+
+static VALUE
+rblapack_ctzrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.ctzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine CTZRZF.\n*\n* CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), whose conjugate transpose is used to\n* introduce zeros into the (m - k + 1)th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.ctzrqf( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ ctzrqf_(&m, &n, a, &lda, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ctzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctzrqf", rblapack_ctzrqf, -1);
+}
diff --git a/ext/ctzrzf.c b/ext/ctzrzf.c
new file mode 100644
index 0000000..752e627
--- /dev/null
+++ b/ext/ctzrzf.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID ctzrzf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ctzrzf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.ctzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.ctzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 2)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 2) {
+ rblapack_lwork = argv[1];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ ctzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ctzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ctzrzf", rblapack_ctzrzf, -1);
+}
diff --git a/ext/cunbdb.c b/ext/cunbdb.c
new file mode 100644
index 0000000..21d88e4
--- /dev/null
+++ b/ext/cunbdb.c
@@ -0,0 +1,232 @@
+#include "rb_lapack.h"
+
+extern VOID cunbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, complex* x11, integer* ldx11, complex* x12, integer* ldx12, complex* x21, integer* ldx21, complex* x22, integer* ldx22, real* theta, real* phi, complex* taup1, complex* taup2, complex* tauq1, complex* tauq2, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunbdb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_signs;
+ char signs;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x11;
+ complex *x11;
+ VALUE rblapack_x12;
+ complex *x12;
+ VALUE rblapack_x21;
+ complex *x21;
+ VALUE rblapack_x22;
+ complex *x22;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_theta;
+ real *theta;
+ VALUE rblapack_phi;
+ real *phi;
+ VALUE rblapack_taup1;
+ complex *taup1;
+ VALUE rblapack_taup2;
+ complex *taup2;
+ VALUE rblapack_tauq1;
+ complex *tauq1;
+ VALUE rblapack_tauq2;
+ complex *tauq2;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x11_out__;
+ complex *x11_out__;
+ VALUE rblapack_x12_out__;
+ complex *x12_out__;
+ VALUE rblapack_x21_out__;
+ complex *x21_out__;
+ VALUE rblapack_x22_out__;
+ complex *x22_out__;
+ complex *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.cunbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNBDB( 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* CUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n* partitioned unitary matrix X:\n*\n* [ B11 | B12 0 0 ]\n* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H\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 CUNCSD\n* for details.)\n*\n* The unitary 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) COMPLEX array, dimension (LDX11,Q)\n* On entry, the top-left block of the unitary 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) CMPLX array, dimension (LDX12,M-Q)\n* On entry, the top-right block of the unitary 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) COMPLEX array, dimension (LDX21,Q)\n* On entry, the bottom-left block of the unitary 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) COMPLEX array, dimension (LDX22,M-Q)\n* On entry, the bottom-right block of the unitary 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) REAL 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) REAL 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) COMPLEX array, dimension (P)\n* The scalar factors of the elementary reflectors that define\n* P1.\n*\n* TAUP2 (output) COMPLEX array, dimension (M-P)\n* The scalar factors of the elementary reflectors that define\n* P2.\n*\n* TAUQ1 (output) COMPLEX array, dimension (Q)\n* The scalar factors of the elementary reflectors that define\n* Q1.\n*\n* TAUQ2 (output) COMPLEX array, dimension (M-Q)\n* The scalar factors of the elementary reflectors that define\n* Q2.\n*\n* WORK (workspace) COMPLEX 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 CUNCSD for details.\n*\n* P1, P2, Q1, and Q2 are represented as products of elementary\n* reflectors. See CUNCSD for details on generating P1, P2, Q1, and Q2\n* using CUNGQR and CUNGLQ.\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.cunbdb( 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_SCOMPLEX)
+ rblapack_x11 = na_change_type(rblapack_x11, NA_SCOMPLEX);
+ x11 = NA_PTR_TYPE(rblapack_x11, complex*);
+ 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_SCOMPLEX)
+ rblapack_x21 = na_change_type(rblapack_x21, NA_SCOMPLEX);
+ x21 = NA_PTR_TYPE(rblapack_x21, complex*);
+ 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_SCOMPLEX)
+ rblapack_x22 = na_change_type(rblapack_x22, NA_SCOMPLEX);
+ x22 = NA_PTR_TYPE(rblapack_x22, complex*);
+ 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_SCOMPLEX)
+ rblapack_x12 = na_change_type(rblapack_x12, NA_SCOMPLEX);
+ x12 = NA_PTR_TYPE(rblapack_x12, complex*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ phi = NA_PTR_TYPE(rblapack_phi, real*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_taup1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taup1 = NA_PTR_TYPE(rblapack_taup1, complex*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_taup2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ taup2 = NA_PTR_TYPE(rblapack_taup2, complex*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_tauq1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tauq1 = NA_PTR_TYPE(rblapack_tauq1, complex*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_tauq2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ tauq2 = NA_PTR_TYPE(rblapack_tauq2, complex*);
+ {
+ int shape[2];
+ shape[0] = ldx11;
+ shape[1] = q;
+ rblapack_x11_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, complex*);
+ MEMCPY(x11_out__, x11, complex, NA_TOTAL(rblapack_x11));
+ rblapack_x11 = rblapack_x11_out__;
+ x11 = x11_out__;
+ {
+ int shape[2];
+ shape[0] = ldx12;
+ shape[1] = m-q;
+ rblapack_x12_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, complex*);
+ MEMCPY(x12_out__, x12, complex, NA_TOTAL(rblapack_x12));
+ rblapack_x12 = rblapack_x12_out__;
+ x12 = x12_out__;
+ {
+ int shape[2];
+ shape[0] = ldx21;
+ shape[1] = q;
+ rblapack_x21_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, complex*);
+ MEMCPY(x21_out__, x21, complex, NA_TOTAL(rblapack_x21));
+ rblapack_x21 = rblapack_x21_out__;
+ x21 = x21_out__;
+ {
+ int shape[2];
+ shape[0] = ldx22;
+ shape[1] = m-q;
+ rblapack_x22_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, complex*);
+ MEMCPY(x22_out__, x22, complex, NA_TOTAL(rblapack_x22));
+ rblapack_x22 = rblapack_x22_out__;
+ x22 = x22_out__;
+ work = ALLOC_N(complex, (MAX(1,lwork)));
+
+ cunbdb_(&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_cunbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunbdb", rblapack_cunbdb, -1);
+}
diff --git a/ext/cuncsd.c b/ext/cuncsd.c
new file mode 100644
index 0000000..6d191bd
--- /dev/null
+++ b/ext/cuncsd.c
@@ -0,0 +1,204 @@
+#include "rb_lapack.h"
+
+extern VOID cuncsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, char* signs, integer* m, integer* p, integer* q, complex* x11, integer* ldx11, complex* x12, integer* ldx12, complex* x21, integer* ldx21, complex* x22, integer* ldx22, real* theta, complex* u1, integer* ldu1, complex* u2, integer* ldu2, complex* v1t, integer* ldv1t, complex* v2t, integer* ldv2t, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_cuncsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_signs;
+ char signs;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x11;
+ complex *x11;
+ VALUE rblapack_x12;
+ complex *x12;
+ VALUE rblapack_x21;
+ complex *x21;
+ VALUE rblapack_x22;
+ complex *x22;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_theta;
+ real *theta;
+ VALUE rblapack_u1;
+ complex *u1;
+ VALUE rblapack_u2;
+ complex *u2;
+ VALUE rblapack_v1t;
+ complex *v1t;
+ VALUE rblapack_v2t;
+ complex *v2t;
+ VALUE rblapack_info;
+ integer info;
+ complex *work;
+ real *rwork;
+ integer *iwork;
+
+ integer p;
+ integer q;
+ integer ldv2t;
+ integer ldv1t;
+ integer ldu1;
+ integer ldu2;
+ integer ldx11;
+ integer ldx12;
+ integer ldx21;
+ integer ldx22;
+
+ 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, u1, u2, v1t, v2t, info = NumRu::Lapack.cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNCSD computes the CS decomposition of an M-by-M partitioned\n* unitary matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) COMPLEX array, dimension (LDX,M)\n* On entry, the unitary matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) REAL array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) COMPLEX array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) COMPLEX array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) COMPLEX array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n* matrix V1**H.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) COMPLEX array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n* matrix V2**H.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) COMPLEX 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.\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* RWORK (workspace) REAL array, dimension MAX(1,LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n* If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n*\n* If LRWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the RWORK array, returns\n* this value as the first entry of the work array, and no error\n* message related to LRWORK is issued by XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (M-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: CBBCSD did not converge. See the description of RWORK\n* above for details.\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\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_signs = argv[5];
+ rblapack_m = argv[6];
+ rblapack_x11 = argv[7];
+ rblapack_x12 = argv[8];
+ rblapack_x21 = argv[9];
+ rblapack_x22 = argv[10];
+ rblapack_lwork = argv[11];
+ rblapack_lrwork = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_x21))
+ rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_x21) != 2)
+ rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
+ p = NA_SHAPE0(rblapack_x21);
+ q = NA_SHAPE1(rblapack_x21);
+ if (NA_TYPE(rblapack_x21) != NA_SCOMPLEX)
+ rblapack_x21 = na_change_type(rblapack_x21, NA_SCOMPLEX);
+ x21 = NA_PTR_TYPE(rblapack_x21, complex*);
+ lwork = NUM2INT(rblapack_lwork);
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ signs = StringValueCStr(rblapack_signs)[0];
+ lrwork = NUM2INT(rblapack_lrwork);
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_x11))
+ rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x11) != 2)
+ rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_x11) != p)
+ rb_raise(rb_eRuntimeError, "shape 0 of x11 must be the same as shape 0 of x21");
+ if (NA_SHAPE1(rblapack_x11) != q)
+ rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
+ if (NA_TYPE(rblapack_x11) != NA_SCOMPLEX)
+ rblapack_x11 = na_change_type(rblapack_x11, NA_SCOMPLEX);
+ x11 = NA_PTR_TYPE(rblapack_x11, complex*);
+ if (!NA_IsNArray(rblapack_x22))
+ rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
+ if (NA_RANK(rblapack_x22) != 2)
+ rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_x22) != p)
+ rb_raise(rb_eRuntimeError, "shape 0 of x22 must be the same as shape 0 of x21");
+ 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_SCOMPLEX)
+ rblapack_x22 = na_change_type(rblapack_x22, NA_SCOMPLEX);
+ x22 = NA_PTR_TYPE(rblapack_x22, complex*);
+ ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
+ if (!NA_IsNArray(rblapack_x12))
+ rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x12) != 2)
+ rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_x12) != p)
+ rb_raise(rb_eRuntimeError, "shape 0 of x12 must be the same as shape 0 of x21");
+ 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_SCOMPLEX)
+ rblapack_x12 = na_change_type(rblapack_x12, NA_SCOMPLEX);
+ x12 = NA_PTR_TYPE(rblapack_x12, complex*);
+ ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
+ ldx11 = p;
+ ldx21 = p;
+ ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
+ ldx12 = p;
+ ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
+ ldx22 = p;
+ {
+ int shape[1];
+ shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
+ rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, real*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_u1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ u1 = NA_PTR_TYPE(rblapack_u1, complex*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_u2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ u2 = NA_PTR_TYPE(rblapack_u2, complex*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_v1t = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ v1t = NA_PTR_TYPE(rblapack_v1t, complex*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_v2t = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ v2t = NA_PTR_TYPE(rblapack_v2t, complex*);
+ work = ALLOC_N(complex, (MAX(1,lwork)));
+ rwork = ALLOC_N(real, (MAX(1,lrwork)));
+ iwork = ALLOC_N(integer, (m-q));
+
+ cuncsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, rwork, &lrwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
+}
+
+void
+init_lapack_cuncsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cuncsd", rblapack_cuncsd, -1);
+}
diff --git a/ext/cung2l.c b/ext/cung2l.c
new file mode 100644
index 0000000..71cd904
--- /dev/null
+++ b/ext/cung2l.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID cung2l_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cung2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.cung2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNG2L generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.cung2l( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n));
+
+ cung2l_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cung2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cung2l", rblapack_cung2l, -1);
+}
diff --git a/ext/cung2r.c b/ext/cung2r.c
new file mode 100644
index 0000000..51e9236
--- /dev/null
+++ b/ext/cung2r.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID cung2r_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cung2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.cung2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNG2R generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* WORK (workspace) COMPLEX array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.cung2r( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (n));
+
+ cung2r_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cung2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cung2r", rblapack_cung2r, -1);
+}
diff --git a/ext/cungbr.c b/ext/cungbr.c
new file mode 100644
index 0000000..ebd0f84
--- /dev/null
+++ b/ext/cungbr.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID cungbr_(char* vect, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cungbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 work, info, a = NumRu::Lapack.cungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGBR generates one of the complex unitary matrices Q or P**H\n* determined by CGEBRD when reducing a complex matrix A to bidiagonal\n* form: A = Q * B * P**H. Q and P**H are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and CUNGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n* is of order N:\n* if k < n, P**H = G(k) . . . G(2) G(1) and CUNGBR returns the first m\n* rows of P**H, where n >= m >= k;\n* if k >= n, P**H = G(n-1) . . . G(2) G(1) and CUNGBR returns P**H as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**H is\n* required, as defined in the transformation applied by CGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**H to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**H to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by CGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by CGEBRD.\n* K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by CGEBRD.\n* On exit, the M-by-N matrix Q or P**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= M.\n*\n* TAU (input) COMPLEX array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**H, as\n* returned by CGEBRD in its array argument TAUQ or TAUP.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_m = argv[1];
+ rblapack_k = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ k = NUM2INT(rblapack_k);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MIN(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cungbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cungbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cungbr", rblapack_cungbr, -1);
+}
diff --git a/ext/cunghr.c b/ext/cunghr.c
new file mode 100644
index 0000000..ac58dd5
--- /dev/null
+++ b/ext/cunghr.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID cunghr_(integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunghr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 work, info, a = NumRu::Lapack.cunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGHR generates a complex unitary matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* CGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of CGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by CGEHRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEHRD.\n*\n* WORK (workspace/output) COMPLEX 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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = ihi-ilo;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cunghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cunghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunghr", rblapack_cunghr, -1);
+}
diff --git a/ext/cungl2.c b/ext/cungl2.c
new file mode 100644
index 0000000..4eb17cb
--- /dev/null
+++ b/ext/cungl2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID cungl2_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cungl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cungl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by CGELQF in the first k rows of its array argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* WORK (workspace) COMPLEX array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.cungl2( a, tau, [: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_tau = 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (m));
+
+ cungl2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cungl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cungl2", rblapack_cungl2, -1);
+}
diff --git a/ext/cunglq.c b/ext/cunglq.c
new file mode 100644
index 0000000..bdc4d07
--- /dev/null
+++ b/ext/cunglq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cunglq_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunglq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.cunglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by CGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cunglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cunglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cunglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunglq", rblapack_cunglq, -1);
+}
diff --git a/ext/cungql.c b/ext/cungql.c
new file mode 100644
index 0000000..51e86da
--- /dev/null
+++ b/ext/cungql.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cungql_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cungql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.cungql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cungql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cungql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cungql", rblapack_cungql, -1);
+}
diff --git a/ext/cungqr.c b/ext/cungqr.c
new file mode 100644
index 0000000..fe7d2af
--- /dev/null
+++ b/ext/cungqr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cungqr_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cungqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.cungqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cungqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cungqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cungqr", rblapack_cungqr, -1);
+}
diff --git a/ext/cungr2.c b/ext/cungr2.c
new file mode 100644
index 0000000..c68ccfa
--- /dev/null
+++ b/ext/cungr2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID cungr2_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cungr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+ complex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.cungr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGERQF in the last k rows of its array argument\n* A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* WORK (workspace) COMPLEX array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.cungr2( a, tau, [: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_tau = 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ work = ALLOC_N(complex, (m));
+
+ cungr2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cungr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cungr2", rblapack_cungr2, -1);
+}
diff --git a/ext/cungrq.c b/ext/cungrq.c
new file mode 100644
index 0000000..7239725
--- /dev/null
+++ b/ext/cungrq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cungrq_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cungrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.cungrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by CGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* WORK (workspace/output) COMPLEX 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cungrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cungrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cungrq", rblapack_cungrq, -1);
+}
diff --git a/ext/cungtr.c b/ext/cungtr.c
new file mode 100644
index 0000000..5779d5e
--- /dev/null
+++ b/ext/cungtr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID cungtr_(char* uplo, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cungtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *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 work, info, a = NumRu::Lapack.cungtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* CHETRD:\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 triangle of A contains elementary reflectors\n* from CHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from CHETRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by CHETRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= N.\n*\n* TAU (input) COMPLEX array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CHETRD.\n*\n* WORK (workspace/output) COMPLEX 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 >= N-1.\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.cungtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ cungtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_cungtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cungtr", rblapack_cungtr, -1);
+}
diff --git a/ext/cunm2l.c b/ext/cunm2l.c
new file mode 100644
index 0000000..286f9eb
--- /dev/null
+++ b/ext/cunm2l.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID cunm2l_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cunm2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer lda;
+ integer k;
+ 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.cunm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNM2L overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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.cunm2l( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ cunm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunm2l", rblapack_cunm2l, -1);
+}
diff --git a/ext/cunm2r.c b/ext/cunm2r.c
new file mode 100644
index 0000000..5f4d605
--- /dev/null
+++ b/ext/cunm2r.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID cunm2r_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cunm2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer lda;
+ integer k;
+ 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.cunm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNM2R overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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.cunm2r( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ cunm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunm2r", rblapack_cunm2r, -1);
+}
diff --git a/ext/cunmbr.c b/ext/cunmbr.c
new file mode 100644
index 0000000..2483e6b
--- /dev/null
+++ b/ext/cunmbr.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID cunmbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ integer nq;
+
+ integer lda;
+ 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 work, info, c = NumRu::Lapack.cunmbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'C': P**H * C C * P**H\n*\n* Here Q and P**H are the unitary matrices determined by CGEBRD when\n* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n* and P**H are defined as products of elementary reflectors H(i) and\n* G(i) respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the unitary matrix Q or P**H that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**H;\n* = 'P': apply P or P**H.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**H, P or P**H from the Left;\n* = 'R': apply Q, Q**H, P or P**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'C': Conjugate transpose, apply Q**H or P**H.\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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by CGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by CGEBRD.\n* K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by CGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) COMPLEX array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by CGEBRD in the array argument TAUQ or TAUP.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n* or P*C or P**H*C or C*P or C*P**H.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M);\n* if N = 0 or M = 0, LWORK >= 1.\n* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n* optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CUNMLQ, CUNMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmbr( vect, side, trans, m, k, a, tau, c, [: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_vect = argv[0];
+ rblapack_side = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_m = argv[3];
+ rblapack_k = argv[4];
+ rblapack_a = argv[5];
+ rblapack_tau = argv[6];
+ rblapack_c = 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;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmbr", rblapack_cunmbr, -1);
+}
diff --git a/ext/cunmhr.c b/ext/cunmhr.c
new file mode 100644
index 0000000..257cb23
--- /dev/null
+++ b/ext/cunmhr.c
@@ -0,0 +1,133 @@
+#include "rb_lapack.h"
+
+extern VOID cunmhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmhr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.cunmhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMHR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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* IHI-ILO elementary reflectors, as returned by CGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q**H (Conjugate transpose)\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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of CGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by CGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEHRD.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CUNMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmhr( side, trans, ilo, ihi, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = 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;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmhr", rblapack_cunmhr, -1);
+}
diff --git a/ext/cunml2.c b/ext/cunml2.c
new file mode 100644
index 0000000..2c976b7
--- /dev/null
+++ b/ext/cunml2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID cunml2_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cunml2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.cunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNML2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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.cunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ cunml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunml2", rblapack_cunml2, -1);
+}
diff --git a/ext/cunmlq.c b/ext/cunmlq.c
new file mode 100644
index 0000000..70248cb
--- /dev/null
+++ b/ext/cunmlq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID cunmlq_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmlq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.cunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMLQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGELQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmlq", rblapack_cunmlq, -1);
+}
diff --git a/ext/cunmql.c b/ext/cunmql.c
new file mode 100644
index 0000000..2a586ef
--- /dev/null
+++ b/ext/cunmql.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID cunmql_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.cunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMQL overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQLF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmql", rblapack_cunmql, -1);
+}
diff --git a/ext/cunmqr.c b/ext/cunmqr.c
new file mode 100644
index 0000000..9079d83
--- /dev/null
+++ b/ext/cunmqr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID cunmqr_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.cunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMQR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGEQRF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmqr", rblapack_cunmqr, -1);
+}
diff --git a/ext/cunmr2.c b/ext/cunmr2.c
new file mode 100644
index 0000000..4887738
--- /dev/null
+++ b/ext/cunmr2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID cunmr2_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cunmr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.cunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMR2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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.cunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ cunmr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmr2", rblapack_cunmr2, -1);
+}
diff --git a/ext/cunmr3.c b/ext/cunmr3.c
new file mode 100644
index 0000000..9939542
--- /dev/null
+++ b/ext/cunmr3.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID cunmr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cunmr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.cunmr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMR3 overwrites the general complex m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CTZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CTZRZF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n COMPLEX TAUI\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CLARZ, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CONJG, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.cunmr3( side, trans, l, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ cunmr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmr3", rblapack_cunmr3, -1);
+}
diff --git a/ext/cunmrq.c b/ext/cunmrq.c
new file mode 100644
index 0000000..9cf8168
--- /dev/null
+++ b/ext/cunmrq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID cunmrq_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.cunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMRQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CGERQF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmrq", rblapack_cunmrq, -1);
+}
diff --git a/ext/cunmrz.c b/ext/cunmrz.c
new file mode 100644
index 0000000..6fd9763
--- /dev/null
+++ b/ext/cunmrz.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID cunmrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.cunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMRZ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* CTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CTZRZF.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmrz", rblapack_cunmrz, -1);
+}
diff --git a/ext/cunmtr.c b/ext/cunmtr.c
new file mode 100644
index 0000000..d70aa3f
--- /dev/null
+++ b/ext/cunmtr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID cunmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_cunmtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ complex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.cunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* CUNMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 CHETRD:\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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A contains elementary reflectors\n* from CHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from CHETRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* A (input) COMPLEX array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by CHETRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CHETRD.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL CUNMQL, CUNMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.cunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th 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_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ cunmtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_cunmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cunmtr", rblapack_cunmtr, -1);
+}
diff --git a/ext/cupgtr.c b/ext/cupgtr.c
new file mode 100644
index 0000000..7d538a7
--- /dev/null
+++ b/ext/cupgtr.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID cupgtr_(char* uplo, integer* n, complex* ap, complex* tau, complex* q, integer* ldq, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cupgtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ complex *ap;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_q;
+ complex *q;
+ VALUE rblapack_info;
+ integer info;
+ complex *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.cupgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUPGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors H(i) of order n, as returned by\n* CHPTRD 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 CHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to CHPTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* AP (input) COMPLEX array, dimension (N*(N+1)/2)\n* The vectors which define the elementary reflectors, as\n* returned by CHPTRD.\n*\n* TAU (input) COMPLEX array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by CHPTRD.\n*\n* Q (output) COMPLEX array, dimension (LDQ,N)\n* The N-by-N unitary matrix Q.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* WORK (workspace) COMPLEX 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.cupgtr( 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_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ ldq = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, complex*);
+ work = ALLOC_N(complex, (n-1));
+
+ cupgtr_(&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_cupgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cupgtr", rblapack_cupgtr, -1);
+}
diff --git a/ext/cupmtr.c b/ext/cupmtr.c
new file mode 100644
index 0000000..9437020
--- /dev/null
+++ b/ext/cupmtr.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID cupmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, complex* ap, complex* tau, complex* c, integer* ldc, complex* work, integer* info);
+
+
+static VALUE
+rblapack_cupmtr(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;
+ complex *ap;
+ VALUE rblapack_tau;
+ complex *tau;
+ VALUE rblapack_c;
+ complex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ complex *c_out__;
+ complex *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.cupmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* CUPMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 CHPTRD 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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular packed storage used in previous\n* call to CHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to CHPTRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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) COMPLEX 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 CHPTRD. AP is modified by the routine but\n* restored on exit.\n*\n* TAU (input) COMPLEX 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 CHPTRD.\n*\n* C (input/output) COMPLEX array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX 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.cupmtr( 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_SCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, complex*);
+ 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_SCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, complex*);
+ 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_SCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, complex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
+ MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ cupmtr_(&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_cupmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "cupmtr", rblapack_cupmtr, -1);
+}
diff --git a/ext/dbbcsd.c b/ext/dbbcsd.c
new file mode 100644
index 0000000..ab3709e
--- /dev/null
+++ b/ext/dbbcsd.c
@@ -0,0 +1,287 @@
+#include "rb_lapack.h"
+
+extern VOID dbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, doublereal* theta, doublereal* phi, doublereal* u1, integer* ldu1, doublereal* u2, integer* ldu2, doublereal* v1t, integer* ldv1t, doublereal* v2t, integer* ldv2t, doublereal* b11d, doublereal* b11e, doublereal* b12d, doublereal* b12e, doublereal* b21d, doublereal* b21e, doublereal* b22d, doublereal* b22e, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dbbcsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_theta;
+ doublereal *theta;
+ VALUE rblapack_phi;
+ doublereal *phi;
+ VALUE rblapack_u1;
+ doublereal *u1;
+ VALUE rblapack_u2;
+ doublereal *u2;
+ VALUE rblapack_v1t;
+ doublereal *v1t;
+ VALUE rblapack_v2t;
+ doublereal *v2t;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_b11d;
+ doublereal *b11d;
+ VALUE rblapack_b11e;
+ doublereal *b11e;
+ VALUE rblapack_b12d;
+ doublereal *b12d;
+ VALUE rblapack_b12e;
+ doublereal *b12e;
+ VALUE rblapack_b21d;
+ doublereal *b21d;
+ VALUE rblapack_b21e;
+ doublereal *b21e;
+ VALUE rblapack_b22d;
+ doublereal *b22d;
+ VALUE rblapack_b22e;
+ doublereal *b22e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_theta_out__;
+ doublereal *theta_out__;
+ VALUE rblapack_u1_out__;
+ doublereal *u1_out__;
+ VALUE rblapack_u2_out__;
+ doublereal *u2_out__;
+ VALUE rblapack_v1t_out__;
+ doublereal *v1t_out__;
+ VALUE rblapack_v2t_out__;
+ doublereal *v2t_out__;
+ doublereal *work;
+
+ integer q;
+ integer ldu1;
+ integer p;
+ integer ldu2;
+ integer ldv1t;
+ integer ldv2t;
+
+ 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 b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.dbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DBBCSD computes the CS decomposition of an orthogonal matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See DORCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the orthogonal matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) DOUBLE PRECISION array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) DOUBLE PRECISION array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) DOUBLE PRECISION array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) DOUBLE PRECISION array, dimension (Q)\n* When DBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If DBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When DBBCSD converges, B11E contains zeros. If DBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) DOUBLE PRECISION array, dimension (Q)\n* When DBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When DBBCSD converges, B12E contains zeros. If DBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* WORK (workspace) DOUBLE PRECISION 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 >= MAX(1,8*Q).\n*\n* If LWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the WORK array,\n* returns this value as the first entry of the work array, and\n* no error 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* > 0: if DBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.dbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [: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_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_m = argv[5];
+ rblapack_theta = argv[6];
+ rblapack_phi = argv[7];
+ rblapack_u1 = argv[8];
+ rblapack_u2 = argv[9];
+ rblapack_v1t = argv[10];
+ rblapack_v2t = 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;
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_theta))
+ rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
+ if (NA_RANK(rblapack_theta) != 1)
+ rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
+ q = NA_SHAPE0(rblapack_theta);
+ if (NA_TYPE(rblapack_theta) != NA_DFLOAT)
+ rblapack_theta = na_change_type(rblapack_theta, NA_DFLOAT);
+ theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
+ if (!NA_IsNArray(rblapack_u1))
+ rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_u1) != 2)
+ rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
+ ldu1 = NA_SHAPE0(rblapack_u1);
+ p = NA_SHAPE1(rblapack_u1);
+ if (NA_TYPE(rblapack_u1) != NA_DFLOAT)
+ rblapack_u1 = na_change_type(rblapack_u1, NA_DFLOAT);
+ u1 = NA_PTR_TYPE(rblapack_u1, doublereal*);
+ if (!NA_IsNArray(rblapack_v1t))
+ rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v1t) != 2)
+ rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
+ ldv1t = NA_SHAPE0(rblapack_v1t);
+ if (NA_SHAPE1(rblapack_v1t) != q)
+ rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
+ if (NA_TYPE(rblapack_v1t) != NA_DFLOAT)
+ rblapack_v1t = na_change_type(rblapack_v1t, NA_DFLOAT);
+ v1t = NA_PTR_TYPE(rblapack_v1t, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = 8*q;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_u2))
+ rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u2) != 2)
+ rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
+ ldu2 = NA_SHAPE0(rblapack_u2);
+ if (NA_SHAPE1(rblapack_u2) != (m-p))
+ rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
+ if (NA_TYPE(rblapack_u2) != NA_DFLOAT)
+ rblapack_u2 = na_change_type(rblapack_u2, NA_DFLOAT);
+ u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_v2t))
+ rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
+ if (NA_RANK(rblapack_v2t) != 2)
+ rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
+ ldv2t = NA_SHAPE0(rblapack_v2t);
+ if (NA_SHAPE1(rblapack_v2t) != (m-q))
+ rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
+ if (NA_TYPE(rblapack_v2t) != NA_DFLOAT)
+ rblapack_v2t = na_change_type(rblapack_v2t, NA_DFLOAT);
+ v2t = NA_PTR_TYPE(rblapack_v2t, doublereal*);
+ if (!NA_IsNArray(rblapack_phi))
+ rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
+ if (NA_RANK(rblapack_phi) != 1)
+ rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_phi) != (q-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
+ if (NA_TYPE(rblapack_phi) != NA_DFLOAT)
+ rblapack_phi = na_change_type(rblapack_phi, NA_DFLOAT);
+ phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b11d = NA_PTR_TYPE(rblapack_b11d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b11e = NA_PTR_TYPE(rblapack_b11e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b12d = NA_PTR_TYPE(rblapack_b12d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b12e = NA_PTR_TYPE(rblapack_b12e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b21d = NA_PTR_TYPE(rblapack_b21d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b21e = NA_PTR_TYPE(rblapack_b21e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b22d = NA_PTR_TYPE(rblapack_b22d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b22e = NA_PTR_TYPE(rblapack_b22e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, doublereal*);
+ MEMCPY(theta_out__, theta, doublereal, NA_TOTAL(rblapack_theta));
+ rblapack_theta = rblapack_theta_out__;
+ theta = theta_out__;
+ {
+ int shape[2];
+ shape[0] = ldu1;
+ shape[1] = p;
+ rblapack_u1_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, doublereal*);
+ MEMCPY(u1_out__, u1, doublereal, NA_TOTAL(rblapack_u1));
+ rblapack_u1 = rblapack_u1_out__;
+ u1 = u1_out__;
+ {
+ int shape[2];
+ shape[0] = ldu2;
+ shape[1] = m-p;
+ rblapack_u2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, doublereal*);
+ MEMCPY(u2_out__, u2, doublereal, NA_TOTAL(rblapack_u2));
+ rblapack_u2 = rblapack_u2_out__;
+ u2 = u2_out__;
+ {
+ int shape[2];
+ shape[0] = ldv1t;
+ shape[1] = q;
+ rblapack_v1t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, doublereal*);
+ MEMCPY(v1t_out__, v1t, doublereal, NA_TOTAL(rblapack_v1t));
+ rblapack_v1t = rblapack_v1t_out__;
+ v1t = v1t_out__;
+ {
+ int shape[2];
+ shape[0] = ldv2t;
+ shape[1] = m-q;
+ rblapack_v2t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, doublereal*);
+ MEMCPY(v2t_out__, v2t, doublereal, NA_TOTAL(rblapack_v2t));
+ rblapack_v2t = rblapack_v2t_out__;
+ v2t = v2t_out__;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ dbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, work, &lwork, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
+}
+
+void
+init_lapack_dbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dbbcsd", rblapack_dbbcsd, -1);
+}
diff --git a/ext/dbdsdc.c b/ext/dbdsdc.c
new file mode 100644
index 0000000..084aec7
--- /dev/null
+++ b/ext/dbdsdc.c
@@ -0,0 +1,151 @@
+#include "rb_lapack.h"
+
+extern VOID dbdsdc_(char* uplo, char* compq, integer* n, doublereal* d, doublereal* e, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* q, integer* iq, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dbdsdc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_iq;
+ integer *iq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ integer c__0;
+ integer c__9;
+ real smlsiz;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldvt;
+ integer ldu;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DBDSDC computes the singular value decomposition (SVD) of a real\n* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,\n* using a divide and conquer method, where S is a diagonal matrix\n* with non-negative diagonal elements (the singular values of B), and\n* U and VT are orthogonal matrices of left and right singular vectors,\n* respectively. DBDSDC can be used to compute all singular values,\n* and optionally, singular vectors or singular vectors in compact form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See DLASD3 for details.\n*\n* The code currently calls DLASDQ if singular values only are desired.\n* However, it can be slightly modified to compute singular values\n* using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal.\n* = 'L': B is lower bidiagonal.\n*\n* COMPQ (input) CHARACTER*1\n* Specifies whether singular vectors are to be computed\n* as follows:\n* = 'N': Compute singular values only;\n* = 'P': Compute singular values and compute singular\n* vectors in compact form;\n* = 'I': Compute singular values and singular vectors.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the elements of E contain the offdiagonal\n* elements of the bidiagonal matrix whose SVD is desired.\n* On exit, E has been destroyed.\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, U contains the left singular vectors\n* of the bidiagonal matrix.\n* For other values of COMPQ, U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1.\n* If singular vectors are desired, then LDU >= max( 1, N ).\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, VT' contains the right singular\n* vectors of the bidiagonal matrix.\n* For other values of COMPQ, VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1.\n* If singular vectors are desired, then LDVT >= max( 1, N ).\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, Q contains all the DOUBLE PRECISION data in\n* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, Q is not referenced.\n*\n* IQ (output) INTEGER array, dimension (LDIQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, IQ contains all INTEGER data in\n* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, IQ is not referenced.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* If COMPQ = 'N' then LWORK >= (4 * N).\n* If COMPQ = 'P' then LWORK >= (6 * N).\n* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n*\n* IWORK (workspace) INTEGER array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value.\n* The update process of divide and conquer failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n* Changed dimension statement in comment describing E from (N) to\n* (N-1). Sven, 17 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ c__0 = 0;
+ compq = StringValueCStr(rblapack_compq)[0];
+ c__9 = 9;
+ ldu = lsame_(&compq,"I") ? MAX(1,n) : 0;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
+ ldvt = lsame_(&compq,"I") ? MAX(1,n) : 0;
+ {
+ int shape[2];
+ shape[0] = lsame_(&compq,"I") ? ldu : 0;
+ shape[1] = lsame_(&compq,"I") ? n : 0;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&compq,"I") ? ldvt : 0;
+ shape[1] = lsame_(&compq,"I") ? n : 0;
+ rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ {
+ int shape[1];
+ shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
+ rblapack_q = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ {
+ int shape[1];
+ shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
+ rblapack_iq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iq = NA_PTR_TYPE(rblapack_iq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(doublereal, (MAX(1,lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0)));
+ iwork = ALLOC_N(integer, (8*n));
+
+ dbdsdc_(&uplo, &compq, &n, d, e, u, &ldu, vt, &ldvt, q, iq, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_u, rblapack_vt, rblapack_q, rblapack_iq, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dbdsdc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dbdsdc", rblapack_dbdsdc, -1);
+}
diff --git a/ext/dbdsqr.c b/ext/dbdsqr.c
new file mode 100644
index 0000000..128d5d2
--- /dev/null
+++ b/ext/dbdsqr.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID dbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, doublereal* d, doublereal* e, doublereal* vt, integer* ldvt, doublereal* u, integer* ldu, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dbdsqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nru;
+ integer nru;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_vt_out__;
+ doublereal *vt_out__;
+ VALUE rblapack_u_out__;
+ doublereal *u_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldvt;
+ integer ncvt;
+ integer ldu;
+ integer ldc;
+ integer ncc;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.dbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**T\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**T*VT instead of\n* P**T, for given real input matrices U and VT. When U and VT are the\n* orthogonal matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by DGEBRD, then\n*\n* A = (U*Q) * S * (P**T*VT)\n*\n* is the SVD of A. Optionally, the subroutine may also compute Q**T*C\n* for a given real input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B. \n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**T * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**T * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0:\n* if NCVT = NRU = NCC = 0,\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n* else NCVT = NRU = NCC = 0,\n* the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.dbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_nru = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vt = argv[4];
+ rblapack_u = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ ncvt = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ nru = NUM2INT(rblapack_nru);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (6th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ if (NA_SHAPE1(rblapack_u) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = ncvt;
+ rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
+ MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
+ MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+ MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublereal, (4*n));
+
+ dbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
+}
+
+void
+init_lapack_dbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dbdsqr", rblapack_dbdsqr, -1);
+}
diff --git a/ext/ddisna.c b/ext/ddisna.c
new file mode 100644
index 0000000..7b35056
--- /dev/null
+++ b/ext/ddisna.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID ddisna_(char* job, integer* m, integer* n, doublereal* d, doublereal* sep, integer* info);
+
+
+static VALUE
+rblapack_ddisna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_sep;
+ doublereal *sep;
+ VALUE rblapack_info;
+ integer info;
+
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n sep, info = NumRu::Lapack.ddisna( job, n, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )\n\n* Purpose\n* =======\n*\n* DDISNA computes the reciprocal condition numbers for the eigenvectors\n* of a real symmetric or complex Hermitian matrix or for the left or\n* right singular vectors of a general m-by-n matrix. The reciprocal\n* condition number is the 'gap' between the corresponding eigenvalue or\n* singular value and the nearest other one.\n*\n* The bound on the error, measured by angle in radians, in the I-th\n* computed vector is given by\n*\n* DLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n*\n* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed\n* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of\n* the error bound.\n*\n* DDISNA may also be used to compute error bounds for eigenvectors of\n* the generalized symmetric definite eigenproblem.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies for which problem the reciprocal condition numbers\n* should be computed:\n* = 'E': the eigenvectors of a symmetric/Hermitian matrix;\n* = 'L': the left singular vectors of a general matrix;\n* = 'R': the right singular vectors of a general matrix.\n*\n* M (input) INTEGER\n* The number of rows of the matrix. M >= 0.\n*\n* N (input) INTEGER\n* If JOB = 'L' or 'R', the number of columns of the matrix,\n* in which case N >= 0. Ignored if JOB = 'E'.\n*\n* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The eigenvalues (if JOB = 'E') or singular values (if JOB =\n* 'L' or 'R') of the matrix, in either increasing or decreasing\n* order. If singular values, they must be non-negative.\n*\n* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The reciprocal condition numbers of the vectors.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sep, info = NumRu::Lapack.ddisna( job, n, d, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_job = argv[0];
+ rblapack_n = argv[1];
+ rblapack_d = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ n = NUM2INT(rblapack_n);
+ {
+ int shape[1];
+ shape[0] = lsame_(&job,"E") ? m : ((lsame_(&job,"L")) || (lsame_(&job,"R"))) ? MIN(m,n) : 0;
+ rblapack_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sep = NA_PTR_TYPE(rblapack_sep, doublereal*);
+
+ ddisna_(&job, &m, &n, d, sep, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_sep, rblapack_info);
+}
+
+void
+init_lapack_ddisna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ddisna", rblapack_ddisna, -1);
+}
diff --git a/ext/dgbbrd.c b/ext/dgbbrd.c
new file mode 100644
index 0000000..268dda5
--- /dev/null
+++ b/ext/dgbbrd.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID dgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* d, doublereal* e, doublereal* q, integer* ldq, doublereal* pt, integer* ldpt, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgbbrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_pt;
+ doublereal *pt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer ldc;
+ integer ncc;
+ integer ldq;
+ integer m;
+ integer ldpt;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBBRD reduces a real general m-by-n band matrix A to upper\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) DOUBLE PRECISION array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
+ m = ldab;
+ ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = m;
+ rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldpt;
+ shape[1] = n;
+ rblapack_pt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ pt = NA_PTR_TYPE(rblapack_pt, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+ MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublereal, (2*MAX(m,n)));
+
+ dgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
+}
+
+void
+init_lapack_dgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbbrd", rblapack_dgbbrd, -1);
+}
diff --git a/ext/dgbcon.c b/ext/dgbcon.c
new file mode 100644
index 0000000..fcb14b0
--- /dev/null
+++ b/ext/dgbcon.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID dgbcon_(char* norm, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ 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.dgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBCON estimates the reciprocal of the condition number of a real\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by DGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dgbcon( norm, kl, ku, ab, ipiv, anorm, [: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_norm = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_anorm = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ anorm = NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgbcon_(&norm, &n, &kl, &ku, ab, &ldab, 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_dgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbcon", rblapack_dgbcon, -1);
+}
diff --git a/ext/dgbequ.c b/ext/dgbequ.c
new file mode 100644
index 0000000..2c1631c
--- /dev/null
+++ b/ext/dgbequ.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID dgbequ_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dgbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequ( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,m);
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ dgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbequ", rblapack_dgbequ, -1);
+}
diff --git a/ext/dgbequb.c b/ext/dgbequb.c
new file mode 100644
index 0000000..e4e70e5
--- /dev/null
+++ b/ext/dgbequb.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID dgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dgbequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from DGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequb( kl, ku, ab, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ m = ldab;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ dgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbequb", rblapack_dgbequb, -1);
+}
diff --git a/ext/dgbrfs.c b/ext/dgbrfs.c
new file mode 100644
index 0000000..bc578be
--- /dev/null
+++ b/ext/dgbrfs.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID dgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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.dgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, 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_dgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbrfs", rblapack_dgbrfs, -1);
+}
diff --git a/ext/dgbrfsx.c b/ext/dgbrfsx.c
new file mode 100644
index 0000000..c0c9908
--- /dev/null
+++ b/ext/dgbrfsx.c
@@ -0,0 +1,249 @@
+#include "rb_lapack.h"
+
+extern VOID dgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgbrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.dgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.dgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [: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_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_x = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (8th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_dgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbrfsx", rblapack_dgbrfsx, -1);
+}
diff --git a/ext/dgbsv.c b/ext/dgbsv.c
new file mode 100644
index 0000000..b8b9b6c
--- /dev/null
+++ b/ext/dgbsv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID dgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dgbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, ab, b = NumRu::Lapack.dgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGBSV computes the solution to a real system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL DGBTRF, DGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.dgbsv( kl, ku, ab, b, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_dgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbsv", rblapack_dgbsv, -1);
+}
diff --git a/ext/dgbsvx.c b/ext/dgbsvx.c
new file mode 100644
index 0000000..422d919
--- /dev/null
+++ b/ext/dgbsvx.c
@@ -0,0 +1,286 @@
+#include "rb_lapack.h"
+
+extern VOID dgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_afb_out__;
+ doublereal *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.dgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by DGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) DOUBLE PRECISION array, dimension (3*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.dgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 11) {
+ rblapack_afb = argv[6];
+ rblapack_ipiv = argv[7];
+ rblapack_equed = argv[8];
+ rblapack_r = argv[9];
+ rblapack_c = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_afb = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ku = NUM2INT(rblapack_ku);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ }
+ ldafb = 2*kl+ku+1;
+ if (rblapack_afb != Qnil) {
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (option) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_afb) != ldafb)
+ rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 3*n;
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublereal*);
+ if (rblapack_afb != Qnil) {
+ MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rblapack_afb));
+ }
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+
+ dgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_dgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbsvx", rblapack_dgbsvx, -1);
+}
diff --git a/ext/dgbsvxx.c b/ext/dgbsvxx.c
new file mode 100644
index 0000000..fe73f34
--- /dev/null
+++ b/ext/dgbsvxx.c
@@ -0,0 +1,289 @@
+#include "rb_lapack.h"
+
+extern VOID dgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgbsvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_afb_out__;
+ doublereal *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.dgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGBSVXX uses the LU factorization to compute the solution to a\n* double precision system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In DGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.dgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_equed = argv[7];
+ rblapack_r = argv[8];
+ rblapack_c = argv[9];
+ rblapack_b = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_r))
+ rb_raise(rb_eArgError, "r (9th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (10th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ ldx = MAX(1,n);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublereal*);
+ MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_dgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbsvxx", rblapack_dgbsvxx, -1);
+}
diff --git a/ext/dgbtf2.c b/ext/dgbtf2.c
new file mode 100644
index 0000000..8c5d6bf
--- /dev/null
+++ b/ext/dgbtf2.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID dgbtf2_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_dgbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.dgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGBTF2 computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.dgbtf2( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbtf2", rblapack_dgbtf2, -1);
+}
diff --git a/ext/dgbtrf.c b/ext/dgbtrf.c
new file mode 100644
index 0000000..eaa9dd3
--- /dev/null
+++ b/ext/dgbtrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID dgbtrf_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_dgbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.dgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGBTRF computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.dgbtrf( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbtrf", rblapack_dgbtrf, -1);
+}
diff --git a/ext/dgbtrs.c b/ext/dgbtrs.c
new file mode 100644
index 0000000..d85044d
--- /dev/null
+++ b/ext/dgbtrs.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID dgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dgbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGBTRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general band matrix A using the LU factorization computed\n* by DGBTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.dgbtrs( trans, kl, ku, ab, ipiv, b, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgbtrs", rblapack_dgbtrs, -1);
+}
diff --git a/ext/dgebak.c b/ext/dgebak.c
new file mode 100644
index 0000000..f2ef776
--- /dev/null
+++ b/ext/dgebak.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* scale, integer* m, doublereal* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_dgebak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ doublereal *scale;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.dgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* DGEBAK forms the right or left eigenvectors of a real general matrix\n* by backward transformation on the computed eigenvectors of the\n* balanced matrix output by DGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to DGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by DGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by DGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by DHSEIN or DTREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 info, v = NumRu::Lapack.dgebak( job, side, ilo, ihi, scale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_scale = argv[4];
+ rblapack_v = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_scale))
+ rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_scale) != 1)
+ rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_scale);
+ if (NA_TYPE(rblapack_scale) != NA_DFLOAT)
+ rblapack_scale = na_change_type(rblapack_scale, NA_DFLOAT);
+ scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ dgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_dgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgebak", rblapack_dgebak, -1);
+}
diff --git a/ext/dgebal.c b/ext/dgebal.c
new file mode 100644
index 0000000..61331be
--- /dev/null
+++ b/ext/dgebal.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID dgebal_(char* job, integer* n, doublereal* a, integer* lda, integer* ilo, integer* ihi, doublereal* scale, integer* info);
+
+
+static VALUE
+rblapack_dgebal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ doublereal *scale;
+ 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 ilo, ihi, scale, info, a = NumRu::Lapack.dgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* DGEBAL balances a general real matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine BALANC.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.dgebal( job, 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_job = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
+ {
+ int 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__;
+
+ dgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
+
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgebal", rblapack_dgebal, -1);
+}
diff --git a/ext/dgebd2.c b/ext/dgebd2.c
new file mode 100644
index 0000000..96f672f
--- /dev/null
+++ b/ext/dgebd2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID dgebd2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tauq, doublereal* taup, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgebd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tauq;
+ doublereal *tauq;
+ VALUE rblapack_taup;
+ doublereal *taup;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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 d, e, tauq, taup, info, a = NumRu::Lapack.dgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEBD2 reduces a real general m by n matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.dgebd2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (MAX(m,n)));
+
+ dgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgebd2", rblapack_dgebd2, -1);
+}
diff --git a/ext/dgebrd.c b/ext/dgebrd.c
new file mode 100644
index 0000000..a053391
--- /dev/null
+++ b/ext/dgebrd.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID dgebrd_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tauq, doublereal* taup, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgebrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tauq;
+ doublereal *tauq;
+ VALUE rblapack_taup;
+ doublereal *taup;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 d, e, tauq, taup, work, info, a = NumRu::Lapack.dgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEBRD reduces a general real M-by-N matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.dgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgebrd", rblapack_dgebrd, -1);
+}
diff --git a/ext/dgecon.c b/ext/dgecon.c
new file mode 100644
index 0000000..d24cae5
--- /dev/null
+++ b/ext/dgecon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID dgecon_(char* norm, integer* n, doublereal* a, integer* lda, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgecon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ 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 rcond, info = NumRu::Lapack.dgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGECON estimates the reciprocal of the condition number of a general\n* real matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by DGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION array, dimension (4*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.dgecon( norm, a, anorm, [: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_norm = argv[0];
+ rblapack_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ anorm = NUM2DBL(rblapack_anorm);
+ 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*);
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgecon_(&norm, &n, a, &lda, &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_dgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgecon", rblapack_dgecon, -1);
+}
diff --git a/ext/dgeequ.c b/ext/dgeequ.c
new file mode 100644
index 0000000..66140dc
--- /dev/null
+++ b/ext/dgeequ.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID dgeequ_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dgeequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ dgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeequ", rblapack_dgeequ, -1);
+}
diff --git a/ext/dgeequb.c b/ext/dgeequb.c
new file mode 100644
index 0000000..db09e50
--- /dev/null
+++ b/ext/dgeequb.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID dgeequb_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dgeequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from DGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ dgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeequb", rblapack_dgeequb, -1);
+}
diff --git a/ext/dgees.c b/ext/dgees.c
new file mode 100644
index 0000000..f838492
--- /dev/null
+++ b/ext/dgees.c
@@ -0,0 +1,148 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(doublereal *arg0, doublereal *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID dgees_(char* jobvs, char* sort, L_fp select, integer* n, doublereal* a, integer* lda, integer* sdim, doublereal* wr, doublereal* wi, doublereal* vs, integer* ldvs, doublereal* work, integer* lwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_dgees(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_vs;
+ doublereal *vs;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, wr, wi, vs, work, info, a = NumRu::Lapack.dgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEES computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n*\n* A matrix is in real Schur form if it is upper quasi-triangular with\n* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n* form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n* conjugate pair of eigenvalues is selected, then both complex\n* eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO is set to N+2 (see INFO below).\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues in the same order\n* that they appear on the diagonal of the output Schur form T.\n* Complex conjugate pairs of eigenvalues will appear\n* consecutively with the eigenvalue having the positive\n* imaginary part first.\n*\n* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,3*N).\n* For good performance, LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the matrix which reduces A\n* to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, wr, wi, vs, work, info, a = NumRu::Lapack.dgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[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);
+ 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*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ dgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, work, &lwork, bwork, &info);
+
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgees", rblapack_dgees, -1);
+}
diff --git a/ext/dgeesx.c b/ext/dgeesx.c
new file mode 100644
index 0000000..7424ea9
--- /dev/null
+++ b/ext/dgeesx.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(doublereal *arg0, doublereal *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID dgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, doublereal* a, integer* lda, integer* sdim, doublereal* wr, doublereal* wi, doublereal* vs, integer* ldvs, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_dgeesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_vs;
+ doublereal *vs;
+ VALUE rblapack_rconde;
+ doublereal rconde;
+ VALUE rblapack_rcondv;
+ doublereal rcondv;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.dgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEESX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A real matrix is in real Schur form if it is upper quasi-triangular\n* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n* the form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n* complex conjugate pair of eigenvalues is selected, then both\n* are. Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO may be set to N+3 (see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the N-by-N matrix A.\n* On exit, A is overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts, respectively,\n* of the computed eigenvalues, in the same order that they\n* appear on the diagonal of the output Schur form T. Complex\n* conjugate pairs of eigenvalues appear consecutively with the\n* eigenvalue having the positive imaginary part first.\n*\n* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) DOUBLE PRECISION\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,3*N).\n* Also, if SENSE = 'E' or 'V' or 'B',\n* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n* selected eigenvalues computed by this routine. Note that\n* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n* 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bounds on the optimal sizes of the\n* arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n* may not be large enough.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates upper bounds on the optimal sizes of\n* the arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.dgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_sense = argv[2];
+ rblapack_a = argv[3];
+ rblapack_liwork = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[0];
+ sense = StringValueCStr(rblapack_sense)[0];
+ liwork = NUM2INT(rblapack_liwork);
+ sort = StringValueCStr(rblapack_sort)[0];
+ 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);
+ 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*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n+n*n/2 : 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ dgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, &rconde, &rcondv, work, &lwork, iwork, &liwork, bwork, &info);
+
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_rconde = rb_float_new((double)rconde);
+ rblapack_rcondv = rb_float_new((double)rcondv);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeesx", rblapack_dgeesx, -1);
+}
diff --git a/ext/dgeev.c b/ext/dgeev.c
new file mode 100644
index 0000000..75fa9cd
--- /dev/null
+++ b/ext/dgeev.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID dgeev_(char* jobvl, char* jobvr, integer* n, doublereal* a, integer* lda, doublereal* wr, doublereal* wi, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgeev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 wr, wi, vl, vr, work, info, a = NumRu::Lapack.dgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEEV computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,3*N), and\n* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good\n* performance, LWORK must generally be larger.\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* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements i+1:N of WR and WI contain eigenvalues which\n* have converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, vl, vr, work, info, a = NumRu::Lapack.dgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ 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*);
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 4*n : 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeev", rblapack_dgeev, -1);
+}
diff --git a/ext/dgeevx.c b/ext/dgeevx.c
new file mode 100644
index 0000000..8ce6ef4
--- /dev/null
+++ b/ext/dgeevx.c
@@ -0,0 +1,181 @@
+#include "rb_lapack.h"
+
+extern VOID dgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublereal* a, integer* lda, doublereal* wr, doublereal* wi, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* scale, doublereal* abnrm, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgeevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ doublereal *scale;
+ VALUE rblapack_abnrm;
+ doublereal abnrm;
+ VALUE rblapack_rconde;
+ doublereal *rconde;
+ VALUE rblapack_rcondv;
+ doublereal *rcondv;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.dgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, i.e. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the real Schur form of the balanced\n* version of the input matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues will appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and\n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n* For good performance, LWORK must generally be larger.\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 (2*N-2)\n* If SENSE = 'N' or 'E', not referenced.\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, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of WR\n* and WI contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.dgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 3*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*(n+6) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ iwork = ALLOC_N(integer, ((lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2));
+
+ dgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(13, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeevx", rblapack_dgeevx, -1);
+}
diff --git a/ext/dgegs.c b/ext/dgegs.c
new file mode 100644
index 0000000..2994527
--- /dev/null
+++ b/ext/dgegs.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID dgegs_(char* jobvsl, char* jobvsr, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vsl, integer* ldvsl, doublereal* vsr, integer* ldvsr, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgegs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_vsl;
+ doublereal *vsl;
+ VALUE rblapack_vsr;
+ doublereal *vsr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGGES.\n*\n* DGEGS computes the eigenvalues, real Schur form, and, optionally,\n* left and or/right Schur vectors of a real matrix pair (A,B).\n* Given two square matrices A and B, the generalized real Schur\n* factorization has the form\n*\n* A = Q*S*Z**T, B = Q*T*Z**T\n*\n* where Q and Z are orthogonal matrices, T is upper triangular, and S\n* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n* of eigenvalues of (A,B). The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n*\n* If only the eigenvalues of (A,B) are needed, the driver routine\n* DGEGV should be used instead. See DGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper quasi-triangular matrix S from the\n* generalized real Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* real Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and (j+1)-st\n* eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,4*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:\n* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR\n* The optimal LWORK is 2*N + N*(NB+1).\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* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from DGGBAL\n* =N+2: error return from DGEQRF\n* =N+3: error return from DORMQR\n* =N+4: error return from DORGQR\n* =N+5: error return from DGGHRD\n* =N+6: error return from DHGEQZ (other than failed\n* iteration)\n* =N+7: error return from DGGBAK (computing VSL)\n* =N+8: error return from DGGBAK (computing VSR)\n* =N+9: error return from DLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[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);
+ 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*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 4*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgegs", rblapack_dgegs, -1);
+}
diff --git a/ext/dgegv.c b/ext/dgegv.c
new file mode 100644
index 0000000..d191a41
--- /dev/null
+++ b/ext/dgegv.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID dgegv_(char* jobvl, char* jobvr, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgegv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGGEV.\n*\n* DGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a real matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n*\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n*\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n*\n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n*\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n*\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the real Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* blocks from the Schur form will be correct. See DGGHRD and\n* DHGEQZ for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only those elements of\n* B corresponding to the diagonal blocks from the Schur form of\n* A will be correct. See DGGHRD and DHGEQZ for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue of\n* GNEP.\n*\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* u(j) = VL(:,j) + i*VL(:,j+1)\n* and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then x(j) = VR(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* x(j) = VR(:,j) + i*VR(:,j+1)\n* and\n* x(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvalues\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:\n* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;\n* The optimal LWORK is:\n* 2*N + MAX( 6*N, N*(NB+1) ).\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from DGGBAL\n* =N+2: error return from DGEQRF\n* =N+3: error return from DORMQR\n* =N+4: error return from DORGQR\n* =N+5: error return from DGGHRD\n* =N+6: error return from DHGEQZ (other than failed\n* iteration)\n* =N+7: error return from DTGEVC\n* =N+8: error return from DGGBAK (computing VL)\n* =N+9: error return from DGGBAK (computing VR)\n* =N+10: error return from DLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls DGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, DGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the real Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] See DHGEQZ, DGEGS, or read the book \"Matrix Computations\",\n* by Golub & van Loan, pub. by Johns Hopkins U. Press.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ 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*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 8*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgegv", rblapack_dgegv, -1);
+}
diff --git a/ext/dgehd2.c b/ext/dgehd2.c
new file mode 100644
index 0000000..1171b43
--- /dev/null
+++ b/ext/dgehd2.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID dgehd2_(integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgehd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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 tau, info, a = NumRu::Lapack.dgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to DGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgehd2( ilo, ihi, a, [: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_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ 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*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n));
+
+ dgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgehd2", rblapack_dgehd2, -1);
+}
diff --git a/ext/dgehrd.c b/ext/dgehrd.c
new file mode 100644
index 0000000..70312ff
--- /dev/null
+++ b/ext/dgehrd.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dgehrd_(integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgehrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 tau, work, info, a = NumRu::Lapack.dgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEHRD reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to DGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ 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*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgehrd", rblapack_dgehrd, -1);
+}
diff --git a/ext/dgejsv.c b/ext/dgejsv.c
new file mode 100644
index 0000000..9e02694
--- /dev/null
+++ b/ext/dgejsv.c
@@ -0,0 +1,159 @@
+#include "rb_lapack.h"
+
+extern VOID dgejsv_(char* joba, char* jobu, char* jobv, char* jobr, char* jobt, char* jobp, integer* m, integer* n, doublereal* a, integer* lda, doublereal* sva, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgejsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_joba;
+ char joba;
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobr;
+ char jobr;
+ VALUE rblapack_jobt;
+ char jobt;
+ VALUE rblapack_jobp;
+ char jobp;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sva;
+ doublereal *sva;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_work_out__;
+ doublereal *work_out__;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ 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 sva, u, v, iwork, info, work = NumRu::Lapack.dgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEJSV computes the singular value decomposition (SVD) of a real M-by-N\n* matrix [A], where M >= N. The SVD of [A] is written as\n*\n* [A] = [U] * [SIGMA] * [V]^t,\n*\n* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N\n* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and\n* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are\n* the singular values of [A]. The columns of [U] and [V] are the left and\n* the right singular vectors of [A], respectively. The matrices [U] and [V]\n* are computed and stored in the arrays U and V, respectively. The diagonal\n* of [SIGMA] is computed and stored in the array SVA.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER*1\n* Specifies the level of accuracy:\n* = 'C': This option works well (high relative accuracy) if A = B * D,\n* with well-conditioned B and arbitrary diagonal matrix D.\n* The accuracy cannot be spoiled by COLUMN scaling. The\n* accuracy of the computed output depends on the condition of\n* B, and the procedure aims at the best theoretical accuracy.\n* The relative error max_{i=1:N}|d sigma_i| / sigma_i is\n* bounded by f(M,N)*epsilon* cond(B), independent of D.\n* The input matrix is preprocessed with the QRF with column\n* pivoting. This initial preprocessing and preconditioning by\n* a rank revealing QR factorization is common for all values of\n* JOBA. Additional actions are specified as follows:\n* = 'E': Computation as with 'C' with an additional estimate of the\n* condition number of B. It provides a realistic error bound.\n* = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings\n* D1, D2, and well-conditioned matrix C, this option gives\n* higher accuracy than the 'C' option. If the structure of the\n* input matrix is not known, and relative accuracy is\n* desirable, then this option is advisable. The input matrix A\n* is preprocessed with QR factorization with FULL (row and\n* column) pivoting.\n* = 'G' Computation as with 'F' with an additional estimate of the\n* condition number of B, where A=D*B. If A has heavily weighted\n* rows, then using this condition number gives too pessimistic\n* error bound.\n* = 'A': Small singular values are the noise and the matrix is treated\n* as numerically rank defficient. The error in the computed\n* singular values is bounded by f(m,n)*epsilon*||A||.\n* The computed SVD A = U * S * V^t restores A up to\n* f(m,n)*epsilon*||A||.\n* This gives the procedure the licence to discard (set to zero)\n* all singular values below N*epsilon*||A||.\n* = 'R': Similar as in 'A'. Rank revealing property of the initial\n* QR factorization is used do reveal (using triangular factor)\n* a gap sigma_{r+1} < epsilon * sigma_r in which case the\n* numerical RANK is declared to be r. The SVD is computed with\n* absolute error bounds, but more accurately than with 'A'.\n*\n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the columns of U:\n* = 'U': N columns of U are returned in the array U.\n* = 'F': full set of M left sing. vectors is returned in the array U.\n* = 'W': U may be used as workspace of length M*N. See the description\n* of U.\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the matrix V:\n* = 'V': N columns of V are returned in the array V; Jacobi rotations\n* are not explicitly accumulated.\n* = 'J': N columns of V are returned in the array V, but they are\n* computed as the product of Jacobi rotations. This option is\n* allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.\n* = 'W': V may be used as workspace of length N*N. See the description\n* of V.\n* = 'N': V is not computed.\n*\n* JOBR (input) CHARACTER*1\n* Specifies the RANGE for the singular values. Issues the licence to\n* set to zero small positive singular values if they are outside\n* specified range. If A .NE. 0 is scaled so that the largest singular\n* value of c*A is around DSQRT(BIG), BIG=SLAMCH('O'), then JOBR issues\n* the licence to kill columns of A whose norm in c*A is less than\n* DSQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN,\n* where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').\n* = 'N': Do not kill small columns of c*A. This option assumes that\n* BLAS and QR factorizations and triangular solvers are\n* implemented to work in that range. If the condition of A\n* is greater than BIG, use DGESVJ.\n* = 'R': RESTRICTED range for sigma(c*A) is [DSQRT(SFMIN), DSQRT(BIG)]\n* (roughly, as described above). This option is recommended.\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* For computing the singular values in the FULL range [SFMIN,BIG]\n* use DGESVJ.\n*\n* JOBT (input) CHARACTER*1\n* If the matrix is square then the procedure may determine to use\n* transposed A if A^t seems to be better with respect to convergence.\n* If the matrix is not square, JOBT is ignored. This is subject to\n* changes in the future.\n* The decision is based on two values of entropy over the adjoint\n* orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).\n* = 'T': transpose if entropy test indicates possibly faster\n* convergence of Jacobi process if A^t is taken as input. If A is\n* replaced with A^t, then the row pivoting is included automatically.\n* = 'N': do not speculate.\n* This option can be used to compute only the singular values, or the\n* full SVD (U, SIGMA and V). For only one set of singular vectors\n* (U or V), the caller should provide both U and V, as one of the\n* matrices is used as workspace if the matrix A is transposed.\n* The implementer can easily remove this constraint and make the\n* code more complicated. See the descriptions of U and V.\n*\n* JOBP (input) CHARACTER*1\n* Issues the licence to introduce structured perturbations to drown\n* denormalized numbers. This licence should be active if the\n* denormals are poorly implemented, causing slow computation,\n* especially in cases of fast convergence (!). For details see [1,2].\n* For the sake of simplicity, this perturbations are included only\n* when the full SVD or only the singular values are requested. The\n* implementer/user can easily add the perturbation for the cases of\n* computing one set of singular vectors.\n* = 'P': introduce perturbation\n* = 'N': do not perturb\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. M >= N >= 0.\n*\n* A (input/workspace) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) DOUBLE PRECISION array, dimension (N)\n* On exit,\n* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the\n* computation SVA contains Euclidean column norms of the\n* iterated matrices in the array A.\n* - For WORK(1) .NE. WORK(2): The singular values of A are\n* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if\n* sigma_max(A) overflows or if small singular values have been\n* saved from underflow by scaling the input matrix A.\n* - If JOBR='R' then some of the singular values may be returned\n* as exact zeros obtained by \"set to zero\" because they are\n* below the numerical rank threshold or are denormalized numbers.\n*\n* U (workspace/output) DOUBLE PRECISION array, dimension ( LDU, N )\n* If JOBU = 'U', then U contains on exit the M-by-N matrix of\n* the left singular vectors.\n* If JOBU = 'F', then U contains on exit the M-by-M matrix of\n* the left singular vectors, including an ONB\n* of the orthogonal complement of the Range(A).\n* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N),\n* then U is used as workspace if the procedure\n* replaces A with A^t. In that case, [V] is computed\n* in U as left singular vectors of A^t and then\n* copied back to the V array. This 'W' option is just\n* a reminder to the caller that in this case U is\n* reserved as workspace of length N*N.\n* If JOBU = 'N' U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U, LDU >= 1.\n* IF JOBU = 'U' or 'F' or 'W', then LDU >= M.\n*\n* V (workspace/output) DOUBLE PRECISION array, dimension ( LDV, N )\n* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N),\n* then V is used as workspace if the pprocedure\n* replaces A with A^t. In that case, [U] is computed\n* in V as right singular vectors of A^t and then\n* copied back to the U array. This 'W' option is just\n* a reminder to the caller that in this case V is\n* reserved as workspace of length N*N.\n* If JOBV = 'N' V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV >= 1.\n* If JOBV = 'V' or 'J' or 'W', then LDV >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension at least LWORK.\n* On exit,\n* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such\n* that SCALE*SVA(1:N) are the computed singular values\n* of A. (See the description of SVA().)\n* WORK(2) = See the description of WORK(1).\n* WORK(3) = SCONDA is an estimate for the condition number of\n* column equilibrated A. (If JOBA .EQ. 'E' or 'G')\n* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).\n* It is computed using DPOCON. It holds\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n* where R is the triangular factor from the QRF of A.\n* However, if R is truncated and the numerical rank is\n* determined to be strictly smaller than N, SCONDA is\n* returned as -1, thus indicating that the smallest\n* singular values might be lost.\n*\n* If full SVD is needed, the following two condition numbers are\n* useful for the analysis of the algorithm. They are provied for\n* a developer/implementer who is familiar with the details of\n* the method.\n*\n* WORK(4) = an estimate of the scaled condition number of the\n* triangular factor in the first QR factorization.\n* WORK(5) = an estimate of the scaled condition number of the\n* triangular factor in the second QR factorization.\n* The following two parameters are computed if JOBT .EQ. 'T'.\n* They are provided for a developer/implementer who is familiar\n* with the details of the method.\n*\n* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy\n* of diag(A^t*A) / Trace(A^t*A) taken as point in the\n* probability simplex.\n* WORK(7) = the entropy of A*A^t.\n*\n* LWORK (input) INTEGER\n* Length of WORK to confirm proper allocation of work space.\n* LWORK depends on the job:\n*\n* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and\n* -> .. no scaled condition estimate required ( JOBE.EQ.'N'):\n* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.\n* For optimal performance (blocked code) the optimal value\n* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal\n* block size for xGEQP3/xGEQRF.\n* -> .. an estimate of the scaled condition number of A is\n* required (JOBA='E', 'G'). In this case, LWORK is the maximum\n* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7).\n*\n* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'),\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If SIGMA and the left singular vectors are needed\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and\n* -> .. the singular vectors are computed without explicit\n* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N\n* -> .. in the iterative part, the Jacobi rotations are\n* explicitly accumulated (option, see the description of JOBV),\n* then the minimal requirement is LWORK >= max(M+3*N+N*N,7).\n* For better performance, if NB is the optimal block size,\n* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7).\n*\n* IWORK (workspace/output) INTEGER array, dimension M+3*N.\n* On exit,\n* IWORK(1) = the numerical rank determined after the initial\n* QR factorization with pivoting. See the descriptions\n* of JOBA and JOBR.\n* IWORK(2) = the number of the computed nonzero singular values\n* IWORK(3) = if nonzero, a warning message:\n* If IWORK(3).EQ.1 then some of the column norms of A\n* were denormalized floats. The requested high accuracy\n* is not warranted by the data.\n*\n* INFO (output) INTEGER\n* < 0 : if INFO = -i, then the i-th argument had an illegal value.\n* = 0 : successfull exit;\n* > 0 : DGEJSV did not converge in the maximal allowed number\n* of sweeps. The computed values may be inaccurate.\n*\n\n* Further Details\n* ===============\n*\n* DGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,\n* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an\n* additional row pivoting can be used as a preprocessor, which in some\n* cases results in much higher accuracy. An example is matrix A with the\n* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned\n* diagonal matrices and C is well-conditioned matrix. In that case, complete\n* pivoting in the first QR factorizations provides accuracy dependent on the\n* condition number of C, and independent of D1, D2. Such higher accuracy is\n* not completely understood theoretically, but it works well in practice.\n* Further, if A can be written as A = B*D, with well-conditioned B and some\n* diagonal D, then the high accuracy is guaranteed, both theoretically and\n* in software, independent of D. For more details see [1], [2].\n* The computational range for the singular values can be the full range\n* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS\n* & LAPACK routines called by DGEJSV are implemented to work in that range.\n* If that is not the case, then the restriction for safe computation with\n* the singular values in the range of normalized IEEE numbers is that the\n* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not\n* overflow. This code (DGEJSV) is best used in this restricted range,\n* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are\n* returned as zeros. See JOBR for details on this.\n* Further, this implementation is somewhat slower than the one described\n* in [1,2] due to replacement of some non-LAPACK components, and because\n* the choice of some tuning parameters in the iterative part (DGESVJ) is\n* left to the implementer on a particular machine.\n* The rank revealing QR factorization (in this code: SGEQP3) should be\n* implemented as in [3]. We have a new version of SGEQP3 under development\n* that is more robust than the current one in LAPACK, with a cleaner cut in\n* rank defficient cases. It will be available in the SIGMA library [4].\n* If M is much larger than N, it is obvious that the inital QRF with\n* column pivoting can be preprocessed by the QRF without pivoting. That\n* well known trick is not used in DGEJSV because in some cases heavy row\n* weighting can be treated with complete pivoting. The overhead in cases\n* M much larger than N is then only due to pivoting, but the benefits in\n* terms of accuracy have prevailed. The implementer/user can incorporate\n* this extra QRF step easily. The implementer can also improve data movement\n* (matrix transpose, matrix copy, matrix transposed copy) - this\n* implementation of DGEJSV uses only the simplest, naive data movement.\n*\n* Contributors\n*\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n*\n* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR\n* factorization software - a case study.\n* ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28.\n* LAPACK Working note 176.\n* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, examples and comments\n* \n* Please report all bugs and send interesting examples and/or comments to\n* drmac at math.hr. Thank you.\n*\n* ==========================================================================\n*\n* .. Local Parameters ..\n DOUBLE PRECISION ZERO, ONE\n PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK,\n & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM,\n & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC\n INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING\n LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC,\n & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN,\n & NOSCAL, ROWPIV, RSVEC, TRANSP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DLOG, DMAX1, DMIN1, DBLE,\n & MAX0, MIN0, IDNINT, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DLAMCH, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DLAMCH, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DGELQF, DGEQP3, DGEQRF, DLACPY, DLASCL,\n & DLASET, DLASSQ, DLASWP, DORGQR, DORMLQ,\n & DORMQR, DPOCON, DSCAL, DSWAP, DTRSM, XERBLA\n*\n EXTERNAL DGESVJ\n* ..\n*\n* Test the input arguments\n*\n LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' )\n JRACC = LSAME( JOBV, 'J' )\n RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC\n ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' )\n L2RANK = LSAME( JOBA, 'R' )\n L2ABER = LSAME( JOBA, 'A' )\n ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' )\n L2TRAN = LSAME( JOBT, 'T' )\n L2KILL = LSAME( JOBR, 'R' )\n DEFR = LSAME( JOBR, 'N' )\n L2PERT = LSAME( JOBP, 'P' )\n*\n IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR.\n & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN\n INFO = - 1\n ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR.\n & LSAME( JOBU, 'W' )) ) THEN\n INFO = - 2\n ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR.\n & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN\n INFO = - 3\n ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN\n INFO = - 4\n ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN\n INFO = - 5\n ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN\n INFO = - 6\n ELSE IF ( M .LT. 0 ) THEN\n INFO = - 7\n ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN\n INFO = - 8\n ELSE IF ( LDA .LT. M ) THEN\n INFO = - 10\n ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN\n INFO = - 13\n ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN\n INFO = - 14\n ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND.\n & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR.\n & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND.\n & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR.\n & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N))\n & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N)))\n & THEN\n INFO = - 17\n ELSE\n* #:)\n INFO = 0\n END IF\n*\n IF ( INFO .NE. 0 ) THEN\n* #:(\n CALL XERBLA( 'DGEJSV', - INFO )\n END IF\n*\n* Quick return for void matrix (Y3K safe)\n* #:)\n IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN\n*\n* Determine whether the matrix U should be M x N or M x M\n*\n IF ( LSVEC ) THEN\n N1 = N\n IF ( LSAME( JOBU, 'F' ) ) N1 = M\n END IF\n*\n* Set numerical parameters\n*\n*! NOTE: Make sure DLAMCH() does not fail on the target architecture.\n*\n\n EPSLN = DLAMCH('Epsilon')\n SFMIN = DLAMCH('SafeMinimum')\n SMALL = SFMIN / EPSLN\n BIG = DLAMCH('O')\n* BIG = ONE / SFMIN\n*\n* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N\n*\n*(!) If necessary, scale SVA() to protect the largest norm from\n* overflow. It is possible that this scaling pushes the smallest\n* column norm left from the underflow threshold (extreme case).\n*\n SCALEM = ONE / DSQRT(DBLE(M)*DBLE(N))\n NOSCAL = .TRUE.\n GOSCAL = .TRUE.\n DO 1874 p = 1, N\n AAPP = ZERO\n AAQQ = ONE\n CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ )\n IF ( AAPP .GT. BIG ) THEN\n INFO = - 9\n CALL XERBLA( 'DGEJSV', -INFO )\n RETURN\n END IF\n AAQQ = DSQRT(AAQQ)\n IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN\n SVA(p) = AAPP * AAQQ\n ELSE\n NOSCAL = .FALSE.\n SVA(p) = AAPP * ( AAQQ * SCALEM )\n IF ( GOSCAL ) THEN\n GOSCAL = .FALSE.\n CALL DSCAL( p-1, SCALEM, SVA, 1 )\n END IF\n END IF\n 1874 CONTINUE\n*\n IF ( NOSCAL ) SCALEM = ONE\n*\n AAPP = ZERO\n AAQQ = BIG\n DO 4781 p = 1, N\n AAPP = DMAX1( AAPP, SVA(p) )\n IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) )\n 4781 CONTINUE\n*\n* Quick return for zero M x N matrix\n* #:)\n IF ( AAPP .EQ. ZERO ) THEN\n IF ( LSVEC ) CALL DLASET( 'G', M, N1, ZERO, ONE, U, LDU )\n IF ( RSVEC ) CALL DLASET( 'G', N, N, ZERO, ONE, V, LDV )\n WORK(1) = ONE\n WORK(2) = ONE\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n IWORK(1) = 0\n IWORK(2) = 0\n RETURN\n END IF\n*\n* Issue warning if denormalized column norms detected. Override the\n* high relative accuracy request. Issue licence to kill columns\n* (set them to zero) whose norm is less than sigma_max / BIG (roughly).\n* #:(\n WARNING = 0\n IF ( AAQQ .LE. SFMIN ) THEN\n L2RANK = .TRUE.\n L2KILL = .TRUE.\n WARNING = 1\n END IF\n*\n* Quick return for one-column matrix\n* #:)\n IF ( N .EQ. 1 ) THEN\n*\n IF ( LSVEC ) THEN\n CALL DLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )\n CALL DLACPY( 'A', M, 1, A, LDA, U, LDU )\n* computing all M left singular vectors of the M x 1 matrix\n IF ( N1 .NE. N ) THEN\n CALL DGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )\n CALL DORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )\n CALL DCOPY( M, A(1,1), 1, U(1,1), 1 )\n END IF\n END IF\n IF ( RSVEC ) THEN\n V(1,1) = ONE\n END IF\n IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN\n SVA(1) = SVA(1) / SCALEM\n SCALEM = ONE\n END IF\n WORK(1) = ONE / SCALEM\n WORK(2) = ONE\n IF ( SVA(1) .NE. ZERO ) THEN\n IWORK(1) = 1\n IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN\n IWORK(2) = 1\n ELSE\n IWORK(2) = 0\n END IF\n ELSE\n IWORK(1) = 0\n IWORK(2) = 0\n END IF\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n RETURN\n*\n END IF\n*\n TRANSP = .FALSE.\n L2TRAN = L2TRAN .AND. ( M .EQ. N )\n*\n AATMAX = -ONE\n AATMIN = BIG\n IF ( ROWPIV .OR. L2TRAN ) THEN\n*\n* Compute the row norms, needed to determine row pivoting sequence\n* (in the case of heavily row weighted A, row pivoting is strongly\n* advised) and to collect information needed to compare the\n* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).\n*\n IF ( L2TRAN ) THEN\n DO 1950 p = 1, M\n XSC = ZERO\n TEMP1 = ONE\n CALL DLASSQ( N, A(p,1), LDA, XSC, TEMP1 )\n* DLASSQ gets both the ell_2 and the ell_infinity norm\n* in one pass through the vector\n WORK(M+N+p) = XSC * SCALEM\n WORK(N+p) = XSC * (SCALEM*DSQRT(TEMP1))\n AATMAX = DMAX1( AATMAX, WORK(N+p) )\n IF (WORK(N+p) .NE. ZERO) AATMIN = DMIN1(AATMIN,WORK(N+p))\n 1950 CONTINUE\n ELSE\n DO 1904 p = 1, M\n WORK(M+N+p) = SCALEM*DABS( A(p,IDAMAX(N,A(p,1),LDA)) )\n AATMAX = DMAX1( AATMAX, WORK(M+N+p) )\n AATMIN = DMIN1( AATMIN, WORK(M+N+p) )\n 1904 CONTINUE\n END IF\n*\n END IF\n*\n* For square matrix A try to determine whether A^t would be better\n* input for the preconditioned Jacobi SVD, with faster convergence.\n* The decision is based on an O(N) function of the vector of column\n* and row norms of A, based on the Shannon entropy. This should give\n* the right choice in most cases when the difference actually matters.\n* It may fail and pick the slower converging side.\n*\n ENTRA = ZERO\n ENTRAT = ZERO\n IF ( L2TRAN ) THEN\n*\n XSC = ZERO\n TEMP1 = ONE\n CALL DLASSQ( N, SVA, 1, XSC, TEMP1 )\n TEMP1 = ONE / TEMP1\n*\n ENTRA = ZERO\n DO 1113 p = 1, N\n BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1)\n 1113 CONTINUE\n ENTRA = - ENTRA / DLOG(DBLE(N))\n*\n* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.\n* It is derived from the diagonal of A^t * A. Do the same with the\n* diagonal of A * A^t, compute the entropy of the corresponding\n* probability distribution. Note that A * A^t and A^t * A have the\n* same trace.\n*\n ENTRAT = ZERO\n DO 1114 p = N+1, N+M\n BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1)\n 1114 CONTINUE\n ENTRAT = - ENTRAT / DLOG(DBLE(M))\n*\n* Analyze the entropies and decide A or A^t. Smaller entropy\n* usually means better input for the algorithm.\n*\n TRANSP = ( ENTRAT .LT. ENTRA )\n*\n* If A^t is better than A, transpose A.\n*\n IF ( TRANSP ) THEN\n* In an optimal implementation, this trivial transpose\n* should be replaced with faster transpose.\n DO 1115 p = 1, N - 1\n DO 1116 q = p + 1, N\n TEMP1 = A(q,p)\n A(q,p) = A(p,q)\n A(p,q) = TEMP1\n 1116 CONTINUE\n 1115 CONTINUE\n DO 1117 p = 1, N\n WORK(M+N+p) = SVA(p)\n SVA(p) = WORK(N+p)\n 1117 CONTINUE\n TEMP1 = AAPP\n AAPP = AATMAX\n AATMAX = TEMP1\n TEMP1 = AAQQ\n AAQQ = AATMIN\n AATMIN = TEMP1\n KILL = LSVEC\n LSVEC = RSVEC\n RSVEC = KILL\n IF ( LSVEC ) N1 = N\n*\n ROWPIV = .TRUE.\n END IF\n*\n END IF\n* END IF L2TRAN\n*\n* Scale the matrix so that its maximal singular value remains less\n* than DSQRT(BIG) -- the matrix is scaled so that its maximal column\n* has Euclidean norm equal to DSQRT(BIG/N). The only reason to keep\n* DSQRT(BIG) instead of BIG is the fact that DGEJSV uses LAPACK and\n* BLAS routines that, in some implementations, are not capable of\n* working in the full interval [SFMIN,BIG] and that they may provoke\n* overflows in the intermediate results. If the singular values spread\n* from SFMIN to BIG, then DGESVJ will compute them. So, in that case,\n* one should use DGESVJ instead of DGEJSV.\n*\n BIG1 = DSQRT( BIG )\n TEMP1 = DSQRT( BIG / DBLE(N) )\n*\n CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR )\n IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN\n AAQQ = ( AAQQ / AAPP ) * TEMP1\n ELSE\n AAQQ = ( AAQQ * TEMP1 ) / AAPP\n END IF\n TEMP1 = TEMP1 * SCALEM\n CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR )\n*\n* To undo scaling at the end of this procedure, multiply the\n* computed singular values with USCAL2 / USCAL1.\n*\n USCAL1 = TEMP1\n USCAL2 = AAPP\n*\n IF ( L2KILL ) THEN\n* L2KILL enforces computation of nonzero singular values in\n* the restricted range of condition number of the initial A,\n* sigma_max(A) / sigma_min(A) approx. DSQRT(BIG)/DSQRT(SFMIN).\n XSC = DSQRT( SFMIN )\n ELSE\n XSC = SMALL\n*\n* Now, if the condition number of A is too big,\n* sigma_max(A) / sigma_min(A) .GT. DSQRT(BIG/N) * EPSLN / SFMIN,\n* as a precaution measure, the full SVD is computed using DGESVJ\n* with accumulated Jacobi rotations. This provides numerically\n* more robust computation, at the cost of slightly increased run\n* time. Depending on the concrete implementation of BLAS and LAPACK\n* (i.e. how they behave in presence of extreme ill-conditioning) the\n* implementor may decide to remove this switch.\n IF ( ( AAQQ.LT.DSQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN\n JRACC = .TRUE.\n END IF\n*\n END IF\n IF ( AAQQ .LT. XSC ) THEN\n DO 700 p = 1, N\n IF ( SVA(p) .LT. XSC ) THEN\n CALL DLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA )\n SVA(p) = ZERO\n END IF\n 700 CONTINUE\n END IF\n*\n* Preconditioning using QR factorization with pivoting\n*\n IF ( ROWPIV ) THEN\n* Optional row permutation (Bjoerck row pivoting):\n* A result by Cox and Higham shows that the Bjoerck's\n* row pivoting combined with standard column pivoting\n* has similar effect as Powell-Reid complete pivoting.\n* The ell-infinity norms of A are made nonincreasing.\n DO 1952 p = 1, M - 1\n q = IDAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1\n IWORK(2*N+p) = q\n IF ( p .NE. q ) THEN\n TEMP1 = WORK(M+N+p)\n WORK(M+N+p) = WORK(M+N+q)\n WORK(M+N+q) = TEMP1\n END IF\n 1952 CONTINUE\n CALL DLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 )\n END IF\n*\n* End of the preparation phase (scaling, optional sorting and\n* transposing, optional flushing of small columns).\n*\n* Preconditioning\n*\n* If the full SVD is needed, the right singular vectors are computed\n* from a matrix equation, and for that we need theoretical analysis\n* of the Businger-Golub pivoting. So we use DGEQP3 as the first RR QRF.\n* In all other cases the first RR QRF can be chosen by other criteria\n* (eg speed by replacing global with restricted window pivoting, such\n* as in SGEQPX from TOMS # 782). Good results will be obtained using\n* SGEQPX with properly (!) chosen numerical parameters.\n* Any improvement of DGEQP3 improves overal performance of DGEJSV.\n*\n* A * P1 = Q1 * [ R1^t 0]^t:\n DO 1963 p = 1, N\n* .. all columns are free columns\n IWORK(p) = 0\n 1963 CONTINUE\n CALL DGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR )\n*\n* The upper triangular matrix R1 from the first QRF is inspected for\n* rank deficiency and possibilities for deflation, or possible\n* ill-conditioning. Depending on the user specified flag L2RANK,\n* the procedure explores possibilities to reduce the numerical\n* rank by inspecting the computed upper triangular factor. If\n* L2RANK or L2ABER are up, then DGEJSV will compute the SVD of\n* A + dA, where ||dA|| <= f(M,N)*EPSLN.\n*\n NR = 1\n IF ( L2ABER ) THEN\n* Standard absolute error bound suffices. All sigma_i with\n* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an\n* agressive enforcement of lower numerical rank by introducing a\n* backward error of the order of N*EPSLN*||A||.\n TEMP1 = DSQRT(DBLE(N))*EPSLN\n DO 3001 p = 2, N\n IF ( DABS(A(p,p)) .GE. (TEMP1*DABS(A(1,1))) ) THEN\n NR = NR + 1\n ELSE\n GO TO 3002\n END IF\n 3001 CONTINUE\n 3002 CONTINUE\n ELSE IF ( L2RANK ) THEN\n* .. similarly as above, only slightly more gentle (less agressive).\n* Sudden drop on the diagonal of R1 is used as the criterion for\n* close-to-rank-defficient.\n TEMP1 = DSQRT(SFMIN)\n DO 3401 p = 2, N\n IF ( ( DABS(A(p,p)) .LT. (EPSLN*DABS(A(p-1,p-1))) ) .OR.\n & ( DABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402\n NR = NR + 1\n 3401 CONTINUE\n 3402 CONTINUE\n*\n ELSE\n* The goal is high relative accuracy. However, if the matrix\n* has high scaled condition number the relative accuracy is in\n* general not feasible. Later on, a condition number estimator\n* will be deployed to estimate the scaled condition number.\n* Here we just remove the underflowed part of the triangular\n* factor. This prevents the situation in which the code is\n* working hard to get the accuracy not warranted by the data.\n TEMP1 = DSQRT(SFMIN)\n DO 3301 p = 2, N\n IF ( ( DABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302\n NR = NR + 1\n 3301 CONTINUE\n 3302 CONTINUE\n*\n END IF\n*\n ALMORT = .FALSE.\n IF ( NR .EQ. N ) THEN\n MAXPRJ = ONE\n DO 3051 p = 2, N\n TEMP1 = DABS(A(p,p)) / SVA(IWORK(p))\n MAXPRJ = DMIN1( MAXPRJ, TEMP1 )\n 3051 CONTINUE\n IF ( MAXPRJ**2 .GE. ONE - DBLE(N)*EPSLN ) ALMORT = .TRUE.\n END IF\n*\n*\n SCONDA = - ONE\n CONDR1 = - ONE\n CONDR2 = - ONE\n*\n IF ( ERREST ) THEN\n IF ( N .EQ. NR ) THEN\n IF ( RSVEC ) THEN\n* .. V is available as workspace\n CALL DLACPY( 'U', N, N, A, LDA, V, LDV )\n DO 3053 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL DSCAL( p, ONE/TEMP1, V(1,p), 1 )\n 3053 CONTINUE\n CALL DPOCON( 'U', N, V, LDV, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE IF ( LSVEC ) THEN\n* .. U is available as workspace\n CALL DLACPY( 'U', N, N, A, LDA, U, LDU )\n DO 3054 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL DSCAL( p, ONE/TEMP1, U(1,p), 1 )\n 3054 CONTINUE\n CALL DPOCON( 'U', N, U, LDU, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE\n CALL DLACPY( 'U', N, N, A, LDA, WORK(N+1), N )\n DO 3052 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL DSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 )\n 3052 CONTINUE\n* .. the columns of R are scaled to have unit Euclidean lengths.\n CALL DPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1,\n & WORK(N+N*N+1), IWORK(2*N+M+1), IERR )\n END IF\n SCONDA = ONE / DSQRT(TEMP1)\n* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1).\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n ELSE\n SCONDA = - ONE\n END IF\n END IF\n*\n L2PERT = L2PERT .AND. ( DABS( A(1,1)/A(NR,NR) ) .GT. DSQRT(BIG1) )\n* If there is no violent scaling, artificial perturbation is not needed.\n*\n* Phase 3:\n*\n\n IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN\n*\n* Singular Values only\n*\n* .. transpose A(1:NR,1:N)\n DO 1946 p = 1, MIN0( N-1, NR )\n CALL DCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1946 CONTINUE\n*\n* The following two DO-loops introduce small relative perturbation\n* into the strict upper triangle of the lower triangular matrix.\n* Small entries below the main diagonal are also changed.\n* This modification is useful if the computing environment does not\n* provide/allow FLUSH TO ZERO underflow, for it prevents many\n* annoying denormalized numbers in case of strongly scaled matrices.\n* The perturbation is structured so that it does not introduce any\n* new perturbation of the singular values, and it does not destroy\n* the job done by the preconditioner.\n* The licence for this perturbation is in the variable L2PERT, which\n* should be .FALSE. if FLUSH TO ZERO underflow is active.\n*\n IF ( .NOT. ALMORT ) THEN\n*\n IF ( L2PERT ) THEN\n* XSC = DSQRT(SMALL)\n XSC = EPSLN / DBLE(N)\n DO 4947 q = 1, NR\n TEMP1 = XSC*DABS(A(q,q))\n DO 4949 p = 1, N\n IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = DSIGN( TEMP1, A(p,q) )\n 4949 CONTINUE\n 4947 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA )\n END IF\n*\n* .. second preconditioning using the QR factorization\n*\n CALL DGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR )\n*\n* .. and transpose upper to lower triangular\n DO 1948 p = 1, NR - 1\n CALL DCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1948 CONTINUE\n*\n END IF\n*\n* Row-cyclic Jacobi SVD algorithm with column pivoting\n*\n* .. again some perturbation (a \"background noise\") is added\n* to drown denormals\n IF ( L2PERT ) THEN\n* XSC = DSQRT(SMALL)\n XSC = EPSLN / DBLE(N)\n DO 1947 q = 1, NR\n TEMP1 = XSC*DABS(A(q,q))\n DO 1949 p = 1, NR\n IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = DSIGN( TEMP1, A(p,q) )\n 1949 CONTINUE\n 1947 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA )\n END IF\n*\n* .. and one-sided Jacobi rotations are started on a lower\n* triangular matrix (plus perturbation which is ignored in\n* the part which destroys triangular form (confusing?!))\n*\n CALL DGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,\n & N, V, LDV, WORK, LWORK, INFO )\n*\n SCALEM = WORK(1)\n NUMRANK = IDNINT(WORK(2))\n*\n*\n ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN\n*\n* -> Singular Values and Right Singular Vectors <-\n*\n IF ( ALMORT ) THEN\n*\n* .. in this case NR equals N\n DO 1998 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1998 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL DGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,\n & WORK, LWORK, INFO )\n SCALEM = WORK(1)\n NUMRANK = IDNINT(WORK(2))\n\n ELSE\n*\n* .. two more QR factorizations ( one QRF is not enough, two require\n* accumulated product of Jacobi rotations, three are perfect )\n*\n CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )\n CALL DGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)\n CALL DLACPY( 'Lower', NR, NR, A, LDA, V, LDV )\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n CALL DGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n DO 8998 p = 1, NR\n CALL DCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )\n 8998 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL DGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,\n & LDU, WORK(N+1), LWORK, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = IDNINT(WORK(N+2))\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV )\n CALL DLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )\n END IF\n*\n CALL DORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK,\n & V, LDV, WORK(N+1), LWORK-N, IERR )\n*\n END IF\n*\n DO 8991 p = 1, N\n CALL DCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )\n 8991 CONTINUE\n CALL DLACPY( 'All', N, N, A, LDA, V, LDV )\n*\n IF ( TRANSP ) THEN\n CALL DLACPY( 'All', N, N, V, LDV, U, LDU )\n END IF\n*\n ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN\n*\n* .. Singular Values and Left Singular Vectors ..\n*\n* .. second preconditioning step to avoid need to accumulate\n* Jacobi rotations in the Jacobi iterations.\n DO 1965 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )\n 1965 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL DGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n DO 1967 p = 1, NR - 1\n CALL DCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )\n 1967 CONTINUE\n CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL DGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A,\n & LDA, WORK(N+1), LWORK-N, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = IDNINT(WORK(N+2))\n*\n IF ( NR .LT. M ) THEN\n CALL DLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )\n CALL DLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )\n END IF\n END IF\n*\n CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n DO 1974 p = 1, N1\n XSC = ONE / DNRM2( M, U(1,p), 1 )\n CALL DSCAL( M, XSC, U(1,p), 1 )\n 1974 CONTINUE\n*\n IF ( TRANSP ) THEN\n CALL DLACPY( 'All', N, N, U, LDU, V, LDV )\n END IF\n*\n ELSE\n*\n* .. Full SVD ..\n*\n IF ( .NOT. JRACC ) THEN\n*\n IF ( .NOT. ALMORT ) THEN\n*\n* Second Preconditioning Step (QRF [with pivoting])\n* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is\n* equivalent to an LQF CALL. Since in many libraries the QRF\n* seems to be better optimized than the LQF, we do explicit\n* transpose and use the QRF. This is subject to changes in an\n* optimized implementation of DGEJSV.\n*\n DO 1968 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1968 CONTINUE\n*\n* .. the following two loops perturb small entries to avoid\n* denormals in the second QR factorization, where they are\n* as good as zeros. This is done to avoid painfully slow\n* computation with denormals. The relative size of the perturbation\n* is a parameter that can be changed by the implementer.\n* This perturbation device will be obsolete on machines with\n* properly implemented arithmetic.\n* To switch it off, set L2PERT=.FALSE. To remove it from the\n* code, remove the action under L2PERT=.TRUE., leave the ELSE part.\n* The following two loops should be blocked and fused with the\n* transposed copy above.\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 2969 q = 1, NR\n TEMP1 = XSC*DABS( V(q,q) )\n DO 2968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = DSIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 2968 CONTINUE\n 2969 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n*\n* Estimate the row scaled condition number of R1\n* (If R1 is rectangular, N > NR, then the condition number\n* of the leading NR x NR submatrix is estimated.)\n*\n CALL DLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )\n DO 3950 p = 1, NR\n TEMP1 = DNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)\n CALL DSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)\n 3950 CONTINUE\n CALL DPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1,\n & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR)\n CONDR1 = ONE / DSQRT(TEMP1)\n* .. here need a second oppinion on the condition number\n* .. then assume worst case scenario\n* R1 is OK for inverse <=> CONDR1 .LT. DBLE(N)\n* more conservative <=> CONDR1 .LT. DSQRT(DBLE(N))\n*\n COND_OK = DSQRT(DBLE(NR))\n*[TP] COND_OK is a tuning parameter.\n\n IF ( CONDR1 .LT. COND_OK ) THEN\n* .. the second QRF without pivoting. Note: in an optimized\n* implementation, this QRF should be implemented as the QRF\n* of a lower triangular matrix.\n* R1^t = Q2 * R2\n CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)/EPSLN\n DO 3959 p = 2, NR\n DO 3958 q = 1, p - 1\n TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n IF ( DABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = DSIGN( TEMP1, V(q,p) )\n 3958 CONTINUE\n 3959 CONTINUE\n END IF\n*\n IF ( NR .NE. N )\n* .. save ...\n & CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n* .. this transposed copy should be better than naive\n DO 1969 p = 1, NR - 1\n CALL DCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 )\n 1969 CONTINUE\n*\n CONDR2 = CONDR1\n*\n ELSE\n*\n* .. ill-conditioned case: second QRF with pivoting\n* Note that windowed pivoting would be equaly good\n* numerically, and more run-time efficient. So, in\n* an optimal implementation, the next call to DGEQP3\n* should be replaced with eg. CALL SGEQPX (ACM TOMS #782)\n* with properly (carefully) chosen parameters.\n*\n* R1^t * P2 = Q2 * R2\n DO 3003 p = 1, NR\n IWORK(N+p) = 0\n 3003 CONTINUE\n CALL DGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),\n & WORK(2*N+1), LWORK-2*N, IERR )\n** CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n** & LWORK-2*N, IERR )\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 3969 p = 2, NR\n DO 3968 q = 1, p - 1\n TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n IF ( DABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = DSIGN( TEMP1, V(q,p) )\n 3968 CONTINUE\n 3969 CONTINUE\n END IF\n*\n CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 8970 p = 2, NR\n DO 8971 q = 1, p - 1\n TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q)))\n V(p,q) = - DSIGN( TEMP1, V(q,p) )\n 8971 CONTINUE\n 8970 CONTINUE\n ELSE\n CALL DLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV )\n END IF\n* Now, compute R2 = L3 * Q3, the LQ factorization.\n CALL DGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1),\n & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR )\n* .. and estimate the condition number\n CALL DLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )\n DO 4950 p = 1, NR\n TEMP1 = DNRM2( p, WORK(2*N+N*NR+NR+p), NR )\n CALL DSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )\n 4950 CONTINUE\n CALL DPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1,\n & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR )\n CONDR2 = ONE / DSQRT(TEMP1)\n*\n IF ( CONDR2 .GE. COND_OK ) THEN\n* .. save the Householder vectors used for Q3\n* (this overwrittes the copy of R2, as it will not be\n* needed in this branch, but it does not overwritte the\n* Huseholder vectors of Q2.).\n CALL DLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N )\n* .. and the rest of the information on Q3 is in\n* WORK(2*N+N*NR+1:2*N+N*NR+N)\n END IF\n*\n END IF\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 4968 q = 2, NR\n TEMP1 = XSC * V(q,q)\n DO 4969 p = 1, q - 1\n* V(p,q) = - DSIGN( TEMP1, V(q,p) )\n V(p,q) = - DSIGN( TEMP1, V(p,q) )\n 4969 CONTINUE\n 4968 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV )\n END IF\n*\n* Second preconditioning finished; continue with Jacobi SVD\n* The input matrix is lower trinagular.\n*\n* Recover the right singular vectors as solution of a well\n* conditioned triangular matrix equation.\n*\n IF ( CONDR1 .LT. COND_OK ) THEN\n*\n CALL DGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U,\n & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n DO 3970 p = 1, NR\n CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL DSCAL( NR, SVA(p), V(1,p), 1 )\n 3970 CONTINUE\n\n* .. pick the right matrix equation and solve it\n*\n IF ( NR. EQ. N ) THEN\n* :)) .. best case, R1 is inverted. The solution of this matrix\n* equation is Q2*V2 = the product of the Jacobi rotations\n* used in DGESVJ, premultiplied with the orthogonal matrix\n* from the second QR factorization.\n CALL DTRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV )\n ELSE\n* .. R1 is well conditioned, but non-square. Transpose(R2)\n* is inverted to get the product of the Jacobi rotations\n* used in DGESVJ. The Q-factor from the second QR\n* factorization is then built in explicitly.\n CALL DTRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),\n & N,V,LDV)\n IF ( NR .LT. N ) THEN\n CALL DLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)\n CALL DLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)\n CALL DLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)\n END IF\n CALL DORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR)\n END IF\n*\n ELSE IF ( CONDR2 .LT. COND_OK ) THEN\n*\n* :) .. the input matrix A is very likely a relative of\n* the Kahan matrix :)\n* The matrix R2 is inverted. The solution of the matrix equation\n* is Q3^T*V3 = the product of the Jacobi rotations (appplied to\n* the lower triangular L3 from the LQ factorization of\n* R2=L3*Q3), pre-multiplied with the transposed Q3.\n CALL DGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n DO 3870 p = 1, NR\n CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL DSCAL( NR, SVA(p), U(1,p), 1 )\n 3870 CONTINUE\n CALL DTRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU)\n* .. apply the permutation from the second QR factorization\n DO 873 q = 1, NR\n DO 872 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 872 CONTINUE\n DO 874 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 874 CONTINUE\n 873 CONTINUE\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n ELSE\n* Last line of defense.\n* #:( This is a rather pathological case: no scaled condition\n* improvement after two pivoted QR factorizations. Other\n* possibility is that the rank revealing QR factorization\n* or the condition estimator has failed, or the COND_OK\n* is set very close to ONE (which is unnecessary). Normally,\n* this branch should never be executed, but in rare cases of\n* failure of the RRQR or condition estimator, the last line of\n* defense ensures that DGEJSV completes the task.\n* Compute the full SVD of L3 using DGESVJ with explicit\n* accumulation of Jacobi rotations.\n CALL DGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2))\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n CALL DORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N,\n & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1),\n & LWORK-2*N-N*NR-NR, IERR )\n DO 773 q = 1, NR\n DO 772 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 772 CONTINUE\n DO 774 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 774 CONTINUE\n 773 CONTINUE\n*\n END IF\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = DSQRT(DBLE(N)) * EPSLN\n DO 1972 q = 1, N\n DO 972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 972 CONTINUE\n DO 973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 973 CONTINUE\n XSC = ONE / DNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( N, XSC, V(1,q), 1 )\n 1972 CONTINUE\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n IF ( NR .LT. M ) THEN\n CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL DLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)\n CALL DLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU)\n END IF\n END IF\n*\n* The Q matrix from the first QRF is built into the left singular\n* matrix U. This applies to all cases.\n*\n CALL DORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n\n* The columns of U are normalized. The cost is O(M*N) flops.\n TEMP1 = DSQRT(DBLE(M)) * EPSLN\n DO 1973 p = 1, NR\n XSC = ONE / DNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( M, XSC, U(1,p), 1 )\n 1973 CONTINUE\n*\n* If the initial QRF is computed with row pivoting, the left\n* singular vectors must be adjusted.\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n ELSE\n*\n* .. the initial matrix A has almost orthogonal columns and\n* the second QRF is not needed\n*\n CALL DLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL)\n DO 5970 p = 2, N\n TEMP1 = XSC * WORK( N + (p-1)*N + p )\n DO 5971 q = 1, p - 1\n WORK(N+(q-1)*N+p)=-DSIGN(TEMP1,WORK(N+(p-1)*N+q))\n 5971 CONTINUE\n 5970 CONTINUE\n ELSE\n CALL DLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )\n END IF\n*\n CALL DGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA,\n & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO )\n*\n SCALEM = WORK(N+N*N+1)\n NUMRANK = IDNINT(WORK(N+N*N+2))\n DO 6970 p = 1, N\n CALL DCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )\n CALL DSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )\n 6970 CONTINUE\n*\n CALL DTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,\n & ONE, A, LDA, WORK(N+1), N )\n DO 6972 p = 1, N\n CALL DCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )\n 6972 CONTINUE\n TEMP1 = DSQRT(DBLE(N))*EPSLN\n DO 6971 p = 1, N\n XSC = ONE / DNRM2( N, V(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( N, XSC, V(1,p), 1 )\n 6971 CONTINUE\n*\n* Assemble the left singular vector matrix U (M x N).\n*\n IF ( N .LT. M ) THEN\n CALL DLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU )\n IF ( N .LT. N1 ) THEN\n CALL DLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU )\n CALL DLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )\n END IF\n END IF\n CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n TEMP1 = DSQRT(DBLE(M))*EPSLN\n DO 6973 p = 1, N1\n XSC = ONE / DNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( M, XSC, U(1,p), 1 )\n 6973 CONTINUE\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n END IF\n*\n* end of the >> almost orthogonal case << in the full SVD\n*\n ELSE\n*\n* This branch deploys a preconditioned Jacobi SVD with explicitly\n* accumulated rotations. It is included as optional, mainly for\n* experimental purposes. It does perfom well, and can also be used.\n* In this implementation, this branch will be automatically activated\n* if the condition number sigma_max(A) / sigma_min(A) is predicted\n* to be greater than the overflow threshold. This is because the\n* a posteriori computation of the singular vectors assumes robust\n* implementation of BLAS and some LAPACK procedures, capable of working\n* in presence of extreme values. Since that is not always the case, ...\n*\n DO 7968 p = 1, NR\n CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 7968 CONTINUE\n*\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL/EPSLN)\n DO 5969 q = 1, NR\n TEMP1 = XSC*DABS( V(q,q) )\n DO 5968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = DSIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 5968 CONTINUE\n 5969 CONTINUE\n ELSE\n CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n\n CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n CALL DLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )\n*\n DO 7969 p = 1, NR\n CALL DCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )\n 7969 CONTINUE\n\n IF ( L2PERT ) THEN\n XSC = DSQRT(SMALL/EPSLN)\n DO 9970 q = 2, NR\n DO 9971 p = 1, q - 1\n TEMP1 = XSC * DMIN1(DABS(U(p,p)),DABS(U(q,q)))\n U(p,q) = - DSIGN( TEMP1, U(q,p) )\n 9971 CONTINUE\n 9970 CONTINUE\n ELSE\n CALL DLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n END IF\n\n CALL DGESVJ( 'G', 'U', 'V', NR, NR, U, LDU, SVA,\n & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO )\n SCALEM = WORK(2*N+N*NR+1)\n NUMRANK = IDNINT(WORK(2*N+N*NR+2))\n\n IF ( NR .LT. N ) THEN\n CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n\n CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = DSQRT(DBLE(N)) * EPSLN\n DO 7972 q = 1, N\n DO 8972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 8972 CONTINUE\n DO 8973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 8973 CONTINUE\n XSC = ONE / DNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL DSCAL( N, XSC, V(1,q), 1 )\n 7972 CONTINUE\n*\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n*\n IF ( NR .LT. M ) THEN\n CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU )\n CALL DLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )\n END IF\n END IF\n*\n CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n*\n END IF\n IF ( TRANSP ) THEN\n* .. swap U and V because the procedure worked on A^t\n DO 6974 p = 1, N\n CALL DSWAP( N, U(1,p), 1, V(1,p), 1 )\n 6974 CONTINUE\n END IF\n*\n END IF\n* end of the full SVD\n*\n* Undo scaling, if necessary (and possible)\n*\n IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN\n CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR )\n USCAL1 = ONE\n USCAL2 = ONE\n END IF\n*\n IF ( NR .LT. N ) THEN\n DO 3004 p = NR+1, N\n SVA(p) = ZERO\n 3004 CONTINUE\n END IF\n*\n WORK(1) = USCAL2 * SCALEM\n WORK(2) = USCAL1\n IF ( ERREST ) WORK(3) = SCONDA\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = CONDR1\n WORK(5) = CONDR2\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ENTRA\n WORK(7) = ENTRAT\n END IF\n*\n IWORK(1) = NR\n IWORK(2) = NUMRANK\n IWORK(3) = WARNING\n*\n RETURN\n* ..\n* .. END OF DGEJSV\n* ..\n END\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sva, u, v, iwork, info, work = NumRu::Lapack.dgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_joba = argv[0];
+ rblapack_jobu = argv[1];
+ rblapack_jobv = argv[2];
+ rblapack_jobr = argv[3];
+ rblapack_jobt = argv[4];
+ rblapack_jobp = argv[5];
+ rblapack_m = argv[6];
+ rblapack_a = argv[7];
+ rblapack_work = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ joba = StringValueCStr(rblapack_joba)[0];
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ jobt = StringValueCStr(rblapack_jobt)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (9th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
+ lwork = NA_SHAPE0(rblapack_work);
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobp = StringValueCStr(rblapack_jobp)[0];
+ ldu = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? m : 1;
+ jobr = StringValueCStr(rblapack_jobr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (8th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (8th 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*);
+ ldv = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&jobu,"N")&&lsame_(&jobv,"N")) ? MAX(MAX(2*m+n,4*n+n*n),7) : lsame_(&jobv,"V") ? MAX(2*n+m,7) : ((lsame_(&jobu,"U")||lsame_(&jobu,"F"))&&lsame_(&jobv,"V")) ? MAX(MAX(6*n+2*n*n,m+3*n+n*n),7) : MAX(2*n+m,7);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = n;
+ rblapack_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int shape[1];
+ shape[0] = m+3*n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = lwork;
+ rblapack_work_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work_out__ = NA_PTR_TYPE(rblapack_work_out__, doublereal*);
+ MEMCPY(work_out__, work, doublereal, NA_TOTAL(rblapack_work));
+ rblapack_work = rblapack_work_out__;
+ work = work_out__;
+
+ dgejsv_(&joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a, &lda, sva, u, &ldu, v, &ldv, work, &lwork, iwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_sva, rblapack_u, rblapack_v, rblapack_iwork, rblapack_info, rblapack_work);
+}
+
+void
+init_lapack_dgejsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgejsv", rblapack_dgejsv, -1);
+}
diff --git a/ext/dgelq2.c b/ext/dgelq2.c
new file mode 100644
index 0000000..7290332
--- /dev/null
+++ b/ext/dgelq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID dgelq2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgelq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELQ2 computes an LQ factorization of a real m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgelq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (m));
+
+ dgelq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgelq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgelq2", rblapack_dgelq2, -1);
+}
diff --git a/ext/dgelqf.c b/ext/dgelqf.c
new file mode 100644
index 0000000..3a19031
--- /dev/null
+++ b/ext/dgelqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dgelqf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgelqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 tau, work, info, a = NumRu::Lapack.dgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELQF computes an LQ factorization of a real M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgelqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgelqf", rblapack_dgelqf, -1);
+}
diff --git a/ext/dgels.c b/ext/dgels.c
new file mode 100644
index 0000000..d6858dc
--- /dev/null
+++ b/ext/dgels.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID dgels_(char* trans, integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgels(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 work, info, a, b = NumRu::Lapack.dgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELS solves overdetermined or underdetermined real linear systems\n* involving an M-by-N matrix A, or its transpose, using a QR or LQ\n* factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided:\n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of\n* an undetermined system A**T * X = B.\n*\n* 4. If TRANS = 'T' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**T * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'T': the linear system involves A**T.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by DGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by DGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'T'.\n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of\n* elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.dgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } 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 (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*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(4, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dgels(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgels", rblapack_dgels, -1);
+}
diff --git a/ext/dgelsd.c b/ext/dgelsd.c
new file mode 100644
index 0000000..baee53b
--- /dev/null
+++ b/ext/dgelsd.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID dgelsd_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgelsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+ integer c__9;
+ integer c__0;
+ integer liwork;
+ integer nlvl;
+ integer smlsiz;
+
+ 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 s, rank, work, info, b = NumRu::Lapack.dgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder transformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n* if M is greater than or equal to N or\n* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* For good performance, LWORK should generally be larger.\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 (MAX(1,LIWORK))\n* LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, b = NumRu::Lapack.dgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ 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*);
+ rcond = NUM2DBL(rblapack_rcond);
+ m = lda;
+ c__9 = 9;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldb = MAX(m,n);
+ c__0 = 0;
+ smlsiz = ilaenv_(&c__9,"DGELSD"," ",&c__0,&c__0,&c__0,&c__0);
+ nlvl = MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1));
+ if (rblapack_lwork == Qnil)
+ lwork = m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ liwork = 3*(MIN(m,n))*nlvl+11*(MIN(m,n));
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+
+ dgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgelsd", rblapack_dgelsd, -1);
+}
diff --git a/ext/dgelss.c b/ext/dgelss.c
new file mode 100644
index 0000000..93b75df
--- /dev/null
+++ b/ext/dgelss.c
@@ -0,0 +1,148 @@
+#include "rb_lapack.h"
+
+extern VOID dgelss_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgelss(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 s, rank, work, info, a, b = NumRu::Lapack.dgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELSS computes the minimum norm solution to a real linear least\n* squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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, and also:\n* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n* For good performance, LWORK should generally be larger.\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* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.dgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ 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*);
+ rcond = NUM2DBL(rblapack_rcond);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, &info);
+
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgelss", rblapack_dgelss, -1);
+}
diff --git a/ext/dgelsx.c b/ext/dgelsx.c
new file mode 100644
index 0000000..78c38b8
--- /dev/null
+++ b/ext/dgelsx.c
@@ -0,0 +1,136 @@
+#include "rb_lapack.h"
+
+extern VOID dgelsx_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgelsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 rank, info, a, b, jpvt = NumRu::Lapack.dgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGELSY.\n*\n* DGELSX computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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 rank, info, a, b, jpvt = NumRu::Lapack.dgelsx( m, a, b, jpvt, rcond, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_rcond = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ rcond = NUM2DBL(rblapack_rcond);
+ 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*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(doublereal, (MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)));
+
+ dgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_dgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgelsx", rblapack_dgelsx, -1);
+}
diff --git a/ext/dgelsy.c b/ext/dgelsy.c
new file mode 100644
index 0000000..66f6803
--- /dev/null
+++ b/ext/dgelsy.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID dgelsy_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgelsy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 rank, work, info, a, b, jpvt = NumRu::Lapack.dgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGELSY computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of AP\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* The unblocked strategy requires that:\n* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n* where MN = min( M, N ).\n* The block algorithm requires that:\n* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,\n* and DORMRZ.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.dgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_jpvt = argv[2];
+ rblapack_rcond = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ rcond = NUM2DBL(rblapack_rcond);
+ ldb = MAX(m,n);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+
+ dgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, &info);
+
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_dgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgelsy", rblapack_dgelsy, -1);
+}
diff --git a/ext/dgeql2.c b/ext/dgeql2.c
new file mode 100644
index 0000000..6ed5b21
--- /dev/null
+++ b/ext/dgeql2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID dgeql2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgeql2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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 tau, info, a = NumRu::Lapack.dgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQL2 computes a QL factorization of a real m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgeql2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n));
+
+ dgeql2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeql2", rblapack_dgeql2, -1);
+}
diff --git a/ext/dgeqlf.c b/ext/dgeqlf.c
new file mode 100644
index 0000000..b193069
--- /dev/null
+++ b/ext/dgeqlf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dgeqlf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgeqlf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 tau, work, info, a = NumRu::Lapack.dgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQLF computes a QL factorization of a real M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeqlf", rblapack_dgeqlf, -1);
+}
diff --git a/ext/dgeqp3.c b/ext/dgeqp3.c
new file mode 100644
index 0000000..9b5eddf
--- /dev/null
+++ b/ext/dgeqp3.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID dgeqp3_(integer* m, integer* n, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgeqp3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_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 tau, work, info, a, jpvt = NumRu::Lapack.dgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* orthogonal matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= 3*N+1.\n* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n* is the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.dgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n+1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+
+ dgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_dgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeqp3", rblapack_dgeqp3, -1);
+}
diff --git a/ext/dgeqpf.c b/ext/dgeqpf.c
new file mode 100644
index 0000000..9d12656
--- /dev/null
+++ b/ext/dgeqpf.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID dgeqpf_(integer* m, integer* n, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgeqpf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ doublereal *work;
+
+ 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 tau, info, a, jpvt = NumRu::Lapack.dgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DGEQP3.\n*\n* DGEQPF computes a QR factorization with column pivoting of a\n* real M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the orthogonal matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.dgeqpf( m, a, jpvt, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(doublereal, (3*n));
+
+ dgeqpf_(&m, &n, a, &lda, jpvt, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_dgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeqpf", rblapack_dgeqpf, -1);
+}
diff --git a/ext/dgeqr2.c b/ext/dgeqr2.c
new file mode 100644
index 0000000..c481b80
--- /dev/null
+++ b/ext/dgeqr2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID dgeqr2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgeqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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 tau, info, a = NumRu::Lapack.dgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQR2 computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgeqr2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n));
+
+ dgeqr2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeqr2", rblapack_dgeqr2, -1);
+}
diff --git a/ext/dgeqr2p.c b/ext/dgeqr2p.c
new file mode 100644
index 0000000..d733904
--- /dev/null
+++ b/ext/dgeqr2p.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID dgeqr2p_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgeqr2p(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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 tau, info, a = NumRu::Lapack.dgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQR2 computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgeqr2p( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n));
+
+ dgeqr2p_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeqr2p", rblapack_dgeqr2p, -1);
+}
diff --git a/ext/dgeqrf.c b/ext/dgeqrf.c
new file mode 100644
index 0000000..915de53
--- /dev/null
+++ b/ext/dgeqrf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dgeqrf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgeqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 tau, work, info, a = NumRu::Lapack.dgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQRF computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeqrf", rblapack_dgeqrf, -1);
+}
diff --git a/ext/dgeqrfp.c b/ext/dgeqrfp.c
new file mode 100644
index 0000000..b42b035
--- /dev/null
+++ b/ext/dgeqrfp.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dgeqrfp_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgeqrfp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 tau, work, info, a = NumRu::Lapack.dgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGEQRFP computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQR2P, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgeqrfp", rblapack_dgeqrfp, -1);
+}
diff --git a/ext/dgerfs.c b/ext/dgerfs.c
new file mode 100644
index 0000000..d6683c7
--- /dev/null
+++ b/ext/dgerfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID dgerfs_(char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgerfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.dgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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 matrices B and X. NRHS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dgerfs( trans, a, af, ipiv, 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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, 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_dgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgerfs", rblapack_dgerfs, -1);
+}
diff --git a/ext/dgerfsx.c b/ext/dgerfsx.c
new file mode 100644
index 0000000..f4649d4
--- /dev/null
+++ b/ext/dgerfsx.c
@@ -0,0 +1,219 @@
+#include "rb_lapack.h"
+
+extern VOID dgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgerfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.dgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. \n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.dgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_r = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_x = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (6th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_dgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgerfsx", rblapack_dgerfsx, -1);
+}
diff --git a/ext/dgerq2.c b/ext/dgerq2.c
new file mode 100644
index 0000000..f0ba5d6
--- /dev/null
+++ b/ext/dgerq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID dgerq2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dgerq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERQ2 computes an RQ factorization of a real m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the orthogonal matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dgerq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (m));
+
+ dgerq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgerq2", rblapack_dgerq2, -1);
+}
diff --git a/ext/dgerqf.c b/ext/dgerqf.c
new file mode 100644
index 0000000..f765cc4
--- /dev/null
+++ b/ext/dgerqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dgerqf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgerqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 tau, work, info, a = NumRu::Lapack.dgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGERQF computes an RQ factorization of a real M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgerqf", rblapack_dgerqf, -1);
+}
diff --git a/ext/dgesc2.c b/ext/dgesc2.c
new file mode 100644
index 0000000..0156529
--- /dev/null
+++ b/ext/dgesc2.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID dgesc2_(integer* n, doublereal* a, integer* lda, doublereal* rhs, integer* ipiv, integer* jpiv, doublereal* scale);
+
+
+static VALUE
+rblapack_dgesc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_rhs;
+ doublereal *rhs;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_rhs_out__;
+ doublereal *rhs_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 scale, rhs = NumRu::Lapack.dgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* DGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by DGETC2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by DGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) DOUBLE PRECISION array, dimension (N).\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.dgesc2( a, rhs, ipiv, jpiv, [: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_a = argv[0];
+ rblapack_rhs = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_jpiv = argv[3];
+ if (argc == 4) {
+ } 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th 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 1 of a");
+ 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_rhs))
+ rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rhs) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_rhs) != NA_DFLOAT)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_DFLOAT);
+ rhs = NA_PTR_TYPE(rblapack_rhs, doublereal*);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublereal*);
+ MEMCPY(rhs_out__, rhs, doublereal, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ dgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
+
+ rblapack_scale = rb_float_new((double)scale);
+ return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
+}
+
+void
+init_lapack_dgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgesc2", rblapack_dgesc2, -1);
+}
diff --git a/ext/dgesdd.c b/ext/dgesdd.c
new file mode 100644
index 0000000..075421e
--- /dev/null
+++ b/ext/dgesdd.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID dgesdd_(char* jobz, integer* m, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgesdd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ucol;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.dgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESDD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and right singular\n* vectors. If singular vectors are desired, it uses a\n* divide-and-conquer algorithm.\n*\n* The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**T, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**T are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**T are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* on the array A and all rows of V**T are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**T are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**T are computed.\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 >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**T (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* orthogonal matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N orthogonal matrix V**T;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 JOBZ = 'N',\n* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).\n* If JOBZ = 'O',\n* LWORK >= 3*min(M,N) + \n* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n* If JOBZ = 'S' or 'A'\n* LWORK >= 3*min(M,N) +\n* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n* For good performance, LWORK should generally be larger.\n* If LWORK = -1 but other input arguments are legal, WORK(1)\n* returns the optimal LWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: DBDSDC did not converge, updating process failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.dgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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*);
+ m = lda;
+ ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"N") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,"O") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
+ ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = ucol;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ iwork = ALLOC_N(integer, (8*MIN(m,n)));
+
+ dgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgesdd", rblapack_dgesdd, -1);
+}
diff --git a/ext/dgesv.c b/ext/dgesv.c
new file mode 100644
index 0000000..21a318c
--- /dev/null
+++ b/ext/dgesv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dgesv_(integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dgesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, a, b = NumRu::Lapack.dgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGESV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL DGETRF, DGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.dgesv( 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);
+ 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*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgesv", rblapack_dgesv, -1);
+}
diff --git a/ext/dgesvd.c b/ext/dgesvd.c
new file mode 100644
index 0000000..c4e4eed
--- /dev/null
+++ b/ext/dgesvd.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID dgesvd_(char* jobu, char* jobvt, integer* m, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgesvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobvt;
+ char jobvt;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.dgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**T, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**T:\n* = 'A': all N rows of V**T are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**T (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**T (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**T (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**T (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n* V**T;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;\n* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n* superdiagonal elements of an upper bidiagonal matrix B\n* whose diagonal is in S (not necessarily sorted). B\n* satisfies A = U * B * VT, so it has the same singular values\n* as A, and singular vectors related by U and VT.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n* For good performance, LWORK should generally be larger.\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* > 0: if DBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of WORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.dgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobu = argv[0];
+ rblapack_jobvt = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[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);
+ 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*);
+ m = lda;
+ ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
+ jobvt = StringValueCStr(rblapack_jobvt)[0];
+ ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n));
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = MAX(n, MIN(m,n));
+ rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
+ __shape__[2] = rblapack_a;
+ na_aset(3, __shape__, rblapack_a_out__);
+ }
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ dgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
+ rblapack_a = na_aref(2, __shape__, rblapack_a);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgesvd", rblapack_dgesvd, -1);
+}
diff --git a/ext/dgesvj.c b/ext/dgesvj.c
new file mode 100644
index 0000000..8cae660
--- /dev/null
+++ b/ext/dgesvj.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID dgesvj_(char* joba, char* jobu, char* jobv, integer* m, integer* n, doublereal* a, integer* lda, doublereal* sva, integer* mv, doublereal* v, integer* ldv, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgesvj(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_joba;
+ char joba;
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_mv;
+ integer mv;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sva;
+ doublereal *sva;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+ VALUE rblapack_work_out__;
+ doublereal *work_out__;
+
+ 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 sva, info, a, v, work = NumRu::Lapack.dgesvj( joba, jobu, jobv, m, a, mv, v, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVJ computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, where M >= N. The SVD of A is written as\n* [++] [xx] [x0] [xx]\n* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]\n* [++] [xx]\n* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n* of SIGMA are the singular values of A. The columns of U and V are the\n* left and the right singular vectors of A, respectively.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n* rotations. The rotations are implemented as fast scaled rotations of\n* Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n* column interchanges of de Rijk [2]. The relative accuracy of the computed\n* singular values and the accuracy of the computed singular vectors (in\n* angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n* The condition number that determines the accuracy in the full rank case\n* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n* spectral condition number. The best performance of this Jacobi SVD\n* procedure is achieved if used in an accelerated version of Drmac and\n* Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n* Some tunning parameters (marked with [TP]) are available for the\n* implementer.\n* The computational range for the nonzero singular values is the machine\n* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n* denormalized singular values can be computed with the corresponding\n* gradual loss of accurate digits.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n* ~~~~~~~~~~\n* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n* singular value decomposition on a vector computer.\n* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n* value computation in floating point arithmetic.\n* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER* 1\n* Specifies the structure of A.\n* = 'L': The input matrix A is lower triangular;\n* = 'U': The input matrix A is upper triangular;\n* = 'G': The input matrix A is general M-by-N matrix, M >= N.\n*\n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the left singular vectors\n* (columns of U):\n* = 'U': The left singular vectors corresponding to the nonzero\n* singular values are computed and returned in the leading\n* columns of A. See more details in the description of A.\n* The default numerical orthogonality threshold is set to\n* approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E').\n* = 'C': Analogous to JOBU='U', except that user can control the\n* level of numerical orthogonality of the computed left\n* singular vectors. TOL can be set to TOL = CTOL*EPS, where\n* CTOL is given on input in the array WORK.\n* No CTOL smaller than ONE is allowed. CTOL greater\n* than 1 / EPS is meaningless. The option 'C'\n* can be used if M*EPS is satisfactory orthogonality\n* of the computed left singular vectors, so CTOL=M could\n* save few sweeps of Jacobi rotations.\n* See the descriptions of A and WORK(1).\n* = 'N': The matrix U is not computed. However, see the\n* description of A.\n*\n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the right singular vectors, that\n* is, the matrix V:\n* = 'V' : the matrix V is computed and returned in the array V\n* = 'A' : the Jacobi rotations are applied to the MV-by-N\n* array V. In other words, the right singular vector\n* matrix V is not computed explicitly, instead it is\n* applied to an MV-by-N matrix initially stored in the\n* first MV rows of V.\n* = 'N' : the matrix V is not computed and the array V is not\n* referenced\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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit :\n* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' :\n* If INFO .EQ. 0 :\n* RANKA orthonormal columns of U are returned in the\n* leading RANKA columns of the array A. Here RANKA <= N\n* is the number of computed singular values of A that are\n* above the underflow threshold DLAMCH('S'). The singular\n* vectors corresponding to underflowed or zero singular\n* values are not computed. The value of RANKA is returned\n* in the array WORK as RANKA=NINT(WORK(2)). Also see the\n* descriptions of SVA and WORK. The computed columns of U\n* are mutually numerically orthogonal up to approximately\n* TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n* see the description of JOBU.\n* If INFO .GT. 0 :\n* the procedure DGESVJ did not converge in the given number\n* of iterations (sweeps). In that case, the computed\n* columns of U may not be orthogonal up to TOL. The output\n* U (stored in A), SIGMA (given by the computed singular\n* values in SVA(1:N)) and V is still a decomposition of the\n* input matrix A in the sense that the residual\n* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n*\n* If JOBU .EQ. 'N' :\n* If INFO .EQ. 0 :\n* Note that the left singular vectors are 'for free' in the\n* one-sided Jacobi SVD algorithm. However, if only the\n* singular values are needed, the level of numerical\n* orthogonality of U is not an issue and iterations are\n* stopped when the columns of the iterated matrix are\n* numerically orthogonal up to approximately M*EPS. Thus,\n* on exit, A contains the columns of U scaled with the\n* corresponding singular values.\n* If INFO .GT. 0 :\n* the procedure DGESVJ did not converge in the given number\n* of iterations (sweeps).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) DOUBLE PRECISION array, dimension (N)\n* On exit :\n* If INFO .EQ. 0 :\n* depending on the value SCALE = WORK(1), we have:\n* If SCALE .EQ. ONE :\n* SVA(1:N) contains the computed singular values of A.\n* During the computation SVA contains the Euclidean column\n* norms of the iterated matrices in the array A.\n* If SCALE .NE. ONE :\n* The singular values of A are SCALE*SVA(1:N), and this\n* factored representation is due to the fact that some of the\n* singular values of A might underflow or overflow.\n* If INFO .GT. 0 :\n* the procedure DGESVJ did not converge in the given number of\n* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n*\n* MV (input) INTEGER\n* If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ\n* is applied to the first MV rows of V. See the description of JOBV.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n* If JOBV = 'V', then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'A', then V contains the product of the computed right\n* singular vector matrix and the initial matrix in\n* the array V.\n* If JOBV = 'N', then V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV .GE. 1.\n* If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n*\n* WORK (input/workspace/output) DOUBLE PRECISION array, dimension max(4,M+N).\n* On entry :\n* If JOBU .EQ. 'C' :\n* WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n* The process stops if all columns of A are mutually\n* orthogonal up to CTOL*EPS, EPS=DLAMCH('E').\n* It is required that CTOL >= ONE, i.e. it is not\n* allowed to force the routine to obtain orthogonality\n* below EPS.\n* On exit :\n* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n* are the computed singular values of A.\n* (See description of SVA().)\n* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n* singular values.\n* WORK(3) = NINT(WORK(3)) is the number of the computed singular\n* values that are larger than the underflow threshold.\n* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n* rotations needed for numerical convergence.\n* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n* This is useful information in cases when DGESVJ did\n* not converge, as it can be used to estimate whether\n* the output is stil useful and for post festum analysis.\n* WORK(6) = the largest absolute value over all sines of the\n* Jacobi rotation angles in the last sweep. It can be\n* useful for a post festum analysis.\n*\n* LWORK (input) INTEGER\n* length of WORK, WORK >= MAX(6,M+N)\n*\n* INFO (output) INTEGER\n* = 0 : successful exit.\n* < 0 : if INFO = -i, then the i-th argument had an illegal value\n* > 0 : DGESVJ did not converge in the maximal allowed number (30)\n* of sweeps. The output may still be useful. See the\n* description of WORK.\n*\n\n* =====================================================================\n*\n* .. Local Parameters ..\n DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n INTEGER NSWEEP\n PARAMETER ( NSWEEP = 30 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n + THSIGN, TOL\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n + SWBAND\n LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n + RSVEC, UCTOL, UPPER\n* ..\n* .. Local Arrays ..\n DOUBLE PRECISION FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n* ..\n* from BLAS\n DOUBLE PRECISION DDOT, DNRM2\n EXTERNAL DDOT, DNRM2\n INTEGER IDAMAX\n EXTERNAL IDAMAX\n* from LAPACK\n DOUBLE PRECISION DLAMCH\n EXTERNAL DLAMCH\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n* ..\n* from BLAS\n EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP\n* from LAPACK\n EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA\n*\n EXTERNAL DGSVJ0, DGSVJ1\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sva, info, a, v, work = NumRu::Lapack.dgesvj( joba, jobu, jobv, m, a, mv, v, work, [: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_joba = argv[0];
+ rblapack_jobu = argv[1];
+ rblapack_jobv = argv[2];
+ rblapack_m = argv[3];
+ rblapack_a = argv[4];
+ rblapack_mv = argv[5];
+ rblapack_v = argv[6];
+ rblapack_work = 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;
+ }
+
+ joba = StringValueCStr(rblapack_joba)[0];
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th 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 1 of a");
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ mv = NUM2INT(rblapack_mv);
+ m = NUM2INT(rblapack_m);
+ lwork = MAX(4,m+n);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (8th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != lwork)
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be MAX(4,m+n)");
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = n;
+ rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ {
+ int shape[1];
+ shape[0] = lwork;
+ rblapack_work_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work_out__ = NA_PTR_TYPE(rblapack_work_out__, doublereal*);
+ MEMCPY(work_out__, work, doublereal, NA_TOTAL(rblapack_work));
+ rblapack_work = rblapack_work_out__;
+ work = work_out__;
+
+ dgesvj_(&joba, &jobu, &jobv, &m, &n, a, &lda, sva, &mv, v, &ldv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_sva, rblapack_info, rblapack_a, rblapack_v, rblapack_work);
+}
+
+void
+init_lapack_dgesvj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgesvj", rblapack_dgesvj, -1);
+}
diff --git a/ext/dgesvx.c b/ext/dgesvx.c
new file mode 100644
index 0000000..c382468
--- /dev/null
+++ b/ext/dgesvx.c
@@ -0,0 +1,278 @@
+#include "rb_lapack.h"
+
+extern VOID dgesvx_(char* fact, char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgesvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_af_out__;
+ doublereal *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.dgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVX uses the LU factorization to compute the solution to a real\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) DOUBLE PRECISION array, dimension (4*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.dgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 9) {
+ rblapack_af = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_equed = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ } else if (rblapack_options != Qnil) {
+ rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_af = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ 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*);
+ if (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ldaf = n;
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ }
+ if (rblapack_af != Qnil) {
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (option) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_af) != ldaf)
+ rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 4*n;
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
+ if (rblapack_af != Qnil) {
+ MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
+ }
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+
+ dgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_dgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgesvx", rblapack_dgesvx, -1);
+}
diff --git a/ext/dgesvxx.c b/ext/dgesvxx.c
new file mode 100644
index 0000000..a2e5133
--- /dev/null
+++ b/ext/dgesvxx.c
@@ -0,0 +1,281 @@
+#include "rb_lapack.h"
+
+extern VOID dgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgesvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_af_out__;
+ doublereal *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.dgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGESVXX uses the LU factorization to compute the solution to a\n* double precision system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In DGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.dgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_r = argv[6];
+ rblapack_c = argv[7];
+ rblapack_b = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_r))
+ rb_raise(rb_eArgError, "r (7th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
+ MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_dgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgesvxx", rblapack_dgesvxx, -1);
+}
diff --git a/ext/dgetc2.c b/ext/dgetc2.c
new file mode 100644
index 0000000..729e85d
--- /dev/null
+++ b/ext/dgetc2.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID dgetc2_(integer* n, doublereal* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);
+
+
+static VALUE
+rblapack_dgetc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ 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 ipiv, jpiv, info, a = NumRu::Lapack.dgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGETC2 computes an LU factorization with complete pivoting of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is the Level 2 BLAS algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the n-by-n matrix A to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, i.e., giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n* we try to solve for x in Ax = b. So U is perturbed to\n* avoid the overflow.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.dgetc2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ int 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__;
+
+ dgetc2_(&n, a, &lda, ipiv, jpiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgetc2", rblapack_dgetc2, -1);
+}
diff --git a/ext/dgetf2.c b/ext/dgetf2.c
new file mode 100644
index 0000000..66c3a5b
--- /dev/null
+++ b/ext/dgetf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID dgetf2_(integer* m, integer* n, doublereal* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_dgetf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ 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 ipiv, info, a = NumRu::Lapack.dgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.dgetf2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ dgetf2_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgetf2", rblapack_dgetf2, -1);
+}
diff --git a/ext/dgetrf.c b/ext/dgetrf.c
new file mode 100644
index 0000000..1a653c9
--- /dev/null
+++ b/ext/dgetrf.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID dgetrf_(integer* m, integer* n, doublereal* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_dgetrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ 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 ipiv, info, a = NumRu::Lapack.dgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.dgetrf( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ dgetrf_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgetrf", rblapack_dgetrf, -1);
+}
diff --git a/ext/dgetri.c b/ext/dgetri.c
new file mode 100644
index 0000000..486a851
--- /dev/null
+++ b/ext/dgetri.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dgetri_(integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgetri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 work, info, a = NumRu::Lapack.dgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGETRI computes the inverse of a matrix using the LU factorization\n* computed by DGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_a = argv[0];
+ rblapack_ipiv = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (2th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgetri", rblapack_dgetri, -1);
+}
diff --git a/ext/dgetrs.c b/ext/dgetrs.c
new file mode 100644
index 0000000..d2f6cdb
--- /dev/null
+++ b/ext/dgetrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dgetrs_(char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dgetrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGETRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by DGETRF.\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'* X = B (Transpose)\n* = 'C': A'* 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by DGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.dgetrs( trans, a, ipiv, b, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgetrs", rblapack_dgetrs, -1);
+}
diff --git a/ext/dggbak.c b/ext/dggbak.c
new file mode 100644
index 0000000..a9a1076
--- /dev/null
+++ b/ext/dggbak.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID dggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, integer* m, doublereal* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_dggbak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ doublereal *lscale;
+ VALUE rblapack_rscale;
+ doublereal *rscale;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.dggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* DGGBAK forms the right or left eigenvectors of a real generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* DGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to DGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by DGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by DGGBAL.\n*\n* RSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by DGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by DTGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSCAL, DSWAP, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.dggbak( job, side, ilo, ihi, lscale, rscale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_lscale = argv[4];
+ rblapack_rscale = argv[5];
+ rblapack_v = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_lscale))
+ rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_lscale) != 1)
+ rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_lscale);
+ if (NA_TYPE(rblapack_lscale) != NA_DFLOAT)
+ rblapack_lscale = na_change_type(rblapack_lscale, NA_DFLOAT);
+ lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_rscale))
+ rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
+ if (NA_RANK(rblapack_rscale) != 1)
+ rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rscale) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
+ if (NA_TYPE(rblapack_rscale) != NA_DFLOAT)
+ rblapack_rscale = na_change_type(rblapack_rscale, NA_DFLOAT);
+ rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ dggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_dggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggbak", rblapack_dggbak, -1);
+}
diff --git a/ext/dggbal.c b/ext/dggbal.c
new file mode 100644
index 0000000..532a267
--- /dev/null
+++ b/ext/dggbal.c
@@ -0,0 +1,128 @@
+#include "rb_lapack.h"
+
+extern VOID dggbal_(char* job, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dggbal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ doublereal *lscale;
+ VALUE rblapack_rscale;
+ doublereal *rscale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.dggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGBAL balances a pair of general real matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i = 1,...,N.\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j)\n* is the scaling factor applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j)\n* is the scaling factor applied to column j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.dggbal( job, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_job = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
+
+ dggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
+
+ free(work);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggbal", rblapack_dggbal, -1);
+}
diff --git a/ext/dgges.c b/ext/dgges.c
new file mode 100644
index 0000000..76b4bbc
--- /dev/null
+++ b/ext/dgges.c
@@ -0,0 +1,198 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(doublereal *arg0, doublereal *arg1, doublereal *arg2){
+ VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+ rblapack_arg2 = rb_float_new((double)(*arg2));
+
+ rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID dgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* sdim, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vsl, integer* ldvsl, doublereal* vsr, integer* ldvsr, doublereal* work, integer* lwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_dgges(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_vsl;
+ doublereal *vsl;
+ VALUE rblapack_vsr;
+ doublereal *vsr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n* the generalized eigenvalues, the generalized real Schur form (S,T),\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T.The\n* leading columns of VSL and VSR then form an orthonormal basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* DGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG);\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n*\n* Note that in the ill-conditioned case, a selected complex\n* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n* in this case.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N = 0, LWORK >= 1, else LWORK >= 8*N+16.\n* For good performance , LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ.\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in DTGSEN.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(8*n,6*n+16);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ dgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, bwork, &info);
+
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgges", rblapack_dgges, -1);
+}
diff --git a/ext/dggesx.c b/ext/dggesx.c
new file mode 100644
index 0000000..d447fe9
--- /dev/null
+++ b/ext/dggesx.c
@@ -0,0 +1,231 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(doublereal *arg0, doublereal *arg1, doublereal *arg2){
+ VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+ rblapack_arg2 = rb_float_new((double)(*arg2));
+
+ rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID dggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* sdim, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vsl, integer* ldvsl, doublereal* vsr, integer* ldvsr, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_dggesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_vsl;
+ doublereal *vsl;
+ VALUE rblapack_vsr;
+ doublereal *vsr;
+ VALUE rblapack_rconde;
+ doublereal *rconde;
+ VALUE rblapack_rcondv;
+ doublereal *rcondv;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer *iwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGESX computes for a pair of N-by-N real nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n* since ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition numbers for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n* LWORK >= max( 8*N, 6*N+16 ).\n* Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n* this may not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+6.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in DTGSEN.\n*\n\n* Further Details\n* ===============\n*\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / RCONDE( 1 ).\n*\n* An approximate (asymptotic) bound on the maximum angular error in\n* the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / RCONDV( 2 ).\n*\n* See LAPACK User's Guide, section 4.11 for more information.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 8) {
+ rblapack_lwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+6;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ dggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, iwork, &liwork, bwork, &info);
+
+ free(iwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggesx", rblapack_dggesx, -1);
+}
diff --git a/ext/dggev.c b/ext/dggev.c
new file mode 100644
index 0000000..f02a220
--- /dev/null
+++ b/ext/dggev.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID dggev_(char* jobvl, char* jobvr, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dggev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B .\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* alpha/beta. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ.\n* =N+2: error return from DTGEVC.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ 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*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(1,8*n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggev", rblapack_dggev, -1);
+}
diff --git a/ext/dggevx.c b/ext/dggevx.c
new file mode 100644
index 0000000..a774cee
--- /dev/null
+++ b/ext/dggevx.c
@@ -0,0 +1,229 @@
+#include "rb_lapack.h"
+
+extern VOID dggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* abnrm, doublereal* bbnrm, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_dggevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ doublereal *lscale;
+ VALUE rblapack_rscale;
+ doublereal *rscale;
+ VALUE rblapack_abnrm;
+ doublereal abnrm;
+ VALUE rblapack_bbnrm;
+ doublereal bbnrm;
+ VALUE rblapack_rconde;
+ doublereal *rconde;
+ VALUE rblapack_rcondv;
+ doublereal *rcondv;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer *iwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j) .\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed.\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* For a complex conjugate pair of eigenvalues two consecutive\n* elements of RCONDE are set to the same value. Thus RCONDE(j),\n* RCONDV(j), and the j-th columns of VL and VR all correspond\n* to the j-th eigenpair.\n* If SENSE = 'N or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* If SENSE = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. For a complex eigenvector two consecutive\n* elements of RCONDV are set to the same value. If the\n* eigenvalues cannot be reordered to compute RCONDV(j),\n* RCONDV(j) is set to 0; this can only occur when the true\n* value would be very small anyway.\n* If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,2*N).\n* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n* LWORK >= max(1,6*N).\n* If SENSE = 'E' or 'B', LWORK >= max(1,10*N).\n* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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 (N+6)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in DHGEQZ.\n* =N+2: error return from DTGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&balanc,"S")||lsame_(&balanc,"B")||lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 6*n : lsame_(&sense,"E") ? 10*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+8*n+16 : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+6));
+ bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
+
+ dggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, iwork, bwork, &info);
+
+ free(iwork);
+ free(bwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_bbnrm = rb_float_new((double)bbnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(17, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggevx", rblapack_dggevx, -1);
+}
diff --git a/ext/dggglm.c b/ext/dggglm.c
new file mode 100644
index 0000000..92a5461
--- /dev/null
+++ b/ext/dggglm.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID dggglm_(integer* n, integer* m, integer* p, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* d, doublereal* x, doublereal* y, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dggglm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ integer p;
+ 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 x, y, work, info, a, b, d = NumRu::Lapack.dggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) DOUBLE PRECISION array, dimension (M)\n* Y (output) DOUBLE PRECISION array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* DGEQRF, SGERQF, DORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.dggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_d = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_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);
+ p = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_y = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+
+ dggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
+}
+
+void
+init_lapack_dggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggglm", rblapack_dggglm, -1);
+}
diff --git a/ext/dgghrd.c b/ext/dgghrd.c
new file mode 100644
index 0000000..b4a27e9
--- /dev/null
+++ b/ext/dgghrd.c
@@ -0,0 +1,167 @@
+#include "rb_lapack.h"
+
+extern VOID dgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_dgghrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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, b, q, z = NumRu::Lapack.dgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* DGGHRD reduces a pair of real matrices (A,B) to generalized upper\n* Hessenberg form using orthogonal transformations, where A is a\n* general matrix and B is upper triangular. The form of the\n* generalized eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the orthogonal matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**T*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**T*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**T*x.\n*\n* The orthogonal matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n*\n* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n*\n* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n*\n* If Q1 is the orthogonal matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then DGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Z;\n* = 'I': Z is initialized to the unit matrix, and the\n* orthogonal matrix Z is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry,\n* and the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to SGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**T B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n* typically from the QR factorization of B.\n* On exit, if COMPQ='I', the orthogonal matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n* On exit, if COMPZ='I', the orthogonal matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and Van Loan (Johns Hopkins Press.)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.dgghrd( compq, compz, ilo, ihi, a, b, q, z, [: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_compq = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_dgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgghrd", rblapack_dgghrd, -1);
+}
diff --git a/ext/dgglse.c b/ext/dgglse.c
new file mode 100644
index 0000000..8fbd3d0
--- /dev/null
+++ b/ext/dgglse.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID dgglse_(integer* m, integer* n, integer* p, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, doublereal* d, doublereal* x, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgglse(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer m;
+ 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 x, work, info, a, b, c, d = NumRu::Lapack.dgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( (A) ) = N.\n* ( (B) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) DOUBLE PRECISION array, dimension (N)\n* On exit, X is the solution of the LSE problem.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* DGEQRF, SGERQF, DORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.dgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ m = NA_SHAPE0(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*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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);
+ p = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+
+ dgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
+}
+
+void
+init_lapack_dgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgglse", rblapack_dgglse, -1);
+}
diff --git a/ext/dggqrf.c b/ext/dggqrf.c
new file mode 100644
index 0000000..37ad3ee
--- /dev/null
+++ b/ext/dggqrf.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID dggqrf_(integer* n, integer* m, integer* p, doublereal* a, integer* lda, doublereal* taua, doublereal* b, integer* ldb, doublereal* taub, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dggqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ doublereal *taua;
+ VALUE rblapack_taub;
+ doublereal *taub;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.dggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the orthogonal matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the orthogonal\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of DORMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine DORGQR.\n* To use Q to update another matrix, use LAPACK subroutine DORMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine DORGRQ.\n* To use Z to update another matrix, use LAPACK subroutine DORMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.dggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_n = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ p = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(n,m);
+ rblapack_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(n,p);
+ rblapack_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggqrf", rblapack_dggqrf, -1);
+}
diff --git a/ext/dggrqf.c b/ext/dggrqf.c
new file mode 100644
index 0000000..b65d712
--- /dev/null
+++ b/ext/dggrqf.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID dggrqf_(integer* m, integer* p, integer* n, doublereal* a, integer* lda, doublereal* taua, doublereal* b, integer* ldb, doublereal* taub, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dggrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_p;
+ integer p;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ doublereal *taua;
+ VALUE rblapack_taub;
+ doublereal *taub;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.dggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the orthogonal\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the orthogonal matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of DORMRQ.\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 INF0= -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine DORGRQ.\n* To use Q to update another matrix, use LAPACK subroutine DORMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine DORGQR.\n* To use Z to update another matrix, use LAPACK subroutine DORMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.dggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_m = argv[0];
+ rblapack_p = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ 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*);
+ p = NUM2INT(rblapack_p);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(p,n);
+ rblapack_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggrqf", rblapack_dggrqf, -1);
+}
diff --git a/ext/dggsvd.c b/ext/dggsvd.c
new file mode 100644
index 0000000..bf95956
--- /dev/null
+++ b/ext/dggsvd.c
@@ -0,0 +1,181 @@
+#include "rb_lapack.h"
+
+extern VOID dggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* q, integer* ldq, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dggsvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_alpha;
+ doublereal *alpha;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.dggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N real matrix A and P-by-N real matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are orthogonal matrices, and Z' is the transpose\n* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',\n* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n* D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n* following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the orthogonal\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n* also equal to the CS decomposition of A and B. Furthermore, the GSVD\n* can be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) ).\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in the Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix R if M-K-L < 0.\n* See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n* BETA(K+1:M) =S, BETA(M+1:K+L) =1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) DOUBLE PRECISION array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) DOUBLE PRECISION array,\n* dimension (max(3*N,M,P)+N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine DTGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA DOUBLE PRECISION\n* TOLB DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n DOUBLE PRECISION DLAMCH, DLANGE\n EXTERNAL LSAME, DLAMCH, DLANGE\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DGGSVP, DTGSJA, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.dggsvd( jobu, jobv, jobq, a, b, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, (MAX(3*n,m)*(p)+n));
+
+ dggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, iwork, &info);
+
+ free(work);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggsvd", rblapack_dggsvd, -1);
+}
diff --git a/ext/dggsvp.c b/ext/dggsvp.c
new file mode 100644
index 0000000..cfe4508
--- /dev/null
+++ b/ext/dggsvp.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID dggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* tola, doublereal* tolb, integer* k, integer* l, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* q, integer* ldq, integer* iwork, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dggsvp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_tola;
+ doublereal tola;
+ VALUE rblapack_tolb;
+ doublereal tolb;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer *iwork;
+ doublereal *tau;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, u, v, q, info, a, b = NumRu::Lapack.dggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DGGSVP computes orthogonal matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* DGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU,M)\n* If JOBU = 'U', U contains the orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) DOUBLE PRECISION array, dimension (LDV,P)\n* If JOBV = 'V', V contains the orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* TAU (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))\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* Further Details\n* ===============\n*\n* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.dggsvp( jobu, jobv, jobq, a, b, tola, tolb, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_tola = argv[5];
+ rblapack_tolb = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ tolb = NUM2DBL(rblapack_tolb);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ tola = NUM2DBL(rblapack_tola);
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int 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*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+ tau = ALLOC_N(doublereal, (n));
+ work = ALLOC_N(doublereal, (MAX(MAX(3*n,m),p)));
+
+ dggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, tau, work, &info);
+
+ free(iwork);
+ free(tau);
+ free(work);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dggsvp", rblapack_dggsvp, -1);
+}
diff --git a/ext/dgsvj0.c b/ext/dgsvj0.c
new file mode 100644
index 0000000..34666f8
--- /dev/null
+++ b/ext/dgsvj0.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID dgsvj0_(char* jobv, integer* m, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* sva, integer* mv, doublereal* v, integer* ldv, doublereal* eps, doublereal* sfmin, doublereal* tol, integer* nsweep, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgsvj0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_sva;
+ doublereal *sva;
+ VALUE rblapack_mv;
+ integer mv;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_eps;
+ doublereal eps;
+ VALUE rblapack_sfmin;
+ doublereal sfmin;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_nsweep;
+ integer nsweep;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_sva_out__;
+ doublereal *sva_out__;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+ doublereal *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.dgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGSVJ0 is called from DGESVJ as a pre-processor and that is its main\n* purpose. It applies Jacobi rotations in the same way as DGESVJ does, but\n* it does not check convergence (stopping criterion). Few tuning\n* parameters (marked by [TP]) are available for the implementer.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* DGSVJ0 is used just to enable SGESVJ to call a simplified version of\n* itself to work on a submatrix of the original matrix.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\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* A (input/output) DOUBLE PRECISION 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 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) DOUBLE PRECISION 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 A, TOL and NSWEEP.)\n*\n* SVA (input/workspace/output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION\n* EPS = DLAMCH('Epsilon')\n*\n* SFMIN (input) DOUBLE PRECISION\n* SFMIN = DLAMCH('Safe Minimum')\n*\n* TOL (input) DOUBLE PRECISION\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 DABS(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) DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n + THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n + NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND\n LOGICAL APPLV, ROTOK, RSVEC\n* ..\n* .. Local Arrays ..\n DOUBLE PRECISION FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DDOT, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DDOT, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\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.dgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_jobv = argv[0];
+ rblapack_m = argv[1];
+ rblapack_a = argv[2];
+ rblapack_d = argv[3];
+ rblapack_sva = argv[4];
+ rblapack_mv = argv[5];
+ rblapack_v = argv[6];
+ rblapack_eps = argv[7];
+ rblapack_sfmin = argv[8];
+ rblapack_tol = argv[9];
+ rblapack_nsweep = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } 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];
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_sva))
+ rb_raise(rb_eArgError, "sva (5th argument) must be NArray");
+ if (NA_RANK(rblapack_sva) != 1)
+ rb_raise(rb_eArgError, "rank of sva (5th 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 1 of a");
+ if (NA_TYPE(rblapack_sva) != NA_DFLOAT)
+ rblapack_sva = na_change_type(rblapack_sva, NA_DFLOAT);
+ sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th 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 1 of a");
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ sfmin = NUM2DBL(rblapack_sfmin);
+ nsweep = NUM2INT(rblapack_nsweep);
+ m = NUM2INT(rblapack_m);
+ mv = NUM2INT(rblapack_mv);
+ tol = NUM2DBL(rblapack_tol);
+ 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 1 of a");
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ lwork = m;
+ eps = NUM2DBL(rblapack_eps);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_sva_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sva_out__ = NA_PTR_TYPE(rblapack_sva_out__, doublereal*);
+ MEMCPY(sva_out__, sva, doublereal, 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_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ work = ALLOC_N(doublereal, (lwork));
+
+ dgsvj0_(&jobv, &m, &n, 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_dgsvj0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgsvj0", rblapack_dgsvj0, -1);
+}
diff --git a/ext/dgsvj1.c b/ext/dgsvj1.c
new file mode 100644
index 0000000..b3cf3a1
--- /dev/null
+++ b/ext/dgsvj1.c
@@ -0,0 +1,186 @@
+#include "rb_lapack.h"
+
+extern VOID dgsvj1_(char* jobv, integer* m, integer* n, integer* n1, doublereal* a, integer* lda, doublereal* d, doublereal* sva, integer* mv, doublereal* v, integer* ldv, doublereal* eps, doublereal* sfmin, doublereal* tol, integer* nsweep, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dgsvj1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_sva;
+ doublereal *sva;
+ VALUE rblapack_mv;
+ integer mv;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_eps;
+ doublereal eps;
+ VALUE rblapack_sfmin;
+ doublereal sfmin;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_nsweep;
+ integer nsweep;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_sva_out__;
+ doublereal *sva_out__;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+ doublereal *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.dgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGSVJ1 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* DGSVJ1 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION\n* EPS = DLAMCH('Epsilon')\n*\n* SFMIN (input) DOUBLE PRECISION\n* SFMIN = DLAMCH('Safe Minimum')\n*\n* TOL (input) DOUBLE PRECISION\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 DABS(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) DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n* ..\n* .. Local Scalars ..\n DOUBLE PRECISION 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 DOUBLE PRECISION FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DDOT, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DDOT, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\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.dgsvj1( 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ mv = NUM2INT(rblapack_mv);
+ eps = NUM2DBL(rblapack_eps);
+ tol = 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_DFLOAT)
+ rblapack_sva = na_change_type(rblapack_sva, NA_DFLOAT);
+ sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
+ sfmin = NUM2DBL(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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_sva_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sva_out__ = NA_PTR_TYPE(rblapack_sva_out__, doublereal*);
+ MEMCPY(sva_out__, sva, doublereal, 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_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ work = ALLOC_N(doublereal, (lwork));
+
+ dgsvj1_(&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_dgsvj1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgsvj1", rblapack_dgsvj1, -1);
+}
diff --git a/ext/dgtcon.c b/ext/dgtcon.c
new file mode 100644
index 0000000..2c100ae
--- /dev/null
+++ b/ext/dgtcon.c
@@ -0,0 +1,124 @@
+#include "rb_lapack.h"
+
+extern VOID dgtcon_(char* norm, integer* n, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgtcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_du2;
+ doublereal *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *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.dgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGTCON estimates the reciprocal of the condition number of a real\n* tridiagonal matrix A using the LU factorization as computed by\n* DGTTRF.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by DGTTRF.\n*\n* D (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION 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) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dgtcon( 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ 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_DFLOAT)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
+ 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublereal, (2*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgtcon_(&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_dgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgtcon", rblapack_dgtcon, -1);
+}
diff --git a/ext/dgtrfs.c b/ext/dgtrfs.c
new file mode 100644
index 0000000..54b8649
--- /dev/null
+++ b/ext/dgtrfs.c
@@ -0,0 +1,209 @@
+#include "rb_lapack.h"
+
+extern VOID dgtrfs_(char* trans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* dlf, doublereal* df, doublereal* duf, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgtrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_dlf;
+ doublereal *dlf;
+ VALUE rblapack_df;
+ doublereal *df;
+ VALUE rblapack_duf;
+ doublereal *duf;
+ VALUE rblapack_du2;
+ doublereal *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *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.dgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTRFS( 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* DGTRFS 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by DGTTRF.\n*\n* DF (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGTTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dgtrfs( 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ 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_DFLOAT)
+ rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
+ df = NA_PTR_TYPE(rblapack_df, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ 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_DFLOAT)
+ rblapack_dlf = na_change_type(rblapack_dlf, NA_DFLOAT);
+ dlf = NA_PTR_TYPE(rblapack_dlf, doublereal*);
+ 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_DFLOAT)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
+ 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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_DFLOAT)
+ rblapack_duf = na_change_type(rblapack_duf, NA_DFLOAT);
+ duf = NA_PTR_TYPE(rblapack_duf, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgtrfs_(&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_dgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgtrfs", rblapack_dgtrfs, -1);
+}
diff --git a/ext/dgtsv.c b/ext/dgtsv.c
new file mode 100644
index 0000000..b7355d7
--- /dev/null
+++ b/ext/dgtsv.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern VOID dgtsv_(integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dgtsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ doublereal *dl_out__;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_du_out__;
+ doublereal *du_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, dl, d, du, b = NumRu::Lapack.dgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an n by n tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-2) elements of the\n* second super-diagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N by NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.dgtsv( dl, d, du, b, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublereal*);
+ MEMCPY(dl_out__, dl, doublereal, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_du_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublereal*);
+ MEMCPY(du_out__, du, doublereal, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
+}
+
+void
+init_lapack_dgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgtsv", rblapack_dgtsv, -1);
+}
diff --git a/ext/dgtsvx.c b/ext/dgtsvx.c
new file mode 100644
index 0000000..e041315
--- /dev/null
+++ b/ext/dgtsvx.c
@@ -0,0 +1,256 @@
+#include "rb_lapack.h"
+
+extern VOID dgtsvx_(char* fact, char* trans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* dlf, doublereal* df, doublereal* duf, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dgtsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_dlf;
+ doublereal *dlf;
+ VALUE rblapack_df;
+ doublereal *df;
+ VALUE rblapack_duf;
+ doublereal *duf;
+ VALUE rblapack_du2;
+ doublereal *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dlf_out__;
+ doublereal *dlf_out__;
+ VALUE rblapack_df_out__;
+ doublereal *df_out__;
+ VALUE rblapack_duf_out__;
+ doublereal *duf_out__;
+ VALUE rblapack_du2_out__;
+ doublereal *du2_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ doublereal *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 x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.dgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DGTSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B or A**T * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored\n* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n* will not be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of A.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input or output) DOUBLE PRECISION array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by DGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) DOUBLE PRECISION array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) DOUBLE PRECISION array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by DGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.dgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_dlf = argv[5];
+ rblapack_df = argv[6];
+ rblapack_duf = argv[7];
+ rblapack_du2 = argv[8];
+ rblapack_ipiv = argv[9];
+ rblapack_b = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (7th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (7th 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_DFLOAT)
+ rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
+ df = NA_PTR_TYPE(rblapack_df, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (10th 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*);
+ ldx = MAX(1,n);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ if (!NA_IsNArray(rblapack_duf))
+ rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
+ if (NA_RANK(rblapack_duf) != 1)
+ rb_raise(rb_eArgError, "rank of duf (8th 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_DFLOAT)
+ rblapack_duf = na_change_type(rblapack_duf, NA_DFLOAT);
+ duf = NA_PTR_TYPE(rblapack_duf, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ if (!NA_IsNArray(rblapack_du2))
+ rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_du2) != 1)
+ rb_raise(rb_eArgError, "rank of du2 (9th 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_DFLOAT)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
+ if (!NA_IsNArray(rblapack_dlf))
+ rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_dlf) != 1)
+ rb_raise(rb_eArgError, "rank of dlf (6th 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_DFLOAT)
+ rblapack_dlf = na_change_type(rblapack_dlf, NA_DFLOAT);
+ dlf = NA_PTR_TYPE(rblapack_dlf, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dlf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, doublereal*);
+ MEMCPY(dlf_out__, dlf, doublereal, NA_TOTAL(rblapack_dlf));
+ rblapack_dlf = rblapack_dlf_out__;
+ dlf = dlf_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublereal*);
+ MEMCPY(df_out__, df, doublereal, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_duf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, doublereal*);
+ MEMCPY(duf_out__, duf, doublereal, NA_TOTAL(rblapack_duf));
+ rblapack_duf = rblapack_duf_out__;
+ duf = duf_out__;
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, doublereal*);
+ MEMCPY(du2_out__, du2, doublereal, NA_TOTAL(rblapack_du2));
+ rblapack_du2 = rblapack_du2_out__;
+ du2 = du2_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
+}
+
+void
+init_lapack_dgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgtsvx", rblapack_dgtsvx, -1);
+}
diff --git a/ext/dgttrf.c b/ext/dgttrf.c
new file mode 100644
index 0000000..7a87af4
--- /dev/null
+++ b/ext/dgttrf.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID dgttrf_(integer* n, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_dgttrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_du2;
+ doublereal *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ doublereal *dl_out__;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_du_out__;
+ doublereal *du_out__;
+
+ 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 du2, ipiv, info, dl, d, du = NumRu::Lapack.dgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DGTTRF computes an LU factorization of a real tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) DOUBLE PRECISION array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.dgttrf( dl, d, du, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublereal*);
+ MEMCPY(dl_out__, dl, doublereal, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_du_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublereal*);
+ MEMCPY(du_out__, du, doublereal, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+
+ dgttrf_(&n, dl, d, du, du2, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
+}
+
+void
+init_lapack_dgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgttrf", rblapack_dgttrf, -1);
+}
diff --git a/ext/dgttrs.c b/ext/dgttrs.c
new file mode 100644
index 0000000..06f3a86
--- /dev/null
+++ b/ext/dgttrs.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID dgttrs_(char* trans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dgttrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_du2;
+ doublereal *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DGTTRS solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by DGTTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DGTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dgttrs( trans, dl, d, du, du2, ipiv, b, [: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_trans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ 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_DFLOAT)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
+ 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgttrs", rblapack_dgttrs, -1);
+}
diff --git a/ext/dgtts2.c b/ext/dgtts2.c
new file mode 100644
index 0000000..51a31ca
--- /dev/null
+++ b/ext/dgtts2.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID dgtts2_(integer* itrans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb);
+
+
+static VALUE
+rblapack_dgtts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itrans;
+ integer itrans;
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_du2;
+ doublereal *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.dgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* DGTTS2 solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by DGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A'* X = B (Transpose)\n* = 2: A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IP, J\n DOUBLE PRECISION TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.dgtts2( itrans, dl, d, du, du2, ipiv, b, [: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_itrans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itrans = NUM2INT(rblapack_itrans);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ 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_DFLOAT)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
+ 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_dgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dgtts2", rblapack_dgtts2, -1);
+}
diff --git a/ext/dhgeqz.c b/ext/dhgeqz.c
new file mode 100644
index 0000000..075ed16
--- /dev/null
+++ b/ext/dhgeqz.c
@@ -0,0 +1,213 @@
+#include "rb_lapack.h"
+
+extern VOID dhgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* t, integer* ldt, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* q, integer* ldq, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dhgeqz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_t_out__;
+ doublereal *t_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldt;
+ integer ldq;
+ integer ldz;
+
+ 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 alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.dhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the double-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a real matrix pair (A,B):\n*\n* A = Q1*H*Z1**T, B = Q1*T*Z1**T,\n*\n* as computed by DGGHRD.\n*\n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**T, T = Q*P*Z**T,\n* \n* where Q and Z are orthogonal matrices, P is an upper triangular\n* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n* diagonal blocks.\n*\n* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n* eigenvalues.\n*\n* Additionally, the 2-by-2 upper triangular diagonal blocks of P\n* corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n* P(j,j) > 0, and P(j+1,j+1) > 0.\n*\n* Optionally, the orthogonal matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced\n* the matrix pair (A,B) to generalized upper Hessenberg form, then the\n* output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n* generalized Schur factorization of (A,B):\n*\n* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n* complex and beta real.\n* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n* generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* Real eigenvalues can be read directly from the generalized Schur\n* form: \n* alpha = S(i,i), beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Compute eigenvalues and the Schur form. \n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper quasi-triangular\n* matrix S from the generalized Schur factorization;\n* 2-by-2 diagonal blocks (corresponding to complex conjugate\n* pairs of eigenvalues) are returned in standard form, with\n* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n* If JOB = 'E', the diagonal blocks of H match those of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization;\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n* are reduced to positive diagonal form, i.e., if H(j+1,j) is\n* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n* T(j+1,j+1) > 0.\n* If JOB = 'E', the diagonal blocks of T match those of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n* of left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of\n* right Schur vectors of (H,T), and if COMPZ = 'V', the\n* orthogonal matrix of right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* Iteration counters:\n*\n* JITER -- counts iterations.\n* IITER -- counts iterations run since ILAST was last\n* changed. This is therefore reset only when a 1-by-1 or\n* 2-by-2 block deflates off the bottom.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.dhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_compz = argv[2];
+ rblapack_ilo = argv[3];
+ rblapack_ihi = argv[4];
+ rblapack_h = argv[5];
+ rblapack_t = argv[6];
+ rblapack_q = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ compz = StringValueCStr(rblapack_compz)[0];
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ n = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (8th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
+ MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dhgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alphar, alphai, beta, q, &ldq, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_dhgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dhgeqz", rblapack_dhgeqz, -1);
+}
diff --git a/ext/dhsein.c b/ext/dhsein.c
new file mode 100644
index 0000000..ecb56bd
--- /dev/null
+++ b/ext/dhsein.c
@@ -0,0 +1,205 @@
+#include "rb_lapack.h"
+
+extern VOID dhsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* mm, integer* m, doublereal* work, integer* ifaill, integer* ifailr, integer* info);
+
+
+static VALUE
+rblapack_dhsein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_eigsrc;
+ char eigsrc;
+ VALUE rblapack_initv;
+ char initv;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_ifaill;
+ integer *ifaill;
+ VALUE rblapack_ifailr;
+ integer *ifailr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_select_out__;
+ logical *select_out__;
+ VALUE rblapack_wr_out__;
+ doublereal *wr_out__;
+ VALUE rblapack_vl_out__;
+ doublereal *vl_out__;
+ VALUE rblapack_vr_out__;
+ doublereal *vr_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldh;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.dhsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* DHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a real upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in (WR,WI):\n* = 'Q': the eigenvalues were found using DHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows DHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, DHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* real eigenvector corresponding to a real eigenvalue WR(j),\n* SELECT(j) must be set to .TRUE.. To select the complex\n* eigenvector corresponding to a complex eigenvalue\n* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n* .FALSE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) DOUBLE PRECISION array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input/output) DOUBLE PRECISION array, dimension (N)\n* WI (input) DOUBLE PRECISION array, dimension (N)\n* On entry, the real and imaginary parts of the eigenvalues of\n* H; a complex conjugate pair of eigenvalues must be stored in\n* consecutive elements of WR and WI.\n* On exit, WR may have been altered since close eigenvalues\n* are perturbed slightly in searching for independent\n* eigenvectors.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors; each selected real eigenvector\n* occupies one column and each selected complex eigenvector\n* occupies two columns.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VL hold a complex eigenvector, then IFAILL(i) and\n* IFAILL(i+1) are set to the same value.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VR hold a complex eigenvector, then IFAILR(i) and\n* IFAILR(i+1) are set to the same value.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.dhsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_side = argv[0];
+ rblapack_eigsrc = argv[1];
+ rblapack_initv = argv[2];
+ rblapack_select = argv[3];
+ rblapack_h = argv[4];
+ rblapack_wr = argv[5];
+ rblapack_wi = argv[6];
+ rblapack_vl = argv[7];
+ rblapack_vr = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ initv = StringValueCStr(rblapack_initv)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ if (!NA_IsNArray(rblapack_wi))
+ rb_raise(rb_eArgError, "wi (7th argument) must be NArray");
+ if (NA_RANK(rblapack_wi) != 1)
+ rb_raise(rb_eArgError, "rank of wi (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wi) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wi must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_wi) != NA_DFLOAT)
+ rblapack_wi = na_change_type(rblapack_wi, NA_DFLOAT);
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (9th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (9th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ mm = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ eigsrc = StringValueCStr(rblapack_eigsrc)[0];
+ if (!NA_IsNArray(rblapack_wr))
+ rb_raise(rb_eArgError, "wr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_wr) != 1)
+ rb_raise(rb_eArgError, "rank of wr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wr must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_wr) != NA_DFLOAT)
+ rblapack_wr = na_change_type(rblapack_wr, NA_DFLOAT);
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (8th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
+ MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
+ rblapack_select = rblapack_select_out__;
+ select = select_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr_out__ = NA_PTR_TYPE(rblapack_wr_out__, doublereal*);
+ MEMCPY(wr_out__, wr, doublereal, NA_TOTAL(rblapack_wr));
+ rblapack_wr = rblapack_wr_out__;
+ wr = wr_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
+ MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
+ MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(doublereal, ((n+2)*n));
+
+ dhsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, wr, wi, vl, &ldvl, vr, &ldvr, &mm, &m, work, ifaill, ifailr, &info);
+
+ free(work);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_select, rblapack_wr, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_dhsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dhsein", rblapack_dhsein, -1);
+}
diff --git a/ext/dhseqr.c b/ext/dhseqr.c
new file mode 100644
index 0000000..900ebb3
--- /dev/null
+++ b/ext/dhseqr.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID dhseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dhseqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer ldh;
+ 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 wr, wi, work, info, h, z = NumRu::Lapack.dhseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an orthogonal matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to DGEBAL, and then passed to DGEHRD\n* when the matrix output by DGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', then H contains the\n* upper quasi-triangular matrix T from the Schur decomposition\n* (the Schur form); 2-by-2 diagonal blocks (corresponding to\n* complex conjugate pairs of eigenvalues) are returned in\n* standard form, with H(i,i) = H(i+1,i+1) and\n* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n* contents of H are unspecified on exit. (The output value of\n* H when INFO.GT.0 is given under the description of INFO\n* below.)\n*\n* Unlike earlier versions of DHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues. If two eigenvalues are computed as a complex\n* conjugate pair, they are stored in consecutive elements of\n* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n* the same order as on the diagonal of the Schur form returned\n* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the orthogonal matrix generated by DORGHR\n* after the call to DGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then DHSEQR does a workspace query.\n* In this case, DHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, DHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The DLAHQR vs DLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* DLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.dhseqr( job, compz, ilo, ihi, h, z, ldz, [: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_job = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_z = argv[5];
+ rblapack_ldz = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ ldz = NUM2INT(rblapack_ldz);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
+ if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = lsame_(&compz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&compz,"N") ? 0 : n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dhseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_dhseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dhseqr", rblapack_dhseqr, -1);
+}
diff --git a/ext/disnan.c b/ext/disnan.c
new file mode 100644
index 0000000..bb1630a
--- /dev/null
+++ b/ext/disnan.c
@@ -0,0 +1,51 @@
+#include "rb_lapack.h"
+
+extern logical disnan_(doublereal* din);
+
+
+static VALUE
+rblapack_disnan(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_din;
+ doublereal din;
+ VALUE rblapack___out__;
+ logical __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 __out__ = NumRu::Lapack.disnan( din, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n LOGICAL FUNCTION DISNAN( DIN )\n\n* Purpose\n* =======\n*\n* DISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n* otherwise. To be replaced by the Fortran 2003 intrinsic in the\n* future.\n*\n\n* Arguments\n* =========\n*\n* DIN (input) DOUBLE PRECISION\n* Input to test for NaN.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL DLAISNAN\n EXTERNAL DLAISNAN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.disnan( din, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_din = argv[0];
+ if (argc == 1) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ din = NUM2DBL(rblapack_din);
+
+ __out__ = disnan_(&din);
+
+ rblapack___out__ = __out__ ? Qtrue : Qfalse;
+ return rblapack___out__;
+}
+
+void
+init_lapack_disnan(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "disnan", rblapack_disnan, -1);
+}
diff --git a/ext/dla_gbamv.c b/ext/dla_gbamv.c
new file mode 100644
index 0000000..4ca6148
--- /dev/null
+++ b/ext/dla_gbamv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID dla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, doublereal* alpha, doublereal* ab, integer* ldab, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);
+
+
+static VALUE
+rblapack_dla_gbamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+
+ integer ldab;
+ integer lda;
+
+ 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 y = NumRu::Lapack.dla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.dla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [: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_trans = argv[0];
+ rblapack_m = argv[1];
+ rblapack_n = argv[2];
+ rblapack_kl = argv[3];
+ rblapack_ku = argv[4];
+ rblapack_alpha = argv[5];
+ rblapack_ab = argv[6];
+ rblapack_x = argv[7];
+ rblapack_incx = argv[8];
+ rblapack_beta = argv[9];
+ rblapack_y = argv[10];
+ rblapack_incy = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+ n = NUM2INT(rblapack_n);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 1)
+ rb_raise(rb_eArgError, "rank of ab (7th argument) must be %d", 1);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ alpha = NUM2DBL(rblapack_alpha);
+ beta = NUM2DBL(rblapack_beta);
+ lda = MAX( 1, m );
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (11th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_dla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_gbamv", rblapack_dla_gbamv, -1);
+}
diff --git a/ext/dla_gbrcond.c b/ext/dla_gbrcond.c
new file mode 100644
index 0000000..b0d7646
--- /dev/null
+++ b/ext/dla_gbrcond.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_gbrcond_(char* trans, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);
+
+
+static VALUE
+rblapack_dla_gbrcond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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, __out__ = NumRu::Lapack.dla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (5*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J, KD, KE\n DOUBLE PRECISION AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_cmode = argv[6];
+ rblapack_c = argv[7];
+ rblapack_work = argv[8];
+ rblapack_iwork = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ cmode = NUM2INT(rblapack_cmode);
+ if (!NA_IsNArray(rblapack_iwork))
+ rb_raise(rb_eArgError, "iwork (10th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (9th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (5*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 5*n);
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+
+ __out__ = dla_gbrcond_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_dla_gbrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_gbrcond", rblapack_dla_gbrcond, -1);
+}
diff --git a/ext/dla_gbrfsx_extended.c b/ext/dla_gbrfsx_extended.c
new file mode 100644
index 0000000..9e886cf
--- /dev/null
+++ b/ext/dla_gbrfsx_extended.c
@@ -0,0 +1,293 @@
+#include "rb_lapack.h"
+
+extern VOID dla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_dla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_res;
+ doublereal *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublereal *dy;
+ VALUE rblapack_y_tail;
+ doublereal *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ doublereal *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ doublereal *err_bnds_comp_out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_norms;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* DLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGBTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension \n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 22 && argc != 22)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 22)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_colequ = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_y = argv[10];
+ rblapack_err_bnds_norm = argv[11];
+ rblapack_err_bnds_comp = argv[12];
+ rblapack_res = argv[13];
+ rblapack_ayb = argv[14];
+ rblapack_dy = argv[15];
+ rblapack_y_tail = argv[16];
+ rblapack_rcond = argv[17];
+ rblapack_ithresh = argv[18];
+ rblapack_rthresh = argv[19];
+ rblapack_dz_ub = argv[20];
+ rblapack_ignore_cwise = argv[21];
+ if (argc == 22) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ ldab = n;
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ colequ = (rblapack_colequ == Qtrue);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ rcond = NUM2DBL(rblapack_rcond);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ n_norms = 3;
+ trans_type = NUM2INT(rblapack_trans_type);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (11th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ if (NA_SHAPE1(rblapack_y) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (13th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be 3");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ n = ldab;
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be ldab");
+ 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_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_norm) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be 3");
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (15th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be ldab");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (17th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be ldab");
+ if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
+ ldafb = n;
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_afb) != ldafb)
+ rb_raise(rb_eRuntimeError, "shape 0 of afb must be n");
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be ldab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (14th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be ldab");
+ if (NA_TYPE(rblapack_res) != NA_DFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, doublereal*);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be ldab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (16th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be ldab");
+ if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ dla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_dla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_gbrfsx_extended", rblapack_dla_gbrfsx_extended, -1);
+}
diff --git a/ext/dla_gbrpvgrw.c b/ext/dla_gbrpvgrw.c
new file mode 100644
index 0000000..dfb03c8
--- /dev/null
+++ b/ext/dla_gbrpvgrw.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb);
+
+
+static VALUE
+rblapack_dla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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 __out__ = NumRu::Lapack.dla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* DLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_gbrpvgrw( kl, ku, ncols, ab, afb, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ncols = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+
+ __out__ = dla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_gbrpvgrw", rblapack_dla_gbrpvgrw, -1);
+}
diff --git a/ext/dla_geamv.c b/ext/dla_geamv.c
new file mode 100644
index 0000000..8d166ba
--- /dev/null
+++ b/ext/dla_geamv.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID dla_geamv_(integer* trans, integer* m, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);
+
+
+static VALUE
+rblapack_dla_geamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 y = NumRu::Lapack.dla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y - DOUBLE PRECISION\n* Array of DIMENSION at least\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.dla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_trans = argv[0];
+ rblapack_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_a = argv[3];
+ rblapack_x = argv[4];
+ rblapack_incx = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_y = argv[7];
+ rblapack_incy = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+ alpha = NUM2DBL(rblapack_alpha);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ beta = NUM2DBL(rblapack_beta);
+ lda = MAX(1, 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);
+ if (NA_SHAPE0(rblapack_a) != lda)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be MAX(1, m)");
+ 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*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy));
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy);
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_dla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_geamv", rblapack_dla_geamv, -1);
+}
diff --git a/ext/dla_gercond.c b/ext/dla_gercond.c
new file mode 100644
index 0000000..8ba3309
--- /dev/null
+++ b/ext/dla_gercond.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_gercond_(char* trans, integer* n, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);
+
+
+static VALUE
+rblapack_dla_gercond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.dla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_cmode = argv[4];
+ rblapack_c = argv[5];
+ rblapack_work = argv[6];
+ rblapack_iwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ cmode = NUM2INT(rblapack_cmode);
+ if (!NA_IsNArray(rblapack_iwork))
+ rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (3*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+
+ __out__ = dla_gercond_(&trans, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_dla_gercond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_gercond", rblapack_dla_gercond, -1);
+}
diff --git a/ext/dla_gerfsx_extended.c b/ext/dla_gerfsx_extended.c
new file mode 100644
index 0000000..f13d87d
--- /dev/null
+++ b/ext/dla_gerfsx_extended.c
@@ -0,0 +1,281 @@
+#include "rb_lapack.h"
+
+extern VOID dla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* errs_n, doublereal* errs_c, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_dla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_errs_n;
+ doublereal *errs_n;
+ VALUE rblapack_errs_c;
+ doublereal *errs_c;
+ VALUE rblapack_res;
+ doublereal *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublereal *dy;
+ VALUE rblapack_y_tail;
+ doublereal *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+ VALUE rblapack_errs_n_out__;
+ doublereal *errs_n_out__;
+ VALUE rblapack_errs_c_out__;
+ doublereal *errs_c_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_norms;
+
+ 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 berr_out, info, y, errs_n, errs_c = NumRu::Lapack.dla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* DLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, errs_n, errs_c = NumRu::Lapack.dla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 20 && argc != 20)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_errs_n = argv[9];
+ rblapack_errs_c = argv[10];
+ rblapack_res = argv[11];
+ rblapack_ayb = argv[12];
+ rblapack_dy = argv[13];
+ rblapack_y_tail = argv[14];
+ rblapack_rcond = argv[15];
+ rblapack_ithresh = argv[16];
+ rblapack_rthresh = argv[17];
+ rblapack_dz_ub = argv[18];
+ rblapack_ignore_cwise = argv[19];
+ if (argc == 20) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (12th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_DFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, doublereal*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
+ rcond = NUM2DBL(rblapack_rcond);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ trans_type = NUM2INT(rblapack_trans_type);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ n_norms = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_errs_n))
+ rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
+ if (NA_RANK(rblapack_errs_n) != 2)
+ rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_errs_n) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_errs_n) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be 3");
+ if (NA_TYPE(rblapack_errs_n) != NA_DFLOAT)
+ rblapack_errs_n = na_change_type(rblapack_errs_n, NA_DFLOAT);
+ errs_n = NA_PTR_TYPE(rblapack_errs_n, doublereal*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_errs_c))
+ rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
+ if (NA_RANK(rblapack_errs_c) != 2)
+ rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_errs_c) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of errs_c must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_errs_c) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of errs_c must be 3");
+ if (NA_TYPE(rblapack_errs_c) != NA_DFLOAT)
+ rblapack_errs_c = na_change_type(rblapack_errs_c, NA_DFLOAT);
+ errs_c = NA_PTR_TYPE(rblapack_errs_c, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_errs_n_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ errs_n_out__ = NA_PTR_TYPE(rblapack_errs_n_out__, doublereal*);
+ MEMCPY(errs_n_out__, errs_n, doublereal, NA_TOTAL(rblapack_errs_n));
+ rblapack_errs_n = rblapack_errs_n_out__;
+ errs_n = errs_n_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_errs_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ errs_c_out__ = NA_PTR_TYPE(rblapack_errs_c_out__, doublereal*);
+ MEMCPY(errs_c_out__, errs_c, doublereal, NA_TOTAL(rblapack_errs_c));
+ rblapack_errs_c = rblapack_errs_c_out__;
+ errs_c = errs_c_out__;
+
+ dla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_errs_n, rblapack_errs_c);
+}
+
+void
+init_lapack_dla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_gerfsx_extended", rblapack_dla_gerfsx_extended, -1);
+}
diff --git a/ext/dla_lin_berr.c b/ext/dla_lin_berr.c
new file mode 100644
index 0000000..017dae7
--- /dev/null
+++ b/ext/dla_lin_berr.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID dla_lin_berr_(integer* n, integer* nz, integer* nrhs, doublereal* res, doublereal* ayb, doublereal* berr);
+
+
+static VALUE
+rblapack_dla_lin_berr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nz;
+ integer nz;
+ VALUE rblapack_res;
+ doublereal *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_berr;
+ doublereal *berr;
+
+ integer n;
+ integer nrhs;
+
+ 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 berr = NumRu::Lapack.dla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* DLA_LIN_BERR computes component-wise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the component-wise absolute value of the matrix\n* or vector Z.\n*\n\n* Arguments\n* ==========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see dla_gerfsx_extended.f).\n* \n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The component-wise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION TMP\n INTEGER I, J\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. External Functions ..\n EXTERNAL DLAMCH\n DOUBLE PRECISION DLAMCH\n DOUBLE PRECISION SAFE1\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr = NumRu::Lapack.dla_lin_berr( nz, res, ayb, [: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_nz = argv[0];
+ rblapack_res = argv[1];
+ rblapack_ayb = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nz = NUM2INT(rblapack_nz);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 2)
+ rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
+ n = NA_SHAPE0(rblapack_ayb);
+ nrhs = NA_SHAPE1(rblapack_ayb);
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (2th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 2)
+ rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
+ if (NA_SHAPE1(rblapack_res) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
+ if (NA_TYPE(rblapack_res) != NA_DFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+
+ dla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
+
+ return rblapack_berr;
+}
+
+void
+init_lapack_dla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_lin_berr", rblapack_dla_lin_berr, -1);
+}
diff --git a/ext/dla_porcond.c b/ext/dla_porcond.c
new file mode 100644
index 0000000..8735720
--- /dev/null
+++ b/ext/dla_porcond.c
@@ -0,0 +1,122 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_porcond_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);
+
+
+static VALUE
+rblapack_dla_porcond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.dla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, TMP\n LOGICAL UP\n* ..\n* .. Array Arguments ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER IDAMAX\n EXTERNAL LSAME, IDAMAX\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_cmode = argv[3];
+ rblapack_c = argv[4];
+ rblapack_work = argv[5];
+ rblapack_iwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_iwork))
+ rb_raise(rb_eArgError, "iwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (3*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ cmode = NUM2INT(rblapack_cmode);
+
+ __out__ = dla_porcond_(&uplo, &n, a, &lda, af, &ldaf, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_dla_porcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_porcond", rblapack_dla_porcond, -1);
+}
diff --git a/ext/dla_porfsx_extended.c b/ext/dla_porfsx_extended.c
new file mode 100644
index 0000000..2578075
--- /dev/null
+++ b/ext/dla_porfsx_extended.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID dla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_dla_porfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_res;
+ doublereal *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublereal *dy;
+ VALUE rblapack_y_tail;
+ doublereal *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ doublereal *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ doublereal *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* DLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 20 && argc != 20)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_colequ = argv[4];
+ rblapack_c = argv[5];
+ rblapack_b = argv[6];
+ rblapack_y = argv[7];
+ rblapack_n_norms = argv[8];
+ rblapack_err_bnds_norm = argv[9];
+ rblapack_err_bnds_comp = argv[10];
+ rblapack_res = argv[11];
+ rblapack_ayb = argv[12];
+ rblapack_dy = argv[13];
+ rblapack_y_tail = argv[14];
+ rblapack_rcond = argv[15];
+ rblapack_ithresh = argv[16];
+ rblapack_rthresh = argv[17];
+ rblapack_dz_ub = argv[18];
+ rblapack_ignore_cwise = argv[19];
+ if (argc == 20) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ 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*);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (12th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_DFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, doublereal*);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ if (NA_SHAPE1(rblapack_y) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ rcond = NUM2DBL(rblapack_rcond);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ dla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_dla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_porfsx_extended", rblapack_dla_porfsx_extended, -1);
+}
diff --git a/ext/dla_porpvgrw.c b/ext/dla_porpvgrw.c
new file mode 100644
index 0000000..3e3fff1
--- /dev/null
+++ b/ext/dla_porpvgrw.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_porpvgrw_(char* uplo, integer* ncols, doublereal* a, integer* lda, doublereal* af, integer* ldaf, doublereal* work);
+
+
+static VALUE
+rblapack_dla_porpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.dla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* DLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) DOUBLE PRECISION array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, DLASET\n LOGICAL LSAME\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_porpvgrw( uplo, ncols, a, af, work, [: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_ncols = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_work = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (5th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+
+ __out__ = dla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_porpvgrw", rblapack_dla_porpvgrw, -1);
+}
diff --git a/ext/dla_rpvgrw.c b/ext/dla_rpvgrw.c
new file mode 100644
index 0000000..f0f6b41
--- /dev/null
+++ b/ext/dla_rpvgrw.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_rpvgrw_(integer* n, integer* ncols, doublereal* a, integer* lda, doublereal* af, integer* ldaf);
+
+
+static VALUE
+rblapack_dla_rpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.dla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n* \n* DLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by DGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_rpvgrw( ncols, a, af, [: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_ncols = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+
+ __out__ = dla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_rpvgrw", rblapack_dla_rpvgrw, -1);
+}
diff --git a/ext/dla_syamv.c b/ext/dla_syamv.c
new file mode 100644
index 0000000..2b9ddc8
--- /dev/null
+++ b/ext/dla_syamv.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID dla_syamv_(integer* uplo, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);
+
+
+static VALUE
+rblapack_dla_syamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ integer uplo;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 y = NumRu::Lapack.dla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.dla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = NUM2INT(rblapack_uplo);
+ 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);
+ 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*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha = NUM2DBL(rblapack_alpha);
+ beta = NUM2DBL(rblapack_beta);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_dla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_syamv", rblapack_dla_syamv, -1);
+}
diff --git a/ext/dla_syrcond.c b/ext/dla_syrcond.c
new file mode 100644
index 0000000..5774b9d
--- /dev/null
+++ b/ext/dla_syrcond.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_syrcond_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);
+
+
+static VALUE
+rblapack_dla_syrcond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.dla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER NORMIN\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, SMLNUM, TMP\n LOGICAL UP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER IDAMAX\n DOUBLE PRECISION DLAMCH\n EXTERNAL LSAME, IDAMAX, DLAMCH\n* ..\n* .. External Subroutines ..\n EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA, DSYTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.dla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [: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_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_cmode = argv[4];
+ rblapack_c = argv[5];
+ rblapack_work = argv[6];
+ rblapack_iwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ cmode = NUM2INT(rblapack_cmode);
+ if (!NA_IsNArray(rblapack_iwork))
+ rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (3*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+
+ __out__ = dla_syrcond_(&uplo, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_dla_syrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_syrcond", rblapack_dla_syrcond, -1);
+}
diff --git a/ext/dla_syrfsx_extended.c b/ext/dla_syrfsx_extended.c
new file mode 100644
index 0000000..cd9e94b
--- /dev/null
+++ b/ext/dla_syrfsx_extended.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID dla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_dla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_res;
+ doublereal *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublereal *dy;
+ VALUE rblapack_y_tail;
+ doublereal *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ doublereal *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ doublereal *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* DLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by DSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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* Y (input/output) DOUBLE PRECISION array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by DSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by DLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to DSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 21 && argc != 21)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_n_norms = argv[9];
+ rblapack_err_bnds_norm = argv[10];
+ rblapack_err_bnds_comp = argv[11];
+ rblapack_res = argv[12];
+ rblapack_ayb = argv[13];
+ rblapack_dy = argv[14];
+ rblapack_y_tail = argv[15];
+ rblapack_rcond = argv[16];
+ rblapack_ithresh = argv[17];
+ rblapack_rthresh = argv[18];
+ rblapack_dz_ub = argv[19];
+ rblapack_ignore_cwise = argv[20];
+ if (argc == 21) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (13th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_DFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, doublereal*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
+ rcond = NUM2DBL(rblapack_rcond);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ colequ = (rblapack_colequ == Qtrue);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ dla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_dla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_syrfsx_extended", rblapack_dla_syrfsx_extended, -1);
+}
diff --git a/ext/dla_syrpvgrw.c b/ext/dla_syrpvgrw.c
new file mode 100644
index 0000000..ec4ec7b
--- /dev/null
+++ b/ext/dla_syrpvgrw.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern doublereal dla_syrpvgrw_(char* uplo, integer* n, integer* info, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* work);
+
+
+static VALUE
+rblapack_dla_syrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.dla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* DLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from DSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* WORK (input) DOUBLE PRECISION array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, DLASET\n LOGICAL LSAME\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dla_syrpvgrw( uplo, info, a, af, ipiv, work, [: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_info = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_work = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ info = NUM2INT(rblapack_info);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+
+ __out__ = dla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_syrpvgrw", rblapack_dla_syrpvgrw, -1);
+}
diff --git a/ext/dla_wwaddw.c b/ext/dla_wwaddw.c
new file mode 100644
index 0000000..b48e64a
--- /dev/null
+++ b/ext/dla_wwaddw.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID dla_wwaddw_(integer* n, doublereal* x, doublereal* y, doublereal* w);
+
+
+static VALUE
+rblapack_dla_wwaddw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+
+ 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 x, y = NumRu::Lapack.dla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* DLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) DOUBLE PRECISION array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION S\n INTEGER I\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.dla_wwaddw( x, y, w, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_w = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (2th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dla_wwaddw_(&n, x, y, w);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_dla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dla_wwaddw", rblapack_dla_wwaddw, -1);
+}
diff --git a/ext/dlabad.c b/ext/dlabad.c
new file mode 100644
index 0000000..5febd6c
--- /dev/null
+++ b/ext/dlabad.c
@@ -0,0 +1,54 @@
+#include "rb_lapack.h"
+
+extern VOID dlabad_(doublereal* small, doublereal* large);
+
+
+static VALUE
+rblapack_dlabad(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_small;
+ doublereal small;
+ VALUE rblapack_large;
+ doublereal large;
+
+
+ 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 small, large = NumRu::Lapack.dlabad( small, large, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLABAD( SMALL, LARGE )\n\n* Purpose\n* =======\n*\n* DLABAD takes as input the values computed by DLAMCH for underflow and\n* overflow, and returns the square root of each of these values if the\n* log of LARGE is sufficiently large. This subroutine is intended to\n* identify machines with a large exponent range, such as the Crays, and\n* redefine the underflow and overflow limits to be the square roots of\n* the values computed by DLAMCH. This subroutine is needed because\n* DLAMCH does not compensate for poor arithmetic in the upper half of\n* the exponent range, as is found on a Cray.\n*\n\n* Arguments\n* =========\n*\n* SMALL (input/output) DOUBLE PRECISION\n* On entry, the underflow threshold as computed by DLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of SMALL, otherwise unchanged.\n*\n* LARGE (input/output) DOUBLE PRECISION\n* On entry, the overflow threshold as computed by DLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of LARGE, otherwise unchanged.\n*\n\n* =====================================================================\n*\n* .. Intrinsic Functions ..\n INTRINSIC LOG10, SQRT\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n small, large = NumRu::Lapack.dlabad( small, large, [: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_small = argv[0];
+ rblapack_large = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ small = NUM2DBL(rblapack_small);
+ large = NUM2DBL(rblapack_large);
+
+ dlabad_(&small, &large);
+
+ rblapack_small = rb_float_new((double)small);
+ rblapack_large = rb_float_new((double)large);
+ return rb_ary_new3(2, rblapack_small, rblapack_large);
+}
+
+void
+init_lapack_dlabad(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlabad", rblapack_dlabad, -1);
+}
diff --git a/ext/dlabrd.c b/ext/dlabrd.c
new file mode 100644
index 0000000..fc4509c
--- /dev/null
+++ b/ext/dlabrd.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID dlabrd_(integer* m, integer* n, integer* nb, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tauq, doublereal* taup, doublereal* x, integer* ldx, doublereal* y, integer* ldy);
+
+
+static VALUE
+rblapack_dlabrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tauq;
+ doublereal *tauq;
+ VALUE rblapack_taup;
+ doublereal *taup;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldx;
+ integer ldy;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.dlabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* DLABRD reduces the first NB rows and columns of a real general\n* m by n matrix A to upper or lower bidiagonal form by an orthogonal\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by DGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the orthogonal matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) DOUBLE PRECISION array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) DOUBLE PRECISION array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= M.\n*\n* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.dlabrd( m, nb, a, [: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_m = argv[0];
+ rblapack_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ 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*);
+ ldy = n;
+ nb = NUM2INT(rblapack_nb);
+ ldx = m;
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = MAX(1,nb);
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int 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__;
+
+ dlabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
+
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_dlabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlabrd", rblapack_dlabrd, -1);
+}
diff --git a/ext/dlacn2.c b/ext/dlacn2.c
new file mode 100644
index 0000000..43d9ab4
--- /dev/null
+++ b/ext/dlacn2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID dlacn2_(integer* n, doublereal* v, doublereal* x, integer* isgn, doublereal* est, integer* kase, integer* isave);
+
+
+static VALUE
+rblapack_dlacn2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_est;
+ doublereal est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_isave;
+ integer *isave;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_isave_out__;
+ integer *isave_out__;
+ doublereal *v;
+ integer *isgn;
+
+ 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 x, est, kase, isave = NumRu::Lapack.dlacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* DLACN2 estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and DLACN2 must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to DLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to DLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from DLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to DLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* This is a thread safe version of DLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* DLACON DLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.dlacn2( x, est, kase, isave, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ rblapack_isave = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ kase = NUM2INT(rblapack_kase);
+ est = NUM2DBL(rblapack_est);
+ if (!NA_IsNArray(rblapack_isave))
+ rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
+ if (NA_RANK(rblapack_isave) != 1)
+ rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isave) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
+ if (NA_TYPE(rblapack_isave) != NA_LINT)
+ rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
+ isave = NA_PTR_TYPE(rblapack_isave, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 3;
+ rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
+ MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
+ rblapack_isave = rblapack_isave_out__;
+ isave = isave_out__;
+ v = ALLOC_N(doublereal, (n));
+ isgn = ALLOC_N(integer, (n));
+
+ dlacn2_(&n, v, x, isgn, &est, &kase, isave);
+
+ free(v);
+ free(isgn);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
+}
+
+void
+init_lapack_dlacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlacn2", rblapack_dlacn2, -1);
+}
diff --git a/ext/dlacon.c b/ext/dlacon.c
new file mode 100644
index 0000000..0bae17c
--- /dev/null
+++ b/ext/dlacon.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID dlacon_(integer* n, doublereal* v, doublereal* x, integer* isgn, doublereal* est, integer* kase);
+
+
+static VALUE
+rblapack_dlacon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_est;
+ doublereal est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *v;
+ integer *isgn;
+
+ 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 x, est, kase = NumRu::Lapack.dlacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )\n\n* Purpose\n* =======\n*\n* DLACON estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and DLACON must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to DLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to DLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from DLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.dlacon( x, est, kase, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ kase = NUM2INT(rblapack_kase);
+ est = NUM2DBL(rblapack_est);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ v = ALLOC_N(doublereal, (n));
+ isgn = ALLOC_N(integer, (n));
+
+ dlacon_(&n, v, x, isgn, &est, &kase);
+
+ free(v);
+ free(isgn);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
+}
+
+void
+init_lapack_dlacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlacon", rblapack_dlacon, -1);
+}
diff --git a/ext/dlacpy.c b/ext/dlacpy.c
new file mode 100644
index 0000000..a86f909
--- /dev/null
+++ b/ext/dlacpy.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID dlacpy_(char* uplo, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb);
+
+
+static VALUE
+rblapack_dlacpy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.dlacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* DLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper triangle\n* or trapezoid is accessed; if UPLO = 'L', only the lower\n* triangle or trapezoid is accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) DOUBLE PRECISION array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.dlacpy( uplo, m, a, [: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_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ m = NUM2INT(rblapack_m);
+ ldb = MAX(1,m);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+
+ dlacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_dlacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlacpy", rblapack_dlacpy, -1);
+}
diff --git a/ext/dladiv.c b/ext/dladiv.c
new file mode 100644
index 0000000..32e450f
--- /dev/null
+++ b/ext/dladiv.c
@@ -0,0 +1,66 @@
+#include "rb_lapack.h"
+
+extern VOID dladiv_(doublereal* a, doublereal* b, doublereal* c, doublereal* d, doublereal* p, doublereal* q);
+
+
+static VALUE
+rblapack_dladiv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal a;
+ VALUE rblapack_b;
+ doublereal b;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_d;
+ doublereal d;
+ VALUE rblapack_p;
+ doublereal p;
+ VALUE rblapack_q;
+ doublereal q;
+
+
+ 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 p, q = NumRu::Lapack.dladiv( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLADIV( A, B, C, D, P, Q )\n\n* Purpose\n* =======\n*\n* DLADIV performs complex division in real arithmetic\n*\n* a + i*b\n* p + i*q = ---------\n* c + i*d\n*\n* The algorithm is due to Robert L. Smith and can be found\n* in D. Knuth, The art of Computer Programming, Vol.2, p.195\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION\n* B (input) DOUBLE PRECISION\n* C (input) DOUBLE PRECISION\n* D (input) DOUBLE PRECISION\n* The scalars a, b, c, and d in the above expression.\n*\n* P (output) DOUBLE PRECISION\n* Q (output) DOUBLE PRECISION\n* The scalars p and q in the above expression.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION E, F\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n p, q = NumRu::Lapack.dladiv( a, b, c, d, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = NUM2DBL(rblapack_a);
+ c = NUM2DBL(rblapack_c);
+ b = NUM2DBL(rblapack_b);
+ d = NUM2DBL(rblapack_d);
+
+ dladiv_(&a, &b, &c, &d, &p, &q);
+
+ rblapack_p = rb_float_new((double)p);
+ rblapack_q = rb_float_new((double)q);
+ return rb_ary_new3(2, rblapack_p, rblapack_q);
+}
+
+void
+init_lapack_dladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dladiv", rblapack_dladiv, -1);
+}
diff --git a/ext/dlae2.c b/ext/dlae2.c
new file mode 100644
index 0000000..60f2681
--- /dev/null
+++ b/ext/dlae2.c
@@ -0,0 +1,62 @@
+#include "rb_lapack.h"
+
+extern VOID dlae2_(doublereal* a, doublereal* b, doublereal* c, doublereal* rt1, doublereal* rt2);
+
+
+static VALUE
+rblapack_dlae2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal a;
+ VALUE rblapack_b;
+ doublereal b;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_rt1;
+ doublereal rt1;
+ VALUE rblapack_rt2;
+ doublereal rt2;
+
+
+ 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 rt1, rt2 = NumRu::Lapack.dlae2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAE2( A, B, C, RT1, RT2 )\n\n* Purpose\n* =======\n*\n* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, and RT2\n* is the eigenvalue of smaller absolute value.\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) DOUBLE PRECISION\n* The (1,2) and (2,1) elements of the 2-by-2 matrix.\n*\n* C (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) DOUBLE PRECISION\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) DOUBLE PRECISION\n* The eigenvalue of smaller absolute value.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2 = NumRu::Lapack.dlae2( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = NUM2DBL(rblapack_a);
+ c = NUM2DBL(rblapack_c);
+ b = NUM2DBL(rblapack_b);
+
+ dlae2_(&a, &b, &c, &rt1, &rt2);
+
+ rblapack_rt1 = rb_float_new((double)rt1);
+ rblapack_rt2 = rb_float_new((double)rt2);
+ return rb_ary_new3(2, rblapack_rt1, rblapack_rt2);
+}
+
+void
+init_lapack_dlae2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlae2", rblapack_dlae2, -1);
+}
diff --git a/ext/dlaebz.c b/ext/dlaebz.c
new file mode 100644
index 0000000..e192c25
--- /dev/null
+++ b/ext/dlaebz.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID dlaebz_(integer* ijob, integer* nitmax, integer* n, integer* mmax, integer* minp, integer* nbmin, doublereal* abstol, doublereal* reltol, doublereal* pivmin, doublereal* d, doublereal* e, doublereal* e2, integer* nval, doublereal* ab, doublereal* c, integer* mout, integer* nab, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlaebz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_nitmax;
+ integer nitmax;
+ VALUE rblapack_minp;
+ integer minp;
+ VALUE rblapack_nbmin;
+ integer nbmin;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_reltol;
+ doublereal reltol;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_e2;
+ doublereal *e2;
+ VALUE rblapack_nval;
+ integer *nval;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_nab;
+ integer *nab;
+ VALUE rblapack_mout;
+ integer mout;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_nval_out__;
+ integer *nval_out__;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_nab_out__;
+ integer *nab_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer mmax;
+
+ 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 mout, info, nval, ab, c, nab = NumRu::Lapack.dlaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAEBZ contains the iteration loops which compute and use the\n* function N(w), which is the count of eigenvalues of a symmetric\n* tridiagonal matrix T less than or equal to its argument w. It\n* performs a choice of two types of loops:\n*\n* IJOB=1, followed by\n* IJOB=2: It takes as input a list of intervals and returns a list of\n* sufficiently small intervals whose union contains the same\n* eigenvalues as the union of the original intervals.\n* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n* The output interval (AB(j,1),AB(j,2)] will contain\n* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n*\n* IJOB=3: It performs a binary search in each input interval\n* (AB(j,1),AB(j,2)] for a point w(j) such that\n* N(w(j))=NVAL(j), and uses C(j) as the starting point of\n* the search. If such a w(j) is found, then on output\n* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output\n* (AB(j,1),AB(j,2)] will be a small interval containing the\n* point where N(w) jumps through NVAL(j), unless that point\n* lies outside the initial interval.\n*\n* Note that the intervals are in all cases half-open intervals,\n* i.e., of the form (a,b] , which includes b but not a .\n*\n* To avoid underflow, the matrix should be scaled so that its largest\n* element is no greater than overflow**(1/2) * underflow**(1/4)\n* in absolute value. To assure the most accurate computation\n* of small eigenvalues, the matrix should be scaled to be\n* not much smaller than that, either.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966\n*\n* Note: the arguments are, in general, *not* checked for unreasonable\n* values.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies what is to be done:\n* = 1: Compute NAB for the initial intervals.\n* = 2: Perform bisection iteration to find eigenvalues of T.\n* = 3: Perform bisection iteration to invert N(w), i.e.,\n* to find a point which has a specified number of\n* eigenvalues of T to its left.\n* Other values will cause DLAEBZ to return with INFO=-1.\n*\n* NITMAX (input) INTEGER\n* The maximum number of \"levels\" of bisection to be\n* performed, i.e., an interval of width W will not be made\n* smaller than 2^(-NITMAX) * W. If not all intervals\n* have converged after NITMAX iterations, then INFO is set\n* to the number of non-converged intervals.\n*\n* N (input) INTEGER\n* The dimension n of the tridiagonal matrix T. It must be at\n* least 1.\n*\n* MMAX (input) INTEGER\n* The maximum number of intervals. If more than MMAX intervals\n* are generated, then DLAEBZ will quit with INFO=MMAX+1.\n*\n* MINP (input) INTEGER\n* The initial number of intervals. It may not be greater than\n* MMAX.\n*\n* NBMIN (input) INTEGER\n* The smallest number of intervals that should be processed\n* using a vector loop. If zero, then only the scalar loop\n* will be used.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The minimum (absolute) width of an interval. When an\n* interval is narrower than ABSTOL, or than RELTOL times the\n* larger (in magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. This must be at least\n* zero.\n*\n* RELTOL (input) DOUBLE PRECISION\n* The minimum relative width of an interval. When an interval\n* is narrower than ABSTOL, or than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum absolute value of a \"pivot\" in the Sturm\n* sequence loop. This *must* be at least max |e(j)**2| *\n* safe_min and at least safe_min, where safe_min is at least\n* the smallest number that can divide one without overflow.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N)\n* The offdiagonal elements of the tridiagonal matrix T in\n* positions 1 through N-1. E(N) is arbitrary.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N)\n* The squares of the offdiagonal elements of the tridiagonal\n* matrix T. E2(N) is ignored.\n*\n* NVAL (input/output) INTEGER array, dimension (MINP)\n* If IJOB=1 or 2, not referenced.\n* If IJOB=3, the desired values of N(w). The elements of NVAL\n* will be reordered to correspond with the intervals in AB.\n* Thus, NVAL(j) on output will not, in general be the same as\n* NVAL(j) on input, but it will correspond with the interval\n* (AB(j,1),AB(j,2)] on output.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2)\n* The endpoints of the intervals. AB(j,1) is a(j), the left\n* endpoint of the j-th interval, and AB(j,2) is b(j), the\n* right endpoint of the j-th interval. The input intervals\n* will, in general, be modified, split, and reordered by the\n* calculation.\n*\n* C (input/output) DOUBLE PRECISION array, dimension (MMAX)\n* If IJOB=1, ignored.\n* If IJOB=2, workspace.\n* If IJOB=3, then on input C(j) should be initialized to the\n* first search point in the binary search.\n*\n* MOUT (output) INTEGER\n* If IJOB=1, the number of eigenvalues in the intervals.\n* If IJOB=2 or 3, the number of intervals output.\n* If IJOB=3, MOUT will equal MINP.\n*\n* NAB (input/output) INTEGER array, dimension (MMAX,2)\n* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n* If IJOB=2, then on input, NAB(i,j) should be set. It must\n* satisfy the condition:\n* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n* which means that in interval i only eigenvalues\n* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,\n* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with\n* IJOB=1.\n* On output, NAB(i,j) will contain\n* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n* the input interval that the output interval\n* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n* the input values of NAB(k,1) and NAB(k,2).\n* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n* unless N(w) > NVAL(i) for all search points w , in which\n* case NAB(i,1) will not be modified, i.e., the output\n* value will be the same as the input value (modulo\n* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n* for all search points w , in which case NAB(i,2) will\n* not be modified. Normally, NAB should be set to some\n* distinctive value(s) before DLAEBZ is called.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (MMAX)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: All intervals converged.\n* = 1--MMAX: The last INFO intervals did not converge.\n* = MMAX+1: More than MMAX intervals were generated.\n*\n\n* Further Details\n* ===============\n*\n* This routine is intended to be called only by other LAPACK\n* routines, thus the interface is less user-friendly. It is intended\n* for two purposes:\n*\n* (a) finding eigenvalues. In this case, DLAEBZ should have one or\n* more initial intervals set up in AB, and DLAEBZ should be called\n* with IJOB=1. This sets up NAB, and also counts the eigenvalues.\n* Intervals with no eigenvalues would usually be thrown out at\n* this point. Also, if not all the eigenvalues in an interval i\n* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX\n* no smaller than the value of MOUT returned by the call with\n* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n* tolerance specified by ABSTOL and RELTOL.\n*\n* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n* In this case, start with a Gershgorin interval (a,b). Set up\n* AB to contain 2 search intervals, both initially (a,b). One\n* NVAL element should contain f-1 and the other should contain l\n* , while C should contain a and b, resp. NAB(i,1) should be -1\n* and NAB(i,2) should be N+1, to flag an error if the desired\n* interval does not lie in (a,b). DLAEBZ is then called with\n* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --\n* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and\n* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and\n* w(l-r)=...=w(l+k) are handled similarly.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n mout, info, nval, ab, c, nab = NumRu::Lapack.dlaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 14 && argc != 14)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
+ rblapack_ijob = argv[0];
+ rblapack_nitmax = argv[1];
+ rblapack_minp = argv[2];
+ rblapack_nbmin = argv[3];
+ rblapack_abstol = argv[4];
+ rblapack_reltol = argv[5];
+ rblapack_pivmin = argv[6];
+ rblapack_d = argv[7];
+ rblapack_e = argv[8];
+ rblapack_e2 = argv[9];
+ rblapack_nval = argv[10];
+ rblapack_ab = argv[11];
+ rblapack_c = argv[12];
+ rblapack_nab = argv[13];
+ if (argc == 14) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ minp = NUM2INT(rblapack_minp);
+ abstol = NUM2DBL(rblapack_abstol);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (9th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_e);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (!NA_IsNArray(rblapack_nval))
+ rb_raise(rb_eArgError, "nval (11th argument) must be NArray");
+ if (NA_RANK(rblapack_nval) != 1)
+ rb_raise(rb_eArgError, "rank of nval (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_nval) != ((ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of nval must be %d", (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0);
+ if (NA_TYPE(rblapack_nval) != NA_LINT)
+ rblapack_nval = na_change_type(rblapack_nval, NA_LINT);
+ nval = NA_PTR_TYPE(rblapack_nval, integer*);
+ if (!NA_IsNArray(rblapack_nab))
+ rb_raise(rb_eArgError, "nab (14th argument) must be NArray");
+ if (NA_RANK(rblapack_nab) != 2)
+ rb_raise(rb_eArgError, "rank of nab (14th argument) must be %d", 2);
+ mmax = NA_SHAPE0(rblapack_nab);
+ if (NA_SHAPE1(rblapack_nab) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of nab must be %d", 2);
+ if (NA_TYPE(rblapack_nab) != NA_LINT)
+ rblapack_nab = na_change_type(rblapack_nab, NA_LINT);
+ nab = NA_PTR_TYPE(rblapack_nab, integer*);
+ nitmax = NUM2INT(rblapack_nitmax);
+ reltol = NUM2DBL(rblapack_reltol);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
+ if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
+ nbmin = NUM2INT(rblapack_nbmin);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (12th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_ab) != mmax)
+ rb_raise(rb_eRuntimeError, "shape 0 of ab must be the same as shape 0 of nab");
+ if (NA_SHAPE1(rblapack_ab) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be %d", 2);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (8th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (8th 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 e");
+ 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_c))
+ rb_raise(rb_eArgError, "c (13th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int shape[1];
+ shape[0] = (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0;
+ rblapack_nval_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ nval_out__ = NA_PTR_TYPE(rblapack_nval_out__, integer*);
+ MEMCPY(nval_out__, nval, integer, NA_TOTAL(rblapack_nval));
+ rblapack_nval = rblapack_nval_out__;
+ nval = nval_out__;
+ {
+ int shape[2];
+ shape[0] = mmax;
+ shape[1] = 2;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[1];
+ shape[0] = ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = mmax;
+ shape[1] = 2;
+ rblapack_nab_out__ = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ nab_out__ = NA_PTR_TYPE(rblapack_nab_out__, integer*);
+ MEMCPY(nab_out__, nab, integer, NA_TOTAL(rblapack_nab));
+ rblapack_nab = rblapack_nab_out__;
+ nab = nab_out__;
+ work = ALLOC_N(doublereal, (mmax));
+ iwork = ALLOC_N(integer, (mmax));
+
+ dlaebz_(&ijob, &nitmax, &n, &mmax, &minp, &nbmin, &abstol, &reltol, &pivmin, d, e, e2, nval, ab, c, &mout, nab, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_mout = INT2NUM(mout);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_mout, rblapack_info, rblapack_nval, rblapack_ab, rblapack_c, rblapack_nab);
+}
+
+void
+init_lapack_dlaebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaebz", rblapack_dlaebz, -1);
+}
diff --git a/ext/dlaed0.c b/ext/dlaed0.c
new file mode 100644
index 0000000..64d99f8
--- /dev/null
+++ b/ext/dlaed0.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed0_(integer* icompq, integer* qsiz, integer* n, doublereal* d, doublereal* e, doublereal* q, integer* ldq, doublereal* qstore, integer* ldqs, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlaed0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ doublereal *qstore;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+ integer ldqs;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q = NumRu::Lapack.dlaed0( icompq, qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAED0 computes all eigenvalues and corresponding eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n* = 2: Compute eigenvalues and eigenvectors of tridiagonal\n* matrix.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the main diagonal of the tridiagonal matrix.\n* On exit, its eigenvalues.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, Q must contain an N-by-N orthogonal matrix.\n* If ICOMPQ = 0 Q is not referenced.\n* If ICOMPQ = 1 On entry, Q is a subset of the columns of the\n* orthogonal matrix used to reduce the full\n* matrix to tridiagonal form corresponding to\n* the subset of the full matrix which is being\n* decomposed at this time.\n* If ICOMPQ = 2 On entry, Q will be the identity matrix.\n* On exit, Q contains the eigenvectors of the\n* tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If eigenvectors are\n* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.\n*\n* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)\n* Referenced only when ICOMPQ = 1. Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE. If ICOMPQ = 1,\n* then LDQS >= max(1,N). In any case, LDQS >= 1.\n*\n* WORK (workspace) DOUBLE PRECISION array,\n* If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n* 1 + 3*N + 2*N*lg N + 2*N**2\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of WORK must be at least\n* 4*N + N**2.\n*\n* IWORK (workspace) INTEGER array,\n* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of IWORK must be at least\n* 3 + 5*N.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q = NumRu::Lapack.dlaed0( icompq, qsiz, d, e, q, [: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_icompq = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ qsiz = NUM2INT(rblapack_qsiz);
+ ldqs = icompq == 1 ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ qstore = ALLOC_N(doublereal, (ldqs)*(n));
+ work = ALLOC_N(doublereal, (((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0));
+ iwork = ALLOC_N(integer, (((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0));
+
+ dlaed0_(&icompq, &qsiz, &n, d, e, q, &ldq, qstore, &ldqs, work, iwork, &info);
+
+ free(qstore);
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_q);
+}
+
+void
+init_lapack_dlaed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed0", rblapack_dlaed0, -1);
+}
diff --git a/ext/dlaed1.c b/ext/dlaed1.c
new file mode 100644
index 0000000..02cece5
--- /dev/null
+++ b/ext/dlaed1.c
@@ -0,0 +1,133 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed1_(integer* n, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, integer* cutpnt, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlaed1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_indxq_out__;
+ integer *indxq_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q, indxq = NumRu::Lapack.dlaed1( d, q, indxq, rho, cutpnt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAED1 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles\n* the case in which eigenvalues only or eigenvalues and eigenvectors\n* of a full symmetric matrix (which was reduced to tridiagonal form)\n* are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine DLAED4 (as called by DLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* On entry, the permutation which separately sorts the two\n* subproblems in D into ascending order.\n* On exit, the permutation which will reintegrate the\n* subproblems back into sorted order,\n* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* RHO (input) DOUBLE PRECISION\n* The subdiagonal entry used to create the rank-1 modification.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= CUTPNT <= N/2.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,\n $ IW, IZ, K, N1, N2, ZPP1\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q, indxq = NumRu::Lapack.dlaed1( d, q, indxq, rho, cutpnt, [: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_d = argv[0];
+ rblapack_q = argv[1];
+ rblapack_indxq = argv[2];
+ rblapack_rho = argv[3];
+ rblapack_cutpnt = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_indxq))
+ rb_raise(rb_eArgError, "indxq (3th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (2th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ rho = NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
+ MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
+ rblapack_indxq = rblapack_indxq_out__;
+ indxq = indxq_out__;
+ work = ALLOC_N(doublereal, (4*n + pow(n,2)));
+ iwork = ALLOC_N(integer, (4*n));
+
+ dlaed1_(&n, d, q, &ldq, indxq, &rho, &cutpnt, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq);
+}
+
+void
+init_lapack_dlaed1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed1", rblapack_dlaed1, -1);
+}
diff --git a/ext/dlaed2.c b/ext/dlaed2.c
new file mode 100644
index 0000000..9fc4856
--- /dev/null
+++ b/ext/dlaed2.c
@@ -0,0 +1,189 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed2_(integer* k, integer* n, integer* n1, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, doublereal* z, doublereal* dlamda, doublereal* w, doublereal* q2, integer* indx, integer* indxc, integer* indxp, integer* coltyp, integer* info);
+
+
+static VALUE
+rblapack_dlaed2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_dlamda;
+ doublereal *dlamda;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_q2;
+ doublereal *q2;
+ VALUE rblapack_indxc;
+ integer *indxc;
+ VALUE rblapack_coltyp;
+ integer *coltyp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_indxq_out__;
+ integer *indxq_out__;
+ integer *indx;
+ integer *indxp;
+
+ integer n;
+ integer ldq;
+
+ 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 k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.dlaed2( n1, d, q, indxq, rho, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* DLAED2 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation. 0 <= K <=N.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined.\n* On exit, D contains the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, Q contains the eigenvectors of two submatrices in\n* the two square blocks with corners at (1,1), (N1,N1)\n* and (N1+1, N1+1), (N,N).\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have N1 added to their\n* values. Destroyed on exit.\n*\n* RHO (input/output) DOUBLE PRECISION\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* DLAED3.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* On entry, Z contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n* On exit, the contents of Z have been destroyed by the updating\n* process.\n*\n* DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* DLAED3 to form the secular equation.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first k values of the final deflation-altered z-vector\n* which will be passed to DLAED3.\n*\n* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)\n* A copy of the first K eigenvectors which will be used by\n* DLAED3 in a matrix multiply (DGEMM) to solve for the new\n* eigenvectors.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of DLAMDA into\n* ascending order.\n*\n* INDXC (output) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups: the first group contains non-zero\n* elements only at and above N1, the second contains\n* non-zero elements only below N1, and the third is dense.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* COLTYP (workspace/output) INTEGER array, dimension (N)\n* During execution, a label which will indicate which of the\n* following types a column in the Q2 matrix is:\n* 1 : non-zero in the upper half only;\n* 2 : dense;\n* 3 : non-zero in the lower half only;\n* 4 : deflated.\n* On exit, COLTYP(i) is the number of columns of type i,\n* for i=1 to 4 only.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.dlaed2( n1, d, q, indxq, rho, z, [: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_n1 = argv[0];
+ rblapack_d = argv[1];
+ rblapack_q = argv[2];
+ rblapack_indxq = argv[3];
+ rblapack_rho = argv[4];
+ rblapack_z = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n1 = NUM2INT(rblapack_n1);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ rho = NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of q");
+ 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_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_indxq))
+ rb_raise(rb_eArgError, "indxq (4th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = pow(n1,2)+pow(n-n1,2);
+ rblapack_q2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ q2 = NA_PTR_TYPE(rblapack_q2, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxc = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxc = NA_PTR_TYPE(rblapack_indxc, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
+ MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
+ rblapack_indxq = rblapack_indxq_out__;
+ indxq = indxq_out__;
+ indx = ALLOC_N(integer, (n));
+ indxp = ALLOC_N(integer, (n));
+
+ dlaed2_(&k, &n, &n1, d, q, &ldq, indxq, &rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, &info);
+
+ free(indx);
+ free(indxp);
+ rblapack_k = INT2NUM(k);
+ rblapack_info = INT2NUM(info);
+ rblapack_rho = rb_float_new((double)rho);
+ return rb_ary_new3(11, rblapack_k, rblapack_dlamda, rblapack_w, rblapack_q2, rblapack_indxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq, rblapack_rho);
+}
+
+void
+init_lapack_dlaed2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed2", rblapack_dlaed2, -1);
+}
diff --git a/ext/dlaed3.c b/ext/dlaed3.c
new file mode 100644
index 0000000..9219e84
--- /dev/null
+++ b/ext/dlaed3.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed3_(integer* k, integer* n, integer* n1, doublereal* d, doublereal* q, integer* ldq, doublereal* rho, doublereal* dlamda, doublereal* q2, integer* indx, integer* ctot, doublereal* w, doublereal* s, integer* info);
+
+
+static VALUE
+rblapack_dlaed3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_dlamda;
+ doublereal *dlamda;
+ VALUE rblapack_q2;
+ doublereal *q2;
+ VALUE rblapack_indx;
+ integer *indx;
+ VALUE rblapack_ctot;
+ integer *ctot;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dlamda_out__;
+ doublereal *dlamda_out__;
+ VALUE rblapack_w_out__;
+ doublereal *w_out__;
+ doublereal *s;
+
+ integer k;
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, q, info, dlamda, w = NumRu::Lapack.dlaed3( n1, rho, dlamda, q2, indx, ctot, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n* Purpose\n* =======\n*\n* DLAED3 finds the roots of the secular equation, as defined by the\n* values in D, W, and RHO, between 1 and K. It makes the\n* appropriate calls to DLAED4 and then updates the eigenvectors by\n* multiplying the matrix of eigenvectors of the pair of eigensystems\n* being combined by the matrix of eigenvectors of the K-by-K system\n* which is solved here.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* DLAED4. K >= 0.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (deflation may result in N>K).\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading submatrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* D(I) contains the updated eigenvalues for\n* 1 <= I <= K.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n* Initially the first K columns are used as workspace.\n* On output the columns 1 to K contain\n* the updated eigenvectors.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) DOUBLE PRECISION\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation. May be changed on output by\n* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n* Cray-2, or Cray C-90, as described above.\n*\n* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)\n* The first K columns of this matrix contain the non-deflated\n* eigenvectors for the split problem.\n*\n* INDX (input) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups (see DLAED2).\n* The rows of the eigenvectors found by DLAED4 must be likewise\n* permuted before the matrix multiply can take place.\n*\n* CTOT (input) INTEGER array, dimension (4)\n* A count of the total number of the various types of columns\n* in Q, as described in INDX. The fourth column type is any\n* column which has been deflated.\n*\n* W (input/output) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector. Destroyed on\n* output.\n*\n* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K\n* Will contain the eigenvectors of the repaired matrix which\n* will be multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, q, info, dlamda, w = NumRu::Lapack.dlaed3( n1, rho, dlamda, q2, indx, ctot, w, [: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_n1 = argv[0];
+ rblapack_rho = argv[1];
+ rblapack_dlamda = argv[2];
+ rblapack_q2 = argv[3];
+ rblapack_indx = argv[4];
+ rblapack_ctot = argv[5];
+ rblapack_w = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n1 = NUM2INT(rblapack_n1);
+ if (!NA_IsNArray(rblapack_dlamda))
+ rb_raise(rb_eArgError, "dlamda (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dlamda) != 1)
+ rb_raise(rb_eArgError, "rank of dlamda (3th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_dlamda);
+ if (NA_TYPE(rblapack_dlamda) != NA_DFLOAT)
+ rblapack_dlamda = na_change_type(rblapack_dlamda, NA_DFLOAT);
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
+ if (!NA_IsNArray(rblapack_indx))
+ rb_raise(rb_eArgError, "indx (5th argument) must be NArray");
+ if (NA_RANK(rblapack_indx) != 1)
+ rb_raise(rb_eArgError, "rank of indx (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_indx);
+ if (NA_TYPE(rblapack_indx) != NA_LINT)
+ rblapack_indx = na_change_type(rblapack_indx, NA_LINT);
+ indx = NA_PTR_TYPE(rblapack_indx, integer*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (7th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ rho = NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_ctot))
+ rb_raise(rb_eArgError, "ctot (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ctot) != 1)
+ rb_raise(rb_eArgError, "rank of ctot (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ctot) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
+ if (NA_TYPE(rblapack_ctot) != NA_LINT)
+ rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
+ ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
+ if (!NA_IsNArray(rblapack_q2))
+ rb_raise(rb_eArgError, "q2 (4th argument) must be NArray");
+ if (NA_RANK(rblapack_q2) != 2)
+ rb_raise(rb_eArgError, "rank of q2 (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_q2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of q2 must be the same as shape 0 of indx");
+ if (NA_SHAPE1(rblapack_q2) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q2 must be the same as shape 0 of indx");
+ if (NA_TYPE(rblapack_q2) != NA_DFLOAT)
+ rblapack_q2 = na_change_type(rblapack_q2, NA_DFLOAT);
+ q2 = NA_PTR_TYPE(rblapack_q2, doublereal*);
+ ldq = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int 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*);
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_dlamda_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dlamda_out__ = NA_PTR_TYPE(rblapack_dlamda_out__, doublereal*);
+ MEMCPY(dlamda_out__, dlamda, doublereal, NA_TOTAL(rblapack_dlamda));
+ rblapack_dlamda = rblapack_dlamda_out__;
+ dlamda = dlamda_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
+ MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ s = ALLOC_N(doublereal, (MAX(1,k))*((n1 + 1)));
+
+ dlaed3_(&k, &n, &n1, d, q, &ldq, &rho, dlamda, q2, indx, ctot, w, s, &info);
+
+ free(s);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_q, rblapack_info, rblapack_dlamda, rblapack_w);
+}
+
+void
+init_lapack_dlaed3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed3", rblapack_dlaed3, -1);
+}
diff --git a/ext/dlaed4.c b/ext/dlaed4.c
new file mode 100644
index 0000000..ede1086
--- /dev/null
+++ b/ext/dlaed4.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed4_(integer* n, integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* dlam, integer* info);
+
+
+static VALUE
+rblapack_dlaed4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_delta;
+ doublereal *delta;
+ VALUE rblapack_dlam;
+ doublereal dlam;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 delta, dlam, info = NumRu::Lapack.dlaed4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th updated eigenvalue of a symmetric\n* rank-one modification to a diagonal matrix whose elements are\n* given in the array d, and that\n*\n* D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The original eigenvalues. It is assumed that they are in\n* order, D(I) < D(J) for I < J.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension (N)\n* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5\n* for detail. The vector DELTA contains the information necessary\n* to construct the eigenvectors by DLAED3 and DLAED9.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) DOUBLE PRECISION\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, dlam, info = NumRu::Lapack.dlaed4( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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*);
+ rho = NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, doublereal*);
+
+ dlaed4_(&n, &i, d, z, delta, &rho, &dlam, &info);
+
+ rblapack_dlam = rb_float_new((double)dlam);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_delta, rblapack_dlam, rblapack_info);
+}
+
+void
+init_lapack_dlaed4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed4", rblapack_dlaed4, -1);
+}
diff --git a/ext/dlaed5.c b/ext/dlaed5.c
new file mode 100644
index 0000000..a0145f7
--- /dev/null
+++ b/ext/dlaed5.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed5_(integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* dlam);
+
+
+static VALUE
+rblapack_dlaed5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_delta;
+ doublereal *delta;
+ VALUE rblapack_dlam;
+ doublereal dlam;
+
+
+ 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 delta, dlam = NumRu::Lapack.dlaed5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th eigenvalue of a symmetric rank-one\n* modification of a 2-by-2 diagonal matrix\n*\n* diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal elements in the array D are assumed to satisfy\n*\n* D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) DOUBLE PRECISION array, dimension (2)\n* The original eigenvalues. We assume D(1) < D(2).\n*\n* Z (input) DOUBLE PRECISION array, dimension (2)\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension (2)\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) DOUBLE PRECISION\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, dlam = NumRu::Lapack.dlaed5( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_d) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ rho = NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, doublereal*);
+
+ dlaed5_(&i, d, z, delta, &rho, &dlam);
+
+ rblapack_dlam = rb_float_new((double)dlam);
+ return rb_ary_new3(2, rblapack_delta, rblapack_dlam);
+}
+
+void
+init_lapack_dlaed5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed5", rblapack_dlaed5, -1);
+}
diff --git a/ext/dlaed6.c b/ext/dlaed6.c
new file mode 100644
index 0000000..eea0179
--- /dev/null
+++ b/ext/dlaed6.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed6_(integer* kniter, logical* orgati, doublereal* rho, doublereal* d, doublereal* z, doublereal* finit, doublereal* tau, integer* info);
+
+
+static VALUE
+rblapack_dlaed6(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kniter;
+ integer kniter;
+ VALUE rblapack_orgati;
+ logical orgati;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_finit;
+ doublereal finit;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 tau, info = NumRu::Lapack.dlaed6( kniter, orgati, rho, d, z, finit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n* Purpose\n* =======\n*\n* DLAED6 computes the positive or negative root (closest to the origin)\n* of\n* z(1) z(2) z(3)\n* f(x) = rho + --------- + ---------- + ---------\n* d(1)-x d(2)-x d(3)-x\n*\n* It is assumed that\n*\n* if ORGATI = .true. the root is between d(2) and d(3);\n* otherwise it is between d(1) and d(2)\n*\n* This routine will be called by DLAED4 when necessary. In most cases,\n* the root sought is the smallest in magnitude, though it might not be\n* in some extremely rare situations.\n*\n\n* Arguments\n* =========\n*\n* KNITER (input) INTEGER\n* Refer to DLAED4 for its significance.\n*\n* ORGATI (input) LOGICAL\n* If ORGATI is true, the needed root is between d(2) and\n* d(3); otherwise it is between d(1) and d(2). See\n* DLAED4 for further details.\n*\n* RHO (input) DOUBLE PRECISION\n* Refer to the equation f(x) above.\n*\n* D (input) DOUBLE PRECISION array, dimension (3)\n* D satisfies d(1) < d(2) < d(3).\n*\n* Z (input) DOUBLE PRECISION array, dimension (3)\n* Each of the elements in z must be positive.\n*\n* FINIT (input) DOUBLE PRECISION\n* The value of f at 0. It is more accurate than the one\n* evaluated inside this routine (if someone wants to do\n* so).\n*\n* TAU (output) DOUBLE PRECISION\n* The root of the equation f(x).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, failure to converge\n*\n\n* Further Details\n* ===============\n*\n* 30/06/99: Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* 10/02/03: This version has a few statements commented out for thread\n* safety (machine parameters are computed on each entry). SJH.\n*\n* 05/10/06: Modified from a new version of Ren-Cang Li, use\n* Gragg-Thornton-Warner cubic convergent scheme for better stability.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info = NumRu::Lapack.dlaed6( kniter, orgati, rho, d, z, finit, [: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_kniter = argv[0];
+ rblapack_orgati = argv[1];
+ rblapack_rho = argv[2];
+ rblapack_d = argv[3];
+ rblapack_z = argv[4];
+ rblapack_finit = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kniter = NUM2INT(rblapack_kniter);
+ rho = NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (5th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 3);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ orgati = (rblapack_orgati == Qtrue);
+ finit = NUM2DBL(rblapack_finit);
+ 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) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 3);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+
+ dlaed6_(&kniter, &orgati, &rho, d, z, &finit, &tau, &info);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_tau, rblapack_info);
+}
+
+void
+init_lapack_dlaed6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed6", rblapack_dlaed6, -1);
+}
diff --git a/ext/dlaed7.c b/ext/dlaed7.c
new file mode 100644
index 0000000..39194f9
--- /dev/null
+++ b/ext/dlaed7.c
@@ -0,0 +1,248 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed7_(integer* icompq, integer* n, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, integer* cutpnt, doublereal* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlaed7(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_tlvls;
+ integer tlvls;
+ VALUE rblapack_curlvl;
+ integer curlvl;
+ VALUE rblapack_curpbm;
+ integer curpbm;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_qstore;
+ doublereal *qstore;
+ VALUE rblapack_qptr;
+ integer *qptr;
+ VALUE rblapack_prmptr;
+ integer *prmptr;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_qstore_out__;
+ doublereal *qstore_out__;
+ VALUE rblapack_qptr_out__;
+ integer *qptr_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+
+ 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 indxq, info, d, q, qstore, qptr = NumRu::Lapack.dlaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense symmetric matrix\n* that has been reduced to tridiagonal form. DLAED1 handles\n* the case in which all eigenvalues and eigenvectors of a symmetric\n* tridiagonal matrix are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLAED8.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine DLAED4 (as called by DLAED9).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= CURLVL <= TLVLS.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* The permutation which will reintegrate the subproblem just\n* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n* will be in ascending order.\n*\n* RHO (input) DOUBLE PRECISION\n* The subdiagonal element used to create the rank-1\n* modification.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.dlaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 16 && argc != 16)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_tlvls = argv[2];
+ rblapack_curlvl = argv[3];
+ rblapack_curpbm = argv[4];
+ rblapack_d = argv[5];
+ rblapack_q = argv[6];
+ rblapack_rho = argv[7];
+ rblapack_cutpnt = argv[8];
+ rblapack_qstore = argv[9];
+ rblapack_qptr = argv[10];
+ rblapack_prmptr = argv[11];
+ rblapack_perm = argv[12];
+ rblapack_givptr = argv[13];
+ rblapack_givcol = argv[14];
+ rblapack_givnum = argv[15];
+ if (argc == 16) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ tlvls = NUM2INT(rblapack_tlvls);
+ curpbm = NUM2INT(rblapack_curpbm);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (6th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (6th 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 1 of q");
+ 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_qstore))
+ rb_raise(rb_eArgError, "qstore (10th argument) must be NArray");
+ if (NA_RANK(rblapack_qstore) != 1)
+ rb_raise(rb_eArgError, "rank of qstore (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
+ if (NA_TYPE(rblapack_qstore) != NA_DFLOAT)
+ rblapack_qstore = na_change_type(rblapack_qstore, NA_DFLOAT);
+ qstore = NA_PTR_TYPE(rblapack_qstore, doublereal*);
+ if (!NA_IsNArray(rblapack_prmptr))
+ rb_raise(rb_eArgError, "prmptr (12th argument) must be NArray");
+ if (NA_RANK(rblapack_prmptr) != 1)
+ rb_raise(rb_eArgError, "rank of prmptr (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_prmptr) != NA_LINT)
+ rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
+ prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (14th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (16th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (16th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
+ if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ curlvl = NUM2INT(rblapack_curlvl);
+ if (!NA_IsNArray(rblapack_qptr))
+ rb_raise(rb_eArgError, "qptr (11th argument) must be NArray");
+ if (NA_RANK(rblapack_qptr) != 1)
+ rb_raise(rb_eArgError, "rank of qptr (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qptr) != (n+2))
+ rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
+ if (NA_TYPE(rblapack_qptr) != NA_LINT)
+ rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
+ qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (15th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (15th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
+ if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ rho = NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (13th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = pow(n,2)+1;
+ rblapack_qstore_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, doublereal*);
+ MEMCPY(qstore_out__, qstore, doublereal, NA_TOTAL(rblapack_qstore));
+ rblapack_qstore = rblapack_qstore_out__;
+ qstore = qstore_out__;
+ {
+ int shape[1];
+ shape[0] = n+2;
+ rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
+ MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
+ rblapack_qptr = rblapack_qptr_out__;
+ qptr = qptr_out__;
+ work = ALLOC_N(doublereal, (3*n+qsiz*n));
+ iwork = ALLOC_N(integer, (4*n));
+
+ dlaed7_(&icompq, &n, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, indxq, &rho, &cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
+}
+
+void
+init_lapack_dlaed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed7", rblapack_dlaed7, -1);
+}
diff --git a/ext/dlaed8.c b/ext/dlaed8.c
new file mode 100644
index 0000000..f2fd27f
--- /dev/null
+++ b/ext/dlaed8.c
@@ -0,0 +1,206 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed8_(integer* icompq, integer* k, integer* n, integer* qsiz, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, integer* cutpnt, doublereal* z, doublereal* dlamda, doublereal* q2, integer* ldq2, doublereal* w, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, integer* indxp, integer* indx, integer* info);
+
+
+static VALUE
+rblapack_dlaed8(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_dlamda;
+ doublereal *dlamda;
+ VALUE rblapack_q2;
+ doublereal *q2;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ integer *indxp;
+ integer *indx;
+
+ integer n;
+ integer ldq2;
+
+ 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 k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.dlaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n* Purpose\n* =======\n*\n* DLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the two submatrices to be\n* combined. On exit, the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* If ICOMPQ = 0, Q is not referenced. Otherwise,\n* on entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have CUTPNT added to\n* their values in order to be accurate.\n*\n* RHO (input/output) DOUBLE PRECISION\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* DLAED3.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* On entry, Z contains the updating vector (the last row of\n* the first sub-eigenvector matrix and the first row of the\n* second sub-eigenvector matrix).\n* On exit, the contents of Z are destroyed by the updating\n* process.\n*\n* DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* DLAED3 to form the secular equation.\n*\n* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* a copy of the first K eigenvectors which will be used by\n* DLAED7 in a matrix multiply (DGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first k values of the final deflation-altered z-vector and\n* will be passed to DLAED3.\n*\n* PERM (output) INTEGER array, dimension (N)\n* The permutations (from deflation and sorting) to be applied\n* to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of D into ascending\n* order.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.dlaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_q = argv[3];
+ rblapack_ldq = argv[4];
+ rblapack_indxq = argv[5];
+ rblapack_rho = argv[6];
+ rblapack_cutpnt = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ ldq = NUM2INT(rblapack_ldq);
+ rho = NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_indxq))
+ rb_raise(rb_eArgError, "indxq (6th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ ldq2 = MAX(1,n);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (4th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_q) != (icompq==0 ? 0 : ldq))
+ rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", icompq==0 ? 0 : ldq);
+ if (NA_SHAPE1(rblapack_q) != (icompq==0 ? 0 : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", icompq==0 ? 0 : n);
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
+ {
+ int shape[2];
+ shape[0] = icompq==0 ? 0 : ldq2;
+ shape[1] = icompq==0 ? 0 : n;
+ rblapack_q2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q2 = NA_PTR_TYPE(rblapack_q2, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = icompq==0 ? 0 : ldq;
+ shape[1] = icompq==0 ? 0 : n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ indxp = ALLOC_N(integer, (n));
+ indx = ALLOC_N(integer, (n));
+
+ dlaed8_(&icompq, &k, &n, &qsiz, d, q, &ldq, indxq, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, perm, &givptr, givcol, givnum, indxp, indx, &info);
+
+ free(indxp);
+ free(indx);
+ rblapack_k = INT2NUM(k);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_info = INT2NUM(info);
+ rblapack_rho = rb_float_new((double)rho);
+ return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_d, rblapack_q, rblapack_rho);
+}
+
+void
+init_lapack_dlaed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed8", rblapack_dlaed8, -1);
+}
diff --git a/ext/dlaed9.c b/ext/dlaed9.c
new file mode 100644
index 0000000..bbe9cbc
--- /dev/null
+++ b/ext/dlaed9.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID dlaed9_(integer* k, integer* kstart, integer* kstop, integer* n, doublereal* d, doublereal* q, integer* ldq, doublereal* rho, doublereal* dlamda, doublereal* w, doublereal* s, integer* lds, integer* info);
+
+
+static VALUE
+rblapack_dlaed9(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kstart;
+ integer kstart;
+ VALUE rblapack_kstop;
+ integer kstop;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_dlamda;
+ doublereal *dlamda;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *q;
+
+ integer k;
+ integer lds;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, s, info = NumRu::Lapack.dlaed9( kstart, kstop, n, rho, dlamda, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n* Purpose\n* =======\n*\n* DLAED9 finds the roots of the secular equation, as defined by the\n* values in D, Z, and RHO, between KSTART and KSTOP. It makes the\n* appropriate calls to DLAED4 and then stores the new matrix of\n* eigenvectors for use in calculating the next level of Z vectors.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* DLAED4. K >= 0.\n*\n* KSTART (input) INTEGER\n* KSTOP (input) INTEGER\n* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n* are to be computed. 1 <= KSTART <= KSTOP <= K.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (delation may result in N > K).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* D(I) contains the updated eigenvalues\n* for KSTART <= I <= KSTOP.\n*\n* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* RHO (input) DOUBLE PRECISION\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* W (input) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector.\n*\n* S (output) DOUBLE PRECISION array, dimension (LDS, K)\n* Will contain the eigenvectors of the repaired matrix which\n* will be stored for subsequent Z vector calculation and\n* multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION TEMP\n* ..\n* .. External Functions ..\n DOUBLE PRECISION DLAMC3, DNRM2\n EXTERNAL DLAMC3, DNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, DLAED4, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, SIGN, SQRT\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, s, info = NumRu::Lapack.dlaed9( kstart, kstop, n, rho, dlamda, w, [: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_kstart = argv[0];
+ rblapack_kstop = argv[1];
+ rblapack_n = argv[2];
+ rblapack_rho = argv[3];
+ rblapack_dlamda = argv[4];
+ rblapack_w = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kstart = NUM2INT(rblapack_kstart);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_dlamda))
+ rb_raise(rb_eArgError, "dlamda (5th argument) must be NArray");
+ if (NA_RANK(rblapack_dlamda) != 1)
+ rb_raise(rb_eArgError, "rank of dlamda (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_dlamda);
+ if (NA_TYPE(rblapack_dlamda) != NA_DFLOAT)
+ rblapack_dlamda = na_change_type(rblapack_dlamda, NA_DFLOAT);
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
+ ldq = MAX( 1, n );
+ kstop = NUM2INT(rblapack_kstop);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (6th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ rho = NUM2DBL(rblapack_rho);
+ lds = MAX( 1, k );
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lds;
+ shape[1] = k;
+ rblapack_s = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ q = ALLOC_N(doublereal, (ldq)*(MAX(1,n)));
+
+ dlaed9_(&k, &kstart, &kstop, &n, d, q, &ldq, &rho, dlamda, w, s, &lds, &info);
+
+ free(q);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_d, rblapack_s, rblapack_info);
+}
+
+void
+init_lapack_dlaed9(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaed9", rblapack_dlaed9, -1);
+}
diff --git a/ext/dlaeda.c b/ext/dlaeda.c
new file mode 100644
index 0000000..b2f5424
--- /dev/null
+++ b/ext/dlaeda.c
@@ -0,0 +1,160 @@
+#include "rb_lapack.h"
+
+extern VOID dlaeda_(integer* n, integer* tlvls, integer* curlvl, integer* curpbm, integer* prmptr, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, doublereal* q, integer* qptr, doublereal* z, doublereal* ztemp, integer* info);
+
+
+static VALUE
+rblapack_dlaeda(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_tlvls;
+ integer tlvls;
+ VALUE rblapack_curlvl;
+ integer curlvl;
+ VALUE rblapack_curpbm;
+ integer curpbm;
+ VALUE rblapack_prmptr;
+ integer *prmptr;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_qptr;
+ integer *qptr;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *ztemp;
+
+ integer ldqptr;
+ 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 z, info = NumRu::Lapack.dlaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n* Purpose\n* =======\n*\n* DLAEDA computes the Z vector corresponding to the merge step in the\n* CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n* problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and incidentally the\n* size of the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* Q (input) DOUBLE PRECISION array, dimension (N**2)\n* Contains the square eigenblocks from previous levels, the\n* starting positions for blocks are given by QPTR.\n*\n* QPTR (input) INTEGER array, dimension (N+2)\n* Contains a list of pointers which indicate where in Q an\n* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates\n* the size of the block.\n*\n* Z (output) DOUBLE PRECISION array, dimension (N)\n* On output this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n*\n* ZTEMP (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, info = NumRu::Lapack.dlaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_tlvls = argv[0];
+ rblapack_curlvl = argv[1];
+ rblapack_curpbm = argv[2];
+ rblapack_prmptr = argv[3];
+ rblapack_perm = argv[4];
+ rblapack_givptr = argv[5];
+ rblapack_givcol = argv[6];
+ rblapack_givnum = argv[7];
+ rblapack_q = argv[8];
+ rblapack_qptr = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ tlvls = NUM2INT(rblapack_tlvls);
+ curpbm = NUM2INT(rblapack_curpbm);
+ if (!NA_IsNArray(rblapack_qptr))
+ rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_qptr) != 1)
+ rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
+ ldqptr = NA_SHAPE0(rblapack_qptr);
+ if (NA_TYPE(rblapack_qptr) != NA_LINT)
+ rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
+ qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
+ curlvl = NUM2INT(rblapack_curlvl);
+ n = ldqptr-2;
+ if (!NA_IsNArray(rblapack_prmptr))
+ rb_raise(rb_eArgError, "prmptr (4th argument) must be NArray");
+ if (NA_RANK(rblapack_prmptr) != 1)
+ rb_raise(rb_eArgError, "rank of prmptr (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_prmptr) != NA_LINT)
+ rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
+ prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (8th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
+ if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (5th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (9th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 1)
+ rb_raise(rb_eArgError, "rank of q (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_q) != (pow(n,2)))
+ rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", pow(n,2));
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (7th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
+ if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ ztemp = ALLOC_N(doublereal, (n));
+
+ dlaeda_(&n, &tlvls, &curlvl, &curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, &info);
+
+ free(ztemp);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_z, rblapack_info);
+}
+
+void
+init_lapack_dlaeda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaeda", rblapack_dlaeda, -1);
+}
diff --git a/ext/dlaein.c b/ext/dlaein.c
new file mode 100644
index 0000000..4b3e259
--- /dev/null
+++ b/ext/dlaein.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID dlaein_(logical* rightv, logical* noinit, integer* n, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, doublereal* vr, doublereal* vi, doublereal* b, integer* ldb, doublereal* work, doublereal* eps3, doublereal* smlnum, doublereal* bignum, integer* info);
+
+
+static VALUE
+rblapack_dlaein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_rightv;
+ logical rightv;
+ VALUE rblapack_noinit;
+ logical noinit;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_wr;
+ doublereal wr;
+ VALUE rblapack_wi;
+ doublereal wi;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_vi;
+ doublereal *vi;
+ VALUE rblapack_eps3;
+ doublereal eps3;
+ VALUE rblapack_smlnum;
+ doublereal smlnum;
+ VALUE rblapack_bignum;
+ doublereal bignum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_vr_out__;
+ doublereal *vr_out__;
+ VALUE rblapack_vi_out__;
+ doublereal *vi_out__;
+ doublereal *b;
+ doublereal *work;
+
+ integer ldh;
+ integer n;
+ integer ldb;
+
+ 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, vr, vi = NumRu::Lapack.dlaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n* Purpose\n* =======\n*\n* DLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in (VR,VI).\n* = .FALSE.: initial vector supplied in (VR,VI).\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) DOUBLE PRECISION array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input) DOUBLE PRECISION\n* WI (input) DOUBLE PRECISION\n* The real and imaginary parts of the eigenvalue of H whose\n* corresponding right or left eigenvector is to be computed.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (N)\n* VI (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n* a real starting vector for inverse iteration using the real\n* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n* must contain the real and imaginary parts of a complex\n* starting vector for inverse iteration using the complex\n* eigenvalue (WR,WI); otherwise VR and VI need not be set.\n* On exit, if WI = 0.0 (real eigenvalue), VR contains the\n* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n* VR and VI contain the real and imaginary parts of the\n* computed complex eigenvector. The eigenvector is normalized\n* so that the component of largest magnitude has magnitude 1;\n* here the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n* VI is not referenced if WI = 0.0.\n*\n* B (workspace) DOUBLE PRECISION array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= N+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* EPS3 (input) DOUBLE PRECISION\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) DOUBLE PRECISION\n* A machine-dependent value close to the underflow threshold.\n*\n* BIGNUM (input) DOUBLE PRECISION\n* A machine-dependent value close to the overflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; VR is set to the\n* last iterate, and so is VI if WI.ne.0.0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, vr, vi = NumRu::Lapack.dlaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_rightv = argv[0];
+ rblapack_noinit = argv[1];
+ rblapack_h = argv[2];
+ rblapack_wr = argv[3];
+ rblapack_wi = argv[4];
+ rblapack_vr = argv[5];
+ rblapack_vi = argv[6];
+ rblapack_eps3 = argv[7];
+ rblapack_smlnum = argv[8];
+ rblapack_bignum = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ rightv = (rblapack_rightv == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (3th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ wi = NUM2DBL(rblapack_wi);
+ if (!NA_IsNArray(rblapack_vi))
+ rb_raise(rb_eArgError, "vi (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vi) != 1)
+ rb_raise(rb_eArgError, "rank of vi (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vi) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vi must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_vi) != NA_DFLOAT)
+ rblapack_vi = na_change_type(rblapack_vi, NA_DFLOAT);
+ vi = NA_PTR_TYPE(rblapack_vi, doublereal*);
+ smlnum = NUM2DBL(rblapack_smlnum);
+ noinit = (rblapack_noinit == Qtrue);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 1)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vr must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ bignum = NUM2DBL(rblapack_bignum);
+ wr = NUM2DBL(rblapack_wr);
+ ldb = n+1;
+ eps3 = NUM2DBL(rblapack_eps3);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
+ MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vi_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vi_out__ = NA_PTR_TYPE(rblapack_vi_out__, doublereal*);
+ MEMCPY(vi_out__, vi, doublereal, NA_TOTAL(rblapack_vi));
+ rblapack_vi = rblapack_vi_out__;
+ vi = vi_out__;
+ b = ALLOC_N(doublereal, (ldb)*(n));
+ work = ALLOC_N(doublereal, (n));
+
+ dlaein_(&rightv, &noinit, &n, h, &ldh, &wr, &wi, vr, vi, b, &ldb, work, &eps3, &smlnum, &bignum, &info);
+
+ free(b);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_vr, rblapack_vi);
+}
+
+void
+init_lapack_dlaein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaein", rblapack_dlaein, -1);
+}
diff --git a/ext/dlaev2.c b/ext/dlaev2.c
new file mode 100644
index 0000000..88d9536
--- /dev/null
+++ b/ext/dlaev2.c
@@ -0,0 +1,68 @@
+#include "rb_lapack.h"
+
+extern VOID dlaev2_(doublereal* a, doublereal* b, doublereal* c, doublereal* rt1, doublereal* rt2, doublereal* cs1, doublereal* sn1);
+
+
+static VALUE
+rblapack_dlaev2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal a;
+ VALUE rblapack_b;
+ doublereal b;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_rt1;
+ doublereal rt1;
+ VALUE rblapack_rt2;
+ doublereal rt2;
+ VALUE rblapack_cs1;
+ doublereal cs1;
+ VALUE rblapack_sn1;
+ doublereal sn1;
+
+
+ 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 rt1, rt2, cs1, sn1 = NumRu::Lapack.dlaev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) DOUBLE PRECISION\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) DOUBLE PRECISION\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) DOUBLE PRECISION\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) DOUBLE PRECISION\n* SN1 (output) DOUBLE PRECISION\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.dlaev2( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = NUM2DBL(rblapack_a);
+ c = NUM2DBL(rblapack_c);
+ b = NUM2DBL(rblapack_b);
+
+ dlaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
+
+ rblapack_rt1 = rb_float_new((double)rt1);
+ rblapack_rt2 = rb_float_new((double)rt2);
+ rblapack_cs1 = rb_float_new((double)cs1);
+ rblapack_sn1 = rb_float_new((double)sn1);
+ return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
+}
+
+void
+init_lapack_dlaev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaev2", rblapack_dlaev2, -1);
+}
diff --git a/ext/dlaexc.c b/ext/dlaexc.c
new file mode 100644
index 0000000..c566201
--- /dev/null
+++ b/ext/dlaexc.c
@@ -0,0 +1,118 @@
+#include "rb_lapack.h"
+
+extern VOID dlaexc_(logical* wantq, integer* n, doublereal* t, integer* ldt, doublereal* q, integer* ldq, integer* j1, integer* n1, integer* n2, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlaexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_j1;
+ integer j1;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ doublereal *t_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ doublereal *work;
+
+ integer ldt;
+ integer n;
+ integer ldq;
+
+ 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, t, q = NumRu::Lapack.dlaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n* an upper quasi-triangular matrix T by an orthogonal similarity\n* transformation.\n*\n* T must be in Schur canonical form, that is, block upper triangular\n* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n* has its diagonal elemnts equal and its off-diagonal elements of\n* opposite sign.\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* = .TRUE. : accumulate the transformation in the matrix Q;\n* = .FALSE.: do not accumulate the transformation.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, the updated matrix T, again in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n* On exit, if WANTQ is .TRUE., the updated matrix Q.\n* If WANTQ is .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n*\n* J1 (input) INTEGER\n* The index of the first row of the first block T11.\n*\n* N1 (input) INTEGER\n* The order of the first block T11. N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block T22. N2 = 0, 1 or 2.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: the transformed matrix T would be too far from Schur\n* form; the blocks are not swapped and T and Q are\n* unchanged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.dlaexc( wantq, t, q, j1, n1, n2, [: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_wantq = argv[0];
+ rblapack_t = argv[1];
+ rblapack_q = argv[2];
+ rblapack_j1 = argv[3];
+ rblapack_n1 = argv[4];
+ rblapack_n2 = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ n1 = NUM2INT(rblapack_n1);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (2th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ n2 = NUM2INT(rblapack_n2);
+ j1 = NUM2INT(rblapack_j1);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
+ MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(doublereal, (n));
+
+ dlaexc_(&wantq, &n, t, &ldt, q, &ldq, &j1, &n1, &n2, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_dlaexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaexc", rblapack_dlaexc, -1);
+}
diff --git a/ext/dlag2.c b/ext/dlag2.c
new file mode 100644
index 0000000..8890dc8
--- /dev/null
+++ b/ext/dlag2.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID dlag2_(doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* safmin, doublereal* scale1, doublereal* scale2, doublereal* wr1, doublereal* wr2, doublereal* wi);
+
+
+static VALUE
+rblapack_dlag2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_safmin;
+ doublereal safmin;
+ VALUE rblapack_scale1;
+ doublereal scale1;
+ VALUE rblapack_scale2;
+ doublereal scale2;
+ VALUE rblapack_wr1;
+ doublereal wr1;
+ VALUE rblapack_wr2;
+ doublereal wr2;
+ VALUE rblapack_wi;
+ doublereal wi;
+
+ integer lda;
+ integer ldb;
+
+ 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 scale1, scale2, wr1, wr2, wi = NumRu::Lapack.dlag2( a, b, safmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n* Purpose\n* =======\n*\n* DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n* problem A - w B, with scaling as necessary to avoid over-/underflow.\n*\n* The scaling factor \"s\" results in a modified eigenvalue equation\n*\n* s A - w B\n*\n* where s is a non-negative scaling factor chosen so that w, w B,\n* and s A do not overflow and, if possible, do not underflow, either.\n*\n\n* Arguments\n* =========\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm\n* is less than 1/SAFMIN. Entries less than\n* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= 2.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB, 2)\n* On entry, the 2 x 2 upper triangular matrix B. It is\n* assumed that the one-norm of B is less than 1/SAFMIN. The\n* diagonals should be at least sqrt(SAFMIN) times the largest\n* element of B (in absolute value); if a diagonal is smaller\n* than that, then +/- sqrt(SAFMIN) will be used instead of\n* that diagonal.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 2.\n*\n* SAFMIN (input) DOUBLE PRECISION\n* The smallest positive number s.t. 1/SAFMIN does not\n* overflow. (This should always be DLAMCH('S') -- it is an\n* argument in order to avoid having to call DLAMCH frequently.)\n*\n* SCALE1 (output) DOUBLE PRECISION\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the first eigenvalue. If\n* the eigenvalues are complex, then the eigenvalues are\n* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the\n* exponent range of the machine), SCALE1=SCALE2, and SCALE1\n* will always be positive. If the eigenvalues are real, then\n* the first (real) eigenvalue is WR1 / SCALE1 , but this may\n* overflow or underflow, and in fact, SCALE1 may be zero or\n* less than the underflow threshhold if the exact eigenvalue\n* is sufficiently large.\n*\n* SCALE2 (output) DOUBLE PRECISION\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the second eigenvalue. If\n* the eigenvalues are complex, then SCALE2=SCALE1. If the\n* eigenvalues are real, then the second (real) eigenvalue is\n* WR2 / SCALE2 , but this may overflow or underflow, and in\n* fact, SCALE2 may be zero or less than the underflow\n* threshhold if the exact eigenvalue is sufficiently large.\n*\n* WR1 (output) DOUBLE PRECISION\n* If the eigenvalue is real, then WR1 is SCALE1 times the\n* eigenvalue closest to the (2,2) element of A B**(-1). If the\n* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n* part of the eigenvalues.\n*\n* WR2 (output) DOUBLE PRECISION\n* If the eigenvalue is real, then WR2 is SCALE2 times the\n* other eigenvalue. If the eigenvalue is complex, then\n* WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n*\n* WI (output) DOUBLE PRECISION\n* If the eigenvalue is real, then WI is zero. If the\n* eigenvalue is complex, then WI is SCALE1 times the imaginary\n* part of the eigenvalues. WI will always be non-negative.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale1, scale2, wr1, wr2, wi = NumRu::Lapack.dlag2( a, b, safmin, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_safmin = argv[2];
+ if (argc == 3) {
+ } 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);
+ if (NA_SHAPE1(rblapack_a) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ safmin = NUM2DBL(rblapack_safmin);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+
+ dlag2_(a, &lda, b, &ldb, &safmin, &scale1, &scale2, &wr1, &wr2, &wi);
+
+ rblapack_scale1 = rb_float_new((double)scale1);
+ rblapack_scale2 = rb_float_new((double)scale2);
+ rblapack_wr1 = rb_float_new((double)wr1);
+ rblapack_wr2 = rb_float_new((double)wr2);
+ rblapack_wi = rb_float_new((double)wi);
+ return rb_ary_new3(5, rblapack_scale1, rblapack_scale2, rblapack_wr1, rblapack_wr2, rblapack_wi);
+}
+
+void
+init_lapack_dlag2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlag2", rblapack_dlag2, -1);
+}
diff --git a/ext/dlag2s.c b/ext/dlag2s.c
new file mode 100644
index 0000000..d2a6d9d
--- /dev/null
+++ b/ext/dlag2s.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID dlag2s_(integer* m, integer* n, doublereal* a, integer* lda, real* sa, integer* ldsa, integer* info);
+
+
+static VALUE
+rblapack_dlag2s(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_sa;
+ real *sa;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer ldsa;
+
+ 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 sa, info = NumRu::Lapack.dlag2s( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE\n* PRECISION matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* DLAG2S checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SA (output) REAL array, dimension (LDSA,N)\n* On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n* INFO>0, the content of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n* ..\n* .. External Functions ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.dlag2s( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ldsa = MAX(1,m);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldsa;
+ shape[1] = n;
+ rblapack_sa = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ sa = NA_PTR_TYPE(rblapack_sa, real*);
+
+ dlag2s_(&m, &n, a, &lda, sa, &ldsa, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_sa, rblapack_info);
+}
+
+void
+init_lapack_dlag2s(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlag2s", rblapack_dlag2s, -1);
+}
diff --git a/ext/dlags2.c b/ext/dlags2.c
new file mode 100644
index 0000000..782e6ab
--- /dev/null
+++ b/ext/dlags2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID dlags2_(logical* upper, doublereal* a1, doublereal* a2, doublereal* a3, doublereal* b1, doublereal* b2, doublereal* b3, doublereal* csu, doublereal* snu, doublereal* csv, doublereal* snv, doublereal* csq, doublereal* snq);
+
+
+static VALUE
+rblapack_dlags2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_upper;
+ logical upper;
+ VALUE rblapack_a1;
+ doublereal a1;
+ VALUE rblapack_a2;
+ doublereal a2;
+ VALUE rblapack_a3;
+ doublereal a3;
+ VALUE rblapack_b1;
+ doublereal b1;
+ VALUE rblapack_b2;
+ doublereal b2;
+ VALUE rblapack_b3;
+ doublereal b3;
+ VALUE rblapack_csu;
+ doublereal csu;
+ VALUE rblapack_snu;
+ doublereal snu;
+ VALUE rblapack_csv;
+ doublereal csv;
+ VALUE rblapack_snv;
+ doublereal snv;
+ VALUE rblapack_csq;
+ doublereal csq;
+ VALUE rblapack_snq;
+ doublereal snq;
+
+
+ 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 csu, snu, csv, snv, csq, snq = NumRu::Lapack.dlags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n*\n* The rows of the transformed A and B are parallel, where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )\n* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )\n*\n* Z' denotes the transpose of Z.\n*\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) DOUBLE PRECISION\n* A2 (input) DOUBLE PRECISION\n* A3 (input) DOUBLE PRECISION\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) DOUBLE PRECISION\n* B2 (input) DOUBLE PRECISION\n* B3 (input) DOUBLE PRECISION\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) DOUBLE PRECISION\n* SNU (output) DOUBLE PRECISION\n* The desired orthogonal matrix U.\n*\n* CSV (output) DOUBLE PRECISION\n* SNV (output) DOUBLE PRECISION\n* The desired orthogonal matrix V.\n*\n* CSQ (output) DOUBLE PRECISION\n* SNQ (output) DOUBLE PRECISION\n* The desired orthogonal matrix Q.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.dlags2( upper, a1, a2, a3, b1, b2, b3, [: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_upper = argv[0];
+ rblapack_a1 = argv[1];
+ rblapack_a2 = argv[2];
+ rblapack_a3 = argv[3];
+ rblapack_b1 = argv[4];
+ rblapack_b2 = argv[5];
+ rblapack_b3 = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ upper = (rblapack_upper == Qtrue);
+ a2 = NUM2DBL(rblapack_a2);
+ b1 = NUM2DBL(rblapack_b1);
+ b3 = NUM2DBL(rblapack_b3);
+ a1 = NUM2DBL(rblapack_a1);
+ b2 = NUM2DBL(rblapack_b2);
+ a3 = NUM2DBL(rblapack_a3);
+
+ dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
+
+ rblapack_csu = rb_float_new((double)csu);
+ rblapack_snu = rb_float_new((double)snu);
+ rblapack_csv = rb_float_new((double)csv);
+ rblapack_snv = rb_float_new((double)snv);
+ rblapack_csq = rb_float_new((double)csq);
+ rblapack_snq = rb_float_new((double)snq);
+ return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
+}
+
+void
+init_lapack_dlags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlags2", rblapack_dlags2, -1);
+}
diff --git a/ext/dlagtf.c b/ext/dlagtf.c
new file mode 100644
index 0000000..c406343
--- /dev/null
+++ b/ext/dlagtf.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID dlagtf_(integer* n, doublereal* a, doublereal* lambda, doublereal* b, doublereal* c, doublereal* tol, doublereal* d, integer* in, integer* info);
+
+
+static VALUE
+rblapack_dlagtf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lambda;
+ doublereal lambda;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_in;
+ integer *in;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ 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 d, in, info, a, b, c = NumRu::Lapack.dlagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n* Purpose\n* =======\n*\n* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n* tridiagonal matrix and lambda is a scalar, as\n*\n* T - lambda*I = PLU,\n*\n* where P is a permutation matrix, L is a unit lower tridiagonal matrix\n* with at most one non-zero sub-diagonal elements per column and U is\n* an upper triangular matrix with at most two non-zero super-diagonal\n* elements per column.\n*\n* The factorization is obtained by Gaussian elimination with partial\n* pivoting and implicit row scaling.\n*\n* The parameter LAMBDA is included in the routine so that DLAGTF may\n* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by\n* inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, A must contain the diagonal elements of T.\n*\n* On exit, A is overwritten by the n diagonal elements of the\n* upper triangular matrix U of the factorization of T.\n*\n* LAMBDA (input) DOUBLE PRECISION\n* On entry, the scalar lambda.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, B must contain the (n-1) super-diagonal elements of\n* T.\n*\n* On exit, B is overwritten by the (n-1) super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* C (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, C must contain the (n-1) sub-diagonal elements of\n* T.\n*\n* On exit, C is overwritten by the (n-1) sub-diagonal elements\n* of the matrix L of the factorization of T.\n*\n* TOL (input) DOUBLE PRECISION\n* On entry, a relative tolerance used to indicate whether or\n* not the matrix (T - lambda*I) is nearly singular. TOL should\n* normally be chose as approximately the largest relative error\n* in the elements of T. For example, if the elements of T are\n* correct to about 4 significant figures, then TOL should be\n* set to about 5*10**(-4). If TOL is supplied as less than eps,\n* where eps is the relative machine precision, then the value\n* eps is used in place of TOL.\n*\n* D (output) DOUBLE PRECISION array, dimension (N-2)\n* On exit, D is overwritten by the (n-2) second super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* IN (output) INTEGER array, dimension (N)\n* On exit, IN contains details of the permutation matrix P. If\n* an interchange occurred at the kth step of the elimination,\n* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n* returns the smallest positive integer j such that\n*\n* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n*\n* where norm( A(j) ) denotes the sum of the absolute values of\n* the jth row of the matrix A. If no such j exists then IN(n)\n* is returned as zero. If IN(n) is returned as positive, then a\n* diagonal element of U is small, indicating that\n* (T - lambda*I) is singular or nearly singular,\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -k, the kth argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, in, info, a, b, c = NumRu::Lapack.dlagtf( a, lambda, b, c, tol, [: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_a = argv[0];
+ rblapack_lambda = argv[1];
+ rblapack_b = argv[2];
+ rblapack_c = argv[3];
+ rblapack_tol = argv[4];
+ if (argc == 5) {
+ } 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) != 1)
+ rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 1);
+ n = NA_SHAPE0(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*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 1)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_b) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ tol = NUM2DBL(rblapack_tol);
+ lambda = NUM2DBL(rblapack_lambda);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_in = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ in = NA_PTR_TYPE(rblapack_in, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+
+ dlagtf_(&n, a, &lambda, b, c, &tol, d, in, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_in, rblapack_info, rblapack_a, rblapack_b, rblapack_c);
+}
+
+void
+init_lapack_dlagtf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlagtf", rblapack_dlagtf, -1);
+}
diff --git a/ext/dlagtm.c b/ext/dlagtm.c
new file mode 100644
index 0000000..dd53906
--- /dev/null
+++ b/ext/dlagtm.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID dlagtm_(char* trans, integer* n, integer* nrhs, doublereal* alpha, doublereal* dl, doublereal* d, doublereal* du, doublereal* x, integer* ldx, doublereal* beta, doublereal* b, integer* ldb);
+
+
+static VALUE
+rblapack_dlagtm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldx;
+ integer nrhs;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.dlagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* DLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A'* X + beta * B\n* = 'C': 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 matrices X and B.\n*\n* ALPHA (input) DOUBLE PRECISION\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) DOUBLE PRECISION\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.dlagtm( trans, alpha, dl, d, du, x, beta, b, [: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_trans = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_x = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ beta = NUM2DBL(rblapack_beta);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dlagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_dlagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlagtm", rblapack_dlagtm, -1);
+}
diff --git a/ext/dlagts.c b/ext/dlagts.c
new file mode 100644
index 0000000..f4e6837
--- /dev/null
+++ b/ext/dlagts.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID dlagts_(integer* job, integer* n, doublereal* a, doublereal* b, doublereal* c, doublereal* d, integer* in, doublereal* y, doublereal* tol, integer* info);
+
+
+static VALUE
+rblapack_dlagts(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ integer job;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_in;
+ integer *in;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+
+ 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, y, tol = NumRu::Lapack.dlagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n* Purpose\n* =======\n*\n* DLAGTS may be used to solve one of the systems of equations\n*\n* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,\n*\n* where T is an n by n tridiagonal matrix, for x, following the\n* factorization of (T - lambda*I) as\n*\n* (T - lambda*I) = P*L*U ,\n*\n* by routine DLAGTF. The choice of equation to be solved is\n* controlled by the argument JOB, and in each case there is an option\n* to perturb zero or very small diagonal elements of U, this option\n* being intended for use in applications such as inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* Specifies the job to be performed by DLAGTS as follows:\n* = 1: The equations (T - lambda*I)x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -1: The equations (T - lambda*I)x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n* = 2: The equations (T - lambda*I)'x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -2: The equations (T - lambda*I)'x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input) DOUBLE PRECISION array, dimension (N)\n* On entry, A must contain the diagonal elements of U as\n* returned from DLAGTF.\n*\n* B (input) DOUBLE PRECISION array, dimension (N-1)\n* On entry, B must contain the first super-diagonal elements of\n* U as returned from DLAGTF.\n*\n* C (input) DOUBLE PRECISION array, dimension (N-1)\n* On entry, C must contain the sub-diagonal elements of L as\n* returned from DLAGTF.\n*\n* D (input) DOUBLE PRECISION array, dimension (N-2)\n* On entry, D must contain the second super-diagonal elements\n* of U as returned from DLAGTF.\n*\n* IN (input) INTEGER array, dimension (N)\n* On entry, IN must contain details of the matrix P as returned\n* from DLAGTF.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side vector y.\n* On exit, Y is overwritten by the solution vector x.\n*\n* TOL (input/output) DOUBLE PRECISION\n* On entry, with JOB .lt. 0, TOL should be the minimum\n* perturbation to be made to very small diagonal elements of U.\n* TOL should normally be chosen as about eps*norm(U), where eps\n* is the relative machine precision, but if TOL is supplied as\n* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n* If JOB .gt. 0 then TOL is not referenced.\n*\n* On exit, TOL is changed as described above, only if TOL is\n* non-positive on entry. Otherwise TOL is unchanged.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -i, the i-th argument had an illegal value\n* .gt. 0: overflow would occur when computing the INFO(th)\n* element of the solution vector x. This can only occur\n* when JOB is supplied as positive and either means\n* that a diagonal element of U is very small, or that\n* the elements of the right-hand side vector y are very\n* large.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, y, tol = NumRu::Lapack.dlagts( job, a, b, c, d, in, y, tol, [: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_job = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_c = argv[3];
+ rblapack_d = argv[4];
+ rblapack_in = argv[5];
+ rblapack_y = argv[6];
+ rblapack_tol = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = NUM2INT(rblapack_job);
+ if (!NA_IsNArray(rblapack_in))
+ rb_raise(rb_eArgError, "in (6th argument) must be NArray");
+ if (NA_RANK(rblapack_in) != 1)
+ rb_raise(rb_eArgError, "rank of in (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_in);
+ if (NA_TYPE(rblapack_in) != NA_LINT)
+ rblapack_in = na_change_type(rblapack_in, NA_LINT);
+ in = NA_PTR_TYPE(rblapack_in, integer*);
+ tol = NUM2DBL(rblapack_tol);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (2th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be the same as shape 0 of in");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of in");
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 1)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_b) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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);
+ if (NA_SHAPE0(rblapack_d) != (n-2))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", n-2);
+ 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_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dlagts_(&job, &n, a, b, c, d, in, y, &tol, &info);
+
+ rblapack_info = INT2NUM(info);
+ rblapack_tol = rb_float_new((double)tol);
+ return rb_ary_new3(3, rblapack_info, rblapack_y, rblapack_tol);
+}
+
+void
+init_lapack_dlagts(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlagts", rblapack_dlagts, -1);
+}
diff --git a/ext/dlagv2.c b/ext/dlagv2.c
new file mode 100644
index 0000000..ab0920a
--- /dev/null
+++ b/ext/dlagv2.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID dlagv2_(doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* csl, doublereal* snl, doublereal* csr, doublereal* snr);
+
+
+static VALUE
+rblapack_dlagv2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_csl;
+ doublereal csl;
+ VALUE rblapack_snl;
+ doublereal snl;
+ VALUE rblapack_csr;
+ doublereal csr;
+ VALUE rblapack_snr;
+ doublereal snr;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer ldb;
+
+ 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 alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.dlagv2( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n* Purpose\n* =======\n*\n* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n* matrix pencil (A,B) where B is upper triangular. This routine\n* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n* SNR such that\n*\n* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n* types), then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],\n*\n* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n* then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]\n*\n* where b11 >= b22 > 0.\n*\n*\n\n* Arguments\n* =========\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A.\n* On exit, A is overwritten by the ``A-part'' of the\n* generalized Schur form.\n*\n* LDA (input) INTEGER\n* THe leading dimension of the array A. LDA >= 2.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2)\n* On entry, the upper triangular 2 x 2 matrix B.\n* On exit, B is overwritten by the ``B-part'' of the\n* generalized Schur form.\n*\n* LDB (input) INTEGER\n* THe leading dimension of the array B. LDB >= 2.\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (2)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (2)\n* BETA (output) DOUBLE PRECISION array, dimension (2)\n* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may\n* be zero.\n*\n* CSL (output) DOUBLE PRECISION\n* The cosine of the left rotation matrix.\n*\n* SNL (output) DOUBLE PRECISION\n* The sine of the left rotation matrix.\n*\n* CSR (output) DOUBLE PRECISION\n* The cosine of the right rotation matrix.\n*\n* SNR (output) DOUBLE PRECISION\n* The sine of the right rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.dlagv2( 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);
+ if (NA_SHAPE1(rblapack_a) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = 2;
+ 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = 2;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dlagv2_(a, &lda, b, &ldb, alphar, alphai, beta, &csl, &snl, &csr, &snr);
+
+ rblapack_csl = rb_float_new((double)csl);
+ rblapack_snl = rb_float_new((double)snl);
+ rblapack_csr = rb_float_new((double)csr);
+ rblapack_snr = rb_float_new((double)snr);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_csl, rblapack_snl, rblapack_csr, rblapack_snr, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dlagv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlagv2", rblapack_dlagv2, -1);
+}
diff --git a/ext/dlahqr.c b/ext/dlahqr.c
new file mode 100644
index 0000000..065ff8e
--- /dev/null
+++ b/ext/dlahqr.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID dlahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_dlahqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer ldh;
+ 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 wr, wi, info, h, z = NumRu::Lapack.dlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* DLAHQR is an auxiliary routine called by DHSEQR to update the\n* eigenvalues and Schur decomposition already computed by DHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper quasi-triangular in\n* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n* ILO = 1). DLAHQR works primarily with the Hessenberg\n* submatrix in rows and columns ILO to IHI, but applies\n* transformations to all of H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n* quasi-triangular in rows and columns ILO:IHI, with any\n* 2-by-2 diagonal blocks in standard form. If INFO is zero\n* and WANTT is .FALSE., the contents of H are unspecified on\n* exit. The output state of H if INFO is nonzero is given\n* below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues ILO to IHI are stored in the corresponding\n* elements of WR and WI. If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with WR(i) = H(i,i), and, if\n* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by DHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: If INFO = i, DLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of WR and WI\n* contain those eigenvalues which have been\n* successfully computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix rows\n* and columns ILO thorugh INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of DLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, info, h, z = NumRu::Lapack.dlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_iloz = argv[5];
+ rblapack_ihiz = argv[6];
+ rblapack_z = argv[7];
+ rblapack_ldz = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = NUM2INT(rblapack_ldz);
+ wantz = (rblapack_wantz == Qtrue);
+ iloz = NUM2INT(rblapack_iloz);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? n : 0;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dlahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_wr, rblapack_wi, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_dlahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlahqr", rblapack_dlahqr, -1);
+}
diff --git a/ext/dlahr2.c b/ext/dlahr2.c
new file mode 100644
index 0000000..2a4b9ad
--- /dev/null
+++ b/ext/dlahr2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID dlahr2_(integer* n, integer* k, integer* nb, doublereal* a, integer* lda, doublereal* tau, doublereal* t, integer* ldt, doublereal* y, integer* ldy);
+
+
+static VALUE
+rblapack_dlahr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.dlahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by DGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.dlahr2( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ ldy = n;
+ k = NUM2INT(rblapack_k);
+ ldt = nb;
+ 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-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ 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__;
+
+ dlahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_dlahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlahr2", rblapack_dlahr2, -1);
+}
diff --git a/ext/dlahrd.c b/ext/dlahrd.c
new file mode 100644
index 0000000..329ac66
--- /dev/null
+++ b/ext/dlahrd.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID dlahrd_(integer* n, integer* k, integer* nb, doublereal* a, integer* lda, doublereal* tau, doublereal* t, integer* ldt, doublereal* y, integer* ldy);
+
+
+static VALUE
+rblapack_dlahrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.dlahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine DLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.dlahrd( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ ldy = n;
+ k = NUM2INT(rblapack_k);
+ ldt = nb;
+ 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-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ 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__;
+
+ dlahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_dlahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlahrd", rblapack_dlahrd, -1);
+}
diff --git a/ext/dlaic1.c b/ext/dlaic1.c
new file mode 100644
index 0000000..4b24e82
--- /dev/null
+++ b/ext/dlaic1.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID dlaic1_(integer* job, integer* j, doublereal* x, doublereal* sest, doublereal* w, doublereal* gamma, doublereal* sestpr, doublereal* s, doublereal* c);
+
+
+static VALUE
+rblapack_dlaic1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ integer job;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_sest;
+ doublereal sest;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_gamma;
+ doublereal gamma;
+ VALUE rblapack_sestpr;
+ doublereal sestpr;
+ VALUE rblapack_s;
+ doublereal s;
+ VALUE rblapack_c;
+ doublereal c;
+
+ integer j;
+
+ 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 sestpr, s, c = NumRu::Lapack.dlaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* DLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then DLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]\n* [ gamma ]\n*\n* where alpha = x'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) DOUBLE PRECISION array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) DOUBLE PRECISION\n* Estimated singular value of j by j matrix L\n*\n* W (input) DOUBLE PRECISION array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) DOUBLE PRECISION\n* The diagonal element gamma.\n*\n* SESTPR (output) DOUBLE PRECISION\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) DOUBLE PRECISION\n* Sine needed in forming xhat.\n*\n* C (output) DOUBLE PRECISION\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.dlaic1( job, x, sest, w, gamma, [: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_job = argv[0];
+ rblapack_x = argv[1];
+ rblapack_sest = argv[2];
+ rblapack_w = argv[3];
+ rblapack_gamma = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = NUM2INT(rblapack_job);
+ sest = NUM2DBL(rblapack_sest);
+ gamma = NUM2DBL(rblapack_gamma);
+ 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);
+ j = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (4th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != j)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+
+ dlaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
+
+ rblapack_sestpr = rb_float_new((double)sestpr);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_c = rb_float_new((double)c);
+ return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
+}
+
+void
+init_lapack_dlaic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaic1", rblapack_dlaic1, -1);
+}
diff --git a/ext/dlaln2.c b/ext/dlaln2.c
new file mode 100644
index 0000000..bd2d445
--- /dev/null
+++ b/ext/dlaln2.c
@@ -0,0 +1,120 @@
+#include "rb_lapack.h"
+
+extern VOID dlaln2_(logical* ltrans, integer* na, integer* nw, doublereal* smin, doublereal* ca, doublereal* a, integer* lda, doublereal* d1, doublereal* d2, doublereal* b, integer* ldb, doublereal* wr, doublereal* wi, doublereal* x, integer* ldx, doublereal* scale, doublereal* xnorm, integer* info);
+
+
+static VALUE
+rblapack_dlaln2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ltrans;
+ logical ltrans;
+ VALUE rblapack_smin;
+ doublereal smin;
+ VALUE rblapack_ca;
+ doublereal ca;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_d1;
+ doublereal d1;
+ VALUE rblapack_d2;
+ doublereal d2;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_wr;
+ doublereal wr;
+ VALUE rblapack_wi;
+ doublereal wi;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_xnorm;
+ doublereal xnorm;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer na;
+ integer ldb;
+ integer nw;
+ 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 x, scale, xnorm, info = NumRu::Lapack.dlaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLALN2 solves a system of the form (ca A - w D ) X = s B\n* or (ca A' - w D) X = s B with possible scaling (\"s\") and\n* perturbation of A. (A' means A-transpose.)\n*\n* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n* real diagonal matrix, w is a real or complex value, and X and B are\n* NA x 1 matrices -- real if w is real, complex if w is complex. NA\n* may be 1 or 2.\n*\n* If w is complex, X and B are represented as NA x 2 matrices,\n* the first column of each being the real part and the second\n* being the imaginary part.\n*\n* \"s\" is a scaling factor (.LE. 1), computed by DLALN2, which is\n* so chosen that X can be computed without overflow. X is further\n* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n* than overflow.\n*\n* If both singular values of (ca A - w D) are less than SMIN,\n* SMIN*identity will be used instead of (ca A - w D). If only one\n* singular value is less than SMIN, one element of (ca A - w D) will be\n* perturbed enough to make the smallest singular value roughly SMIN.\n* If both singular values are at least SMIN, (ca A - w D) will not be\n* perturbed. In any case, the perturbation will be at most some small\n* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values\n* are computed by infinity-norm approximations, and thus will only be\n* correct to a factor of 2 or so.\n*\n* Note: all input quantities are assumed to be smaller than overflow\n* by a reasonable factor. (See BIGNUM.)\n*\n\n* Arguments\n* ==========\n*\n* LTRANS (input) LOGICAL\n* =.TRUE.: A-transpose will be used.\n* =.FALSE.: A will be used (not transposed.)\n*\n* NA (input) INTEGER\n* The size of the matrix A. It may (only) be 1 or 2.\n*\n* NW (input) INTEGER\n* 1 if \"w\" is real, 2 if \"w\" is complex. It may only be 1\n* or 2.\n*\n* SMIN (input) DOUBLE PRECISION\n* The desired lower bound on the singular values of A. This\n* should be a safe distance away from underflow or overflow,\n* say, between (underflow/machine precision) and (machine\n* precision * overflow ). (See BIGNUM and ULP.)\n*\n* CA (input) DOUBLE PRECISION\n* The coefficient c, which A is multiplied by.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,NA)\n* The NA x NA matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. It must be at least NA.\n*\n* D1 (input) DOUBLE PRECISION\n* The 1,1 element in the diagonal matrix D.\n*\n* D2 (input) DOUBLE PRECISION\n* The 2,2 element in the diagonal matrix D. Not used if NW=1.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NW)\n* The NA x NW matrix B (right-hand side). If NW=2 (\"w\" is\n* complex), column 1 contains the real part of B and column 2\n* contains the imaginary part.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. It must be at least NA.\n*\n* WR (input) DOUBLE PRECISION\n* The real part of the scalar \"w\".\n*\n* WI (input) DOUBLE PRECISION\n* The imaginary part of the scalar \"w\". Not used if NW=1.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NW)\n* The NA x NW matrix X (unknowns), as computed by DLALN2.\n* If NW=2 (\"w\" is complex), on exit, column 1 will contain\n* the real part of X and column 2 will contain the imaginary\n* part.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. It must be at least NA.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scale factor that B must be multiplied by to insure\n* that overflow does not occur when computing X. Thus,\n* (ca A - w D) X will be SCALE*B, not B (ignoring\n* perturbations of A.) It will be at most 1.\n*\n* XNORM (output) DOUBLE PRECISION\n* The infinity-norm of X, when X is regarded as an NA x NW\n* real matrix.\n*\n* INFO (output) INTEGER\n* An error flag. It will be set to zero if no error occurs,\n* a negative number if an argument is in error, or a positive\n* number if ca A - w D had to be perturbed.\n* The possible values are:\n* = 0: No error occurred, and (ca A - w D) did not have to be\n* perturbed.\n* = 1: (ca A - w D) had to be perturbed to make its smallest\n* (or only) singular value greater than SMIN.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, scale, xnorm, info = NumRu::Lapack.dlaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_ltrans = argv[0];
+ rblapack_smin = argv[1];
+ rblapack_ca = argv[2];
+ rblapack_a = argv[3];
+ rblapack_d1 = argv[4];
+ rblapack_d2 = argv[5];
+ rblapack_b = argv[6];
+ rblapack_wr = argv[7];
+ rblapack_wi = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ltrans = (rblapack_ltrans == Qtrue);
+ ca = NUM2DBL(rblapack_ca);
+ d1 = NUM2DBL(rblapack_d1);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nw = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ wi = NUM2DBL(rblapack_wi);
+ smin = NUM2DBL(rblapack_smin);
+ d2 = NUM2DBL(rblapack_d2);
+ 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);
+ na = 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*);
+ ldx = na;
+ wr = NUM2DBL(rblapack_wr);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nw;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+
+ dlaln2_(<rans, &na, &nw, &smin, &ca, a, &lda, &d1, &d2, b, &ldb, &wr, &wi, x, &ldx, &scale, &xnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_xnorm = rb_float_new((double)xnorm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_x, rblapack_scale, rblapack_xnorm, rblapack_info);
+}
+
+void
+init_lapack_dlaln2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaln2", rblapack_dlaln2, -1);
+}
diff --git a/ext/dlals0.c b/ext/dlals0.c
new file mode 100644
index 0000000..8fd2458
--- /dev/null
+++ b/ext/dlals0.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID dlals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, doublereal* b, integer* ldb, doublereal* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* poles, doublereal* difl, doublereal* difr, doublereal* z, integer* k, doublereal* c, doublereal* s, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlals0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_poles;
+ doublereal *poles;
+ VALUE rblapack_difl;
+ doublereal *difl;
+ VALUE rblapack_difr;
+ doublereal *difr;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_s;
+ doublereal s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ doublereal *bx;
+ doublereal *work;
+
+ integer ldb;
+ integer nrhs;
+ integer n;
+ integer ldgcol;
+ integer ldgnum;
+ integer k;
+ integer ldbx;
+
+ 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, b = NumRu::Lapack.dlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( K )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_b = argv[4];
+ rblapack_perm = argv[5];
+ rblapack_givptr = argv[6];
+ rblapack_givcol = argv[7];
+ rblapack_givnum = argv[8];
+ rblapack_poles = argv[9];
+ rblapack_difl = argv[10];
+ rblapack_difr = argv[11];
+ rblapack_z = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ givptr = NUM2INT(rblapack_givptr);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
+ ldgnum = NA_SHAPE0(rblapack_givnum);
+ if (NA_SHAPE1(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
+ if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 1)
+ rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_difl);
+ if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (13th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ s = NUM2DBL(rblapack_s);
+ nl = NUM2INT(rblapack_nl);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_perm);
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_poles) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
+ if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
+ c = NUM2DBL(rblapack_c);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_difr) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
+ if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_givcol);
+ if (NA_SHAPE1(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ ldbx = n;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ bx = ALLOC_N(doublereal, (ldbx)*(nrhs));
+ work = ALLOC_N(doublereal, (k));
+
+ dlals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, &info);
+
+ free(bx);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dlals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlals0", rblapack_dlals0, -1);
+}
diff --git a/ext/dlalsa.c b/ext/dlalsa.c
new file mode 100644
index 0000000..a282af9
--- /dev/null
+++ b/ext/dlalsa.c
@@ -0,0 +1,270 @@
+#include "rb_lapack.h"
+
+extern VOID dlalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, doublereal* b, integer* ldb, doublereal* bx, integer* ldbx, doublereal* u, integer* ldu, doublereal* vt, integer* k, doublereal* difl, doublereal* difr, doublereal* z, doublereal* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, doublereal* givnum, doublereal* c, doublereal* s, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlalsa(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_difl;
+ doublereal *difl;
+ VALUE rblapack_difr;
+ doublereal *difr;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_poles;
+ doublereal *poles;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_bx;
+ doublereal *bx;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldb;
+ integer nrhs;
+ integer ldu;
+ integer smlsiz;
+ integer n;
+ integer nlvl;
+ integer ldgcol;
+ integer ldbx;
+
+ 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 bx, info, b = NumRu::Lapack.dlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by DLALSA.\n*\n\n* Arguments\n* =========\n*\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) DOUBLE PRECISION array.\n* The dimension must be at least N.\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.dlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_b = argv[1];
+ rblapack_u = argv[2];
+ rblapack_vt = argv[3];
+ rblapack_k = argv[4];
+ rblapack_difl = argv[5];
+ rblapack_difr = argv[6];
+ rblapack_z = argv[7];
+ rblapack_poles = argv[8];
+ rblapack_givptr = argv[9];
+ rblapack_givcol = argv[10];
+ rblapack_perm = argv[11];
+ rblapack_givnum = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (3th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ smlsiz = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (5th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (14th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (15th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_vt) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
+ if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 2)
+ rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_perm);
+ if (NA_SHAPE1(rblapack_perm) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ ldbx = n;
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 2)
+ rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difl) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difl) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != ldgcol)
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
+ if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_z) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldbx;
+ shape[1] = nrhs;
+ rblapack_bx = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ bx = NA_PTR_TYPE(rblapack_bx, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, (n));
+ iwork = ALLOC_N(integer, (3 * n));
+
+ dlalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dlalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlalsa", rblapack_dlalsa, -1);
+}
diff --git a/ext/dlalsd.c b/ext/dlalsd.c
new file mode 100644
index 0000000..5a7e6f2
--- /dev/null
+++ b/ext/dlalsd.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern VOID dlalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb, doublereal* rcond, integer* rank, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlalsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer nlvl;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 rank, info, d, e, b = NumRu::Lapack.dlalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) DOUBLE PRECISION\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n*\n* IWORK (workspace) INTEGER array, dimension at least\n* (3*N*NLVL + 11*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.dlalsd( uplo, smlsiz, d, e, b, rcond, [: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_smlsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_b = argv[4];
+ rblapack_rcond = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ rcond = NUM2DBL(rblapack_rcond);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ nlvl = MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, (9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2)));
+ iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
+
+ dlalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_dlalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlalsd", rblapack_dlalsd, -1);
+}
diff --git a/ext/dlamrg.c b/ext/dlamrg.c
new file mode 100644
index 0000000..55ccd71
--- /dev/null
+++ b/ext/dlamrg.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID dlamrg_(integer* n1, integer* n2, doublereal* a, integer* dtrd1, integer* dtrd2, integer* index);
+
+
+static VALUE
+rblapack_dlamrg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_dtrd1;
+ integer dtrd1;
+ VALUE rblapack_dtrd2;
+ integer dtrd2;
+ VALUE rblapack_index;
+ integer *index;
+
+
+ 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 index = NumRu::Lapack.dlamrg( n1, n2, a, dtrd1, dtrd2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )\n\n* Purpose\n* =======\n*\n* DLAMRG will create a permutation list which will merge the elements\n* of A (which is composed of two independently sorted sets) into a\n* single set which is sorted in ascending order.\n*\n\n* Arguments\n* =========\n*\n* N1 (input) INTEGER\n* N2 (input) INTEGER\n* These arguements contain the respective lengths of the two\n* sorted lists to be merged.\n*\n* A (input) DOUBLE PRECISION array, dimension (N1+N2)\n* The first N1 elements of A contain a list of numbers which\n* are sorted in either ascending or descending order. Likewise\n* for the final N2 elements.\n*\n* DTRD1 (input) INTEGER\n* DTRD2 (input) INTEGER\n* These are the strides to be taken through the array A.\n* Allowable strides are 1 and -1. They indicate whether a\n* subset of A is sorted in ascending (DTRDx = 1) or descending\n* (DTRDx = -1) order.\n*\n* INDEX (output) INTEGER array, dimension (N1+N2)\n* On exit this array will contain a permutation such that\n* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n* sorted in ascending order.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IND1, IND2, N1SV, N2SV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n index = NumRu::Lapack.dlamrg( n1, n2, a, dtrd1, dtrd2, [: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_n1 = argv[0];
+ rblapack_n2 = argv[1];
+ rblapack_a = argv[2];
+ rblapack_dtrd1 = argv[3];
+ rblapack_dtrd2 = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n1 = NUM2INT(rblapack_n1);
+ dtrd1 = NUM2INT(rblapack_dtrd1);
+ n2 = NUM2INT(rblapack_n2);
+ dtrd2 = NUM2INT(rblapack_dtrd2);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (3th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n1+n2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n1+n2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n1+n2;
+ rblapack_index = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ index = NA_PTR_TYPE(rblapack_index, integer*);
+
+ dlamrg_(&n1, &n2, a, &dtrd1, &dtrd2, index);
+
+ return rblapack_index;
+}
+
+void
+init_lapack_dlamrg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlamrg", rblapack_dlamrg, -1);
+}
diff --git a/ext/dlaneg.c b/ext/dlaneg.c
new file mode 100644
index 0000000..d4abc26
--- /dev/null
+++ b/ext/dlaneg.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern integer dlaneg_(integer* n, doublereal* d, doublereal* lld, doublereal* sigma, doublereal* pivmin, integer* r);
+
+
+static VALUE
+rblapack_dlaneg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_lld;
+ doublereal *lld;
+ VALUE rblapack_sigma;
+ doublereal sigma;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_r;
+ integer r;
+ VALUE rblapack___out__;
+ integer __out__;
+
+ 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 __out__ = NumRu::Lapack.dlaneg( d, lld, sigma, pivmin, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n* Purpose\n* =======\n*\n* DLANEG computes the Sturm count, the number of negative pivots\n* encountered while factoring tridiagonal T - sigma I = L D L^T.\n* This implementation works directly on the factors without forming\n* the tridiagonal matrix T. The Sturm count is also the number of\n* eigenvalues of T less than sigma.\n*\n* This routine is called from DLARRB.\n*\n* The current routine does not use the PIVMIN parameter but rather\n* requires IEEE-754 propagation of Infinities and NaNs. This\n* routine also has no input range restrictions but does require\n* default exception handling such that x/0 produces Inf when x is\n* non-zero, and Inf/Inf produces NaN. For more information, see:\n*\n* Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n* Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624\n* (Tech report version in LAWN 172 with the same title.)\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* SIGMA (input) DOUBLE PRECISION\n* Shift amount in T - sigma I = L D L^T.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence. May be used\n* when zero pivots are encountered on non-IEEE-754\n* architectures.\n*\n* R (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, University of California, Berkeley, USA\n* Jason Riedy, 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 __out__ = NumRu::Lapack.dlaneg( d, lld, sigma, pivmin, r, [: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_d = argv[0];
+ rblapack_lld = argv[1];
+ rblapack_sigma = argv[2];
+ rblapack_pivmin = argv[3];
+ rblapack_r = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ sigma = NUM2DBL(rblapack_sigma);
+ r = NUM2INT(rblapack_r);
+ if (!NA_IsNArray(rblapack_lld))
+ rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
+ if (NA_RANK(rblapack_lld) != 1)
+ rb_raise(rb_eArgError, "rank of lld (2th 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*);
+ pivmin = NUM2DBL(rblapack_pivmin);
+
+ __out__ = dlaneg_(&n, d, lld, &sigma, &pivmin, &r);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlaneg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaneg", rblapack_dlaneg, -1);
+}
diff --git a/ext/dlangb.c b/ext/dlangb.c
new file mode 100644
index 0000000..a428e30
--- /dev/null
+++ b/ext/dlangb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern doublereal dlangb_(char* norm, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* work);
+
+
+static VALUE
+rblapack_dlangb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* DLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* DLANGB returns the value\n*\n* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlangb( norm, kl, ku, ab, [: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_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlangb", rblapack_dlangb, -1);
+}
diff --git a/ext/dlange.c b/ext/dlange.c
new file mode 100644
index 0000000..993eddc
--- /dev/null
+++ b/ext/dlange.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern doublereal dlange_(char* norm, integer* m, integer* n, doublereal* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_dlange(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real matrix A.\n*\n* Description\n* ===========\n*\n* DLANGE returns the value\n*\n* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* DLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* DLANGE is set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlange( norm, m, a, [: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_norm = argv[0];
+ rblapack_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ 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*);
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlange_(&norm, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlange", rblapack_dlange, -1);
+}
diff --git a/ext/dlangt.c b/ext/dlangt.c
new file mode 100644
index 0000000..cd92e91
--- /dev/null
+++ b/ext/dlangt.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern doublereal dlangt_(char* norm, integer* n, doublereal* dl, doublereal* d, doublereal* du);
+
+
+static VALUE
+rblapack_dlangt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_dl;
+ doublereal *dl;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_du;
+ doublereal *du;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ 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 __out__ = NumRu::Lapack.dlangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* DLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* DLANGT returns the value\n*\n* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANGT is\n* set to zero.\n*\n* DL (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) sub-diagonal elements of A.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlangt( norm, dl, d, du, [: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_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ if (argc == 4) {
+ } 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ 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_DFLOAT)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
+ dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
+ 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_DFLOAT)
+ rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
+ du = NA_PTR_TYPE(rblapack_du, doublereal*);
+
+ __out__ = dlangt_(&norm, &n, dl, d, du);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlangt", rblapack_dlangt, -1);
+}
diff --git a/ext/dlanhs.c b/ext/dlanhs.c
new file mode 100644
index 0000000..55f6674
--- /dev/null
+++ b/ext/dlanhs.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern doublereal dlanhs_(char* norm, integer* n, doublereal* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_dlanhs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* DLANHS returns the value\n*\n* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANHS is\n* set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlanhs( norm, 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_norm = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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*);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlanhs_(&norm, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlanhs", rblapack_dlanhs, -1);
+}
diff --git a/ext/dlansb.c b/ext/dlansb.c
new file mode 100644
index 0000000..21d9fd8
--- /dev/null
+++ b/ext/dlansb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern doublereal dlansb_(char* norm, char* uplo, integer* n, integer* k, doublereal* ab, integer* ldab, doublereal* work);
+
+
+static VALUE
+rblapack_dlansb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* DLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* DLANSB returns the value\n*\n* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansb( norm, uplo, k, ab, [: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_k = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ k = NUM2INT(rblapack_k);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlansb", rblapack_dlansb, -1);
+}
diff --git a/ext/dlansf.c b/ext/dlansf.c
new file mode 100644
index 0000000..07a472e
--- /dev/null
+++ b/ext/dlansf.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern doublereal dlansf_(char* norm, char* transr, char* uplo, integer* n, doublereal* a, doublereal* work);
+
+
+static VALUE
+rblapack_dlansf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlansf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* DLANSF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* DLANSF returns the value\n*\n* DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSF as described\n* above.\n*\n* TRANSR (input) CHARACTER*1\n* Specifies whether the RFP format of A is normal or\n* transposed format.\n* = 'N': RFP format is Normal;\n* = 'T': RFP format is Transpose.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* = 'U': RFP A came from an upper triangular matrix;\n* = 'L': RFP A came from a lower triangular matrix.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSF is\n* set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* part of the symmetric matrix A stored in RFP format. See the\n* \"Notes\" below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansf( norm, transr, uplo, n, a, [: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_norm = argv[0];
+ rblapack_transr = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlansf_(&norm, &transr, &uplo, &n, a, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlansf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlansf", rblapack_dlansf, -1);
+}
diff --git a/ext/dlansp.c b/ext/dlansp.c
new file mode 100644
index 0000000..e539d33
--- /dev/null
+++ b/ext/dlansp.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern doublereal dlansp_(char* norm, char* uplo, integer* n, doublereal* ap, doublereal* work);
+
+
+static VALUE
+rblapack_dlansp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* DLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* DLANSP returns the value\n*\n* DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSP is\n* set to zero.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansp( norm, uplo, 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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlansp_(&norm, &uplo, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlansp", rblapack_dlansp, -1);
+}
diff --git a/ext/dlanst.c b/ext/dlanst.c
new file mode 100644
index 0000000..c628a04
--- /dev/null
+++ b/ext/dlanst.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern doublereal dlanst_(char* norm, integer* n, doublereal* d, doublereal* e);
+
+
+static VALUE
+rblapack_dlanst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ 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 __out__ = NumRu::Lapack.dlanst( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* DLANST returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* DLANST returns the value\n*\n* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANST as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANST is\n* set to zero.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlanst( norm, d, e, [: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_norm = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+
+ __out__ = dlanst_(&norm, &n, d, e);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlanst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlanst", rblapack_dlanst, -1);
+}
diff --git a/ext/dlansy.c b/ext/dlansy.c
new file mode 100644
index 0000000..fdabc9b
--- /dev/null
+++ b/ext/dlansy.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern doublereal dlansy_(char* norm, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_dlansy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A.\n*\n* Description\n* ===========\n*\n* DLANSY returns the value\n*\n* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANSY is\n* set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlansy( norm, uplo, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlansy_(&norm, &uplo, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlansy", rblapack_dlansy, -1);
+}
diff --git a/ext/dlantb.c b/ext/dlantb.c
new file mode 100644
index 0000000..3fd9d8b
--- /dev/null
+++ b/ext/dlantb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern doublereal dlantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, doublereal* ab, integer* ldab, doublereal* work);
+
+
+static VALUE
+rblapack_dlantb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* DLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* DLANTB returns the value\n*\n* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlantb( norm, uplo, diag, k, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_k = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = lsame_(&norm,"I") ? n : 0;
+ k = NUM2INT(rblapack_k);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlantb", rblapack_dlantb, -1);
+}
diff --git a/ext/dlantp.c b/ext/dlantp.c
new file mode 100644
index 0000000..373d07f
--- /dev/null
+++ b/ext/dlantp.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern doublereal dlantp_(char* norm, char* uplo, char* diag, integer* n, doublereal* ap, doublereal* work);
+
+
+static VALUE
+rblapack_dlantp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* DLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* DLANTP returns the value\n*\n* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, DLANTP is\n* set to zero.\n*\n* AP (input) DOUBLE PRECISION 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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlantp( norm, uplo, diag, n, ap, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_ap = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ 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) != (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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlantp_(&norm, &uplo, &diag, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlantp", rblapack_dlantp, -1);
+}
diff --git a/ext/dlantr.c b/ext/dlantr.c
new file mode 100644
index 0000000..fa99235
--- /dev/null
+++ b/ext/dlantr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern doublereal dlantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, doublereal* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_dlantr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.dlantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* DLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* DLANTR returns the value\n*\n* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in DLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlantr( norm, uplo, diag, m, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_m = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = dlantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlantr", rblapack_dlantr, -1);
+}
diff --git a/ext/dlanv2.c b/ext/dlanv2.c
new file mode 100644
index 0000000..0838ee8
--- /dev/null
+++ b/ext/dlanv2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dlanv2_(doublereal* a, doublereal* b, doublereal* c, doublereal* d, doublereal* rt1r, doublereal* rt1i, doublereal* rt2r, doublereal* rt2i, doublereal* cs, doublereal* sn);
+
+
+static VALUE
+rblapack_dlanv2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal a;
+ VALUE rblapack_b;
+ doublereal b;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_d;
+ doublereal d;
+ VALUE rblapack_rt1r;
+ doublereal rt1r;
+ VALUE rblapack_rt1i;
+ doublereal rt1i;
+ VALUE rblapack_rt2r;
+ doublereal rt2r;
+ VALUE rblapack_rt2i;
+ doublereal rt2i;
+ VALUE rblapack_cs;
+ doublereal cs;
+ VALUE rblapack_sn;
+ doublereal sn;
+
+
+ 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 rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.dlanv2( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n* Purpose\n* =======\n*\n* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n* matrix in standard form:\n*\n* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]\n* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]\n*\n* where either\n* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n* conjugate eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* A (input/output) DOUBLE PRECISION\n* B (input/output) DOUBLE PRECISION\n* C (input/output) DOUBLE PRECISION\n* D (input/output) DOUBLE PRECISION\n* On entry, the elements of the input matrix.\n* On exit, they are overwritten by the elements of the\n* standardised Schur form.\n*\n* RT1R (output) DOUBLE PRECISION\n* RT1I (output) DOUBLE PRECISION\n* RT2R (output) DOUBLE PRECISION\n* RT2I (output) DOUBLE PRECISION\n* The real and imaginary parts of the eigenvalues. If the\n* eigenvalues are a complex conjugate pair, RT1I > 0.\n*\n* CS (output) DOUBLE PRECISION\n* SN (output) DOUBLE PRECISION\n* Parameters of the rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Modified by V. Sima, Research Institute for Informatics, Bucharest,\n* Romania, to reduce the risk of cancellation errors,\n* when computing real eigenvalues, and to ensure, if possible, that\n* abs(RT1R) >= abs(RT2R).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.dlanv2( a, b, c, d, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = NUM2DBL(rblapack_a);
+ c = NUM2DBL(rblapack_c);
+ b = NUM2DBL(rblapack_b);
+ d = NUM2DBL(rblapack_d);
+
+ dlanv2_(&a, &b, &c, &d, &rt1r, &rt1i, &rt2r, &rt2i, &cs, &sn);
+
+ rblapack_rt1r = rb_float_new((double)rt1r);
+ rblapack_rt1i = rb_float_new((double)rt1i);
+ rblapack_rt2r = rb_float_new((double)rt2r);
+ rblapack_rt2i = rb_float_new((double)rt2i);
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ rblapack_a = rb_float_new((double)a);
+ rblapack_b = rb_float_new((double)b);
+ rblapack_c = rb_float_new((double)c);
+ rblapack_d = rb_float_new((double)d);
+ return rb_ary_new3(10, rblapack_rt1r, rblapack_rt1i, rblapack_rt2r, rblapack_rt2i, rblapack_cs, rblapack_sn, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
+}
+
+void
+init_lapack_dlanv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlanv2", rblapack_dlanv2, -1);
+}
diff --git a/ext/dlapll.c b/ext/dlapll.c
new file mode 100644
index 0000000..67b667a
--- /dev/null
+++ b/ext/dlapll.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID dlapll_(integer* n, doublereal* x, integer* incx, doublereal* y, integer* incy, doublereal* ssmin);
+
+
+static VALUE
+rblapack_dlapll(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_ssmin;
+ doublereal ssmin;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 ssmin, x, y = NumRu::Lapack.dlapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) DOUBLE PRECISION\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.dlapll( n, x, incx, y, incy, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dlapll_(&n, x, &incx, y, &incy, &ssmin);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_dlapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlapll", rblapack_dlapll, -1);
+}
diff --git a/ext/dlapmr.c b/ext/dlapmr.c
new file mode 100644
index 0000000..5fdc2f1
--- /dev/null
+++ b/ext/dlapmr.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dlapmr_(logical* forwrd, integer* m, integer* n, doublereal* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_dlapmr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ integer ldx;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.dlapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* DLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n DOUBLE PRECISION TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.dlapmr( forwrd, x, k, [: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_forwrd = argv[0];
+ rblapack_x = argv[1];
+ rblapack_k = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (3th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ dlapmr_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_dlapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlapmr", rblapack_dlapmr, -1);
+}
diff --git a/ext/dlapmt.c b/ext/dlapmt.c
new file mode 100644
index 0000000..3f7e2f7
--- /dev/null
+++ b/ext/dlapmt.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dlapmt_(logical* forwrd, integer* m, integer* n, doublereal* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_dlapmt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ 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 x, k = NumRu::Lapack.dlapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* DLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, IN, J\n DOUBLE PRECISION TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.dlapmt( forwrd, m, x, k, [: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_forwrd = argv[0];
+ rblapack_m = argv[1];
+ rblapack_x = argv[2];
+ rblapack_k = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (4th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_k) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ dlapmt_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_dlapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlapmt", rblapack_dlapmt, -1);
+}
diff --git a/ext/dlapy2.c b/ext/dlapy2.c
new file mode 100644
index 0000000..3af8bf8
--- /dev/null
+++ b/ext/dlapy2.c
@@ -0,0 +1,55 @@
+#include "rb_lapack.h"
+
+extern doublereal dlapy2_(doublereal* x, doublereal* y);
+
+
+static VALUE
+rblapack_dlapy2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublereal x;
+ VALUE rblapack_y;
+ doublereal y;
+ VALUE rblapack___out__;
+ doublereal __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 __out__ = NumRu::Lapack.dlapy2( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLAPY2( X, Y )\n\n* Purpose\n* =======\n*\n* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n* overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) DOUBLE PRECISION\n* Y (input) DOUBLE PRECISION\n* X and Y specify the values x and y.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlapy2( x, y, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x = NUM2DBL(rblapack_x);
+ y = NUM2DBL(rblapack_y);
+
+ __out__ = dlapy2_(&x, &y);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlapy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlapy2", rblapack_dlapy2, -1);
+}
diff --git a/ext/dlapy3.c b/ext/dlapy3.c
new file mode 100644
index 0000000..82c2ca8
--- /dev/null
+++ b/ext/dlapy3.c
@@ -0,0 +1,59 @@
+#include "rb_lapack.h"
+
+extern doublereal dlapy3_(doublereal* x, doublereal* y, doublereal* z);
+
+
+static VALUE
+rblapack_dlapy3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublereal x;
+ VALUE rblapack_y;
+ doublereal y;
+ VALUE rblapack_z;
+ doublereal z;
+ VALUE rblapack___out__;
+ doublereal __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 __out__ = NumRu::Lapack.dlapy3( x, y, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )\n\n* Purpose\n* =======\n*\n* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n* unnecessary overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) DOUBLE PRECISION\n* Y (input) DOUBLE PRECISION\n* Z (input) DOUBLE PRECISION\n* X, Y and Z specify the values x, y and z.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dlapy3( x, y, z, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_z = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x = NUM2DBL(rblapack_x);
+ z = NUM2DBL(rblapack_z);
+ y = NUM2DBL(rblapack_y);
+
+ __out__ = dlapy3_(&x, &y, &z);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dlapy3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlapy3", rblapack_dlapy3, -1);
+}
diff --git a/ext/dlaqgb.c b/ext/dlaqgb.c
new file mode 100644
index 0000000..b4bd1fd
--- /dev/null
+++ b/ext/dlaqgb.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqgb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_dlaqgb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.dlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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, ab = NumRu::Lapack.dlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_r = argv[3];
+ rblapack_c = argv[4];
+ rblapack_rowcnd = argv[5];
+ rblapack_colcnd = argv[6];
+ rblapack_amax = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ colcnd = NUM2DBL(rblapack_colcnd);
+ ku = NUM2INT(rblapack_ku);
+ rowcnd = NUM2DBL(rblapack_rowcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (4th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ amax = NUM2DBL(rblapack_amax);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dlaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_dlaqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqgb", rblapack_dlaqgb, -1);
+}
diff --git a/ext/dlaqge.c b/ext/dlaqge.c
new file mode 100644
index 0000000..ce16394
--- /dev/null
+++ b/ext/dlaqge.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqge_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_dlaqge(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.dlaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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.dlaqge( a, r, c, rowcnd, colcnd, amax, [: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_a = argv[0];
+ rblapack_r = argv[1];
+ rblapack_c = argv[2];
+ rblapack_rowcnd = argv[3];
+ rblapack_colcnd = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ colcnd = NUM2DBL(rblapack_colcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (2th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ amax = NUM2DBL(rblapack_amax);
+ rowcnd = NUM2DBL(rblapack_rowcnd);
+ {
+ int 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__;
+
+ dlaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_a);
+}
+
+void
+init_lapack_dlaqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqge", rblapack_dlaqge, -1);
+}
diff --git a/ext/dlaqp2.c b/ext/dlaqp2.c
new file mode 100644
index 0000000..0785e8c
--- /dev/null
+++ b/ext/dlaqp2.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqp2_(integer* m, integer* n, integer* offset, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* vn1, doublereal* vn2, doublereal* work);
+
+
+static VALUE
+rblapack_dlaqp2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ doublereal *vn1;
+ VALUE rblapack_vn2;
+ doublereal *vn2;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ doublereal *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ doublereal *vn2_out__;
+ doublereal *work;
+
+ 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 tau, a, jpvt, vn1, vn2 = NumRu::Lapack.dlaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* DLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n* the triangular factor obtained; the elements in block\n* A(OFFSET+1:M,1:N) below the diagonal, together with the\n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.dlaqp2( m, offset, a, jpvt, vn1, vn2, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
+ MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
+ MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ work = ALLOC_N(doublereal, (n));
+
+ dlaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
+
+ free(work);
+ return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
+}
+
+void
+init_lapack_dlaqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqp2", rblapack_dlaqp2, -1);
+}
diff --git a/ext/dlaqps.c b/ext/dlaqps.c
new file mode 100644
index 0000000..ac0797f
--- /dev/null
+++ b/ext/dlaqps.c
@@ -0,0 +1,208 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* vn1, doublereal* vn2, doublereal* auxv, doublereal* f, integer* ldf);
+
+
+static VALUE
+rblapack_dlaqps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ doublereal *vn1;
+ VALUE rblapack_vn2;
+ doublereal *vn2;
+ VALUE rblapack_auxv;
+ doublereal *auxv;
+ VALUE rblapack_f;
+ doublereal *f;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ doublereal *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ doublereal *vn2_out__;
+ VALUE rblapack_auxv_out__;
+ doublereal *auxv_out__;
+ VALUE rblapack_f_out__;
+ doublereal *f_out__;
+
+ integer lda;
+ integer n;
+ integer nb;
+ 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 kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.dlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* DLAQPS computes a step of QR factorization with column pivoting\n* of a real M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) DOUBLE PRECISION array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.dlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ rblapack_auxv = argv[6];
+ rblapack_f = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
+ if (!NA_IsNArray(rblapack_auxv))
+ rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_auxv) != 1)
+ rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
+ nb = NA_SHAPE0(rblapack_auxv);
+ if (NA_TYPE(rblapack_auxv) != NA_DFLOAT)
+ rblapack_auxv = na_change_type(rblapack_auxv, NA_DFLOAT);
+ auxv = NA_PTR_TYPE(rblapack_auxv, doublereal*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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) != nb)
+ rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
+ if (NA_TYPE(rblapack_f) != NA_DFLOAT)
+ rblapack_f = na_change_type(rblapack_f, NA_DFLOAT);
+ f = NA_PTR_TYPE(rblapack_f, doublereal*);
+ kb = nb;
+ {
+ int shape[1];
+ shape[0] = kb;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
+ MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
+ MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ {
+ int shape[1];
+ shape[0] = nb;
+ rblapack_auxv_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, doublereal*);
+ MEMCPY(auxv_out__, auxv, doublereal, NA_TOTAL(rblapack_auxv));
+ rblapack_auxv = rblapack_auxv_out__;
+ auxv = auxv_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = nb;
+ rblapack_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublereal*);
+ MEMCPY(f_out__, f, doublereal, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+
+ dlaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
+
+ rblapack_kb = INT2NUM(kb);
+ return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
+}
+
+void
+init_lapack_dlaqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqps", rblapack_dlaqps, -1);
+}
diff --git a/ext/dlaqr0.c b/ext/dlaqr0.c
new file mode 100644
index 0000000..c4a387c
--- /dev/null
+++ b/ext/dlaqr0.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dlaqr0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ihi;
+
+ 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 wr, wi, work, info, h, z = NumRu::Lapack.dlaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to DGEBAL, and then passed to DGEHRD when the\n* matrix output by DGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (IHI)\n* WI (output) DOUBLE PRECISION array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then DLAQR0 does a workspace query.\n* In this case, DLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, DLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.dlaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [: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_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_h = argv[3];
+ rblapack_iloz = argv[4];
+ rblapack_ihiz = argv[5];
+ rblapack_z = 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;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ ihi = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ wantz = (rblapack_wantz == Qtrue);
+ ihiz = NUM2INT(rblapack_ihiz);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = ihi;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dlaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_dlaqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqr0", rblapack_dlaqr0, -1);
+}
diff --git a/ext/dlaqr1.c b/ext/dlaqr1.c
new file mode 100644
index 0000000..0af4920
--- /dev/null
+++ b/ext/dlaqr1.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqr1_(integer* n, doublereal* h, integer* ldh, doublereal* sr1, doublereal* si1, doublereal* sr2, doublereal* si2, doublereal* v);
+
+
+static VALUE
+rblapack_dlaqr1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_sr1;
+ doublereal sr1;
+ VALUE rblapack_si1;
+ doublereal si1;
+ VALUE rblapack_sr2;
+ doublereal sr2;
+ VALUE rblapack_si2;
+ doublereal si2;
+ VALUE rblapack_v;
+ doublereal *v;
+
+ integer ldh;
+ 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 v = NumRu::Lapack.dlaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n*\n* scaling to avoid overflows and most underflows. It\n* is assumed that either\n*\n* 1) sr1 = sr2 and si1 = -si2\n* or\n* 2) si1 = si2 = 0.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) DOUBLE PRECISION array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* SR1 (input) DOUBLE PRECISION\n* SI1 The shifts in (*).\n* SR2\n* SI2\n*\n* V (output) DOUBLE PRECISION array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n v = NumRu::Lapack.dlaqr1( h, sr1, si1, sr2, si2, [: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_h = argv[0];
+ rblapack_sr1 = argv[1];
+ rblapack_si1 = argv[2];
+ rblapack_sr2 = argv[3];
+ rblapack_si2 = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (1th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ si1 = NUM2DBL(rblapack_si1);
+ si2 = NUM2DBL(rblapack_si2);
+ sr1 = NUM2DBL(rblapack_sr1);
+ sr2 = NUM2DBL(rblapack_sr2);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_v = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+
+ dlaqr1_(&n, h, &ldh, &sr1, &si1, &sr2, &si2, v);
+
+ return rblapack_v;
+}
+
+void
+init_lapack_dlaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqr1", rblapack_dlaqr1, -1);
+}
diff --git a/ext/dlaqr2.c b/ext/dlaqr2.c
new file mode 100644
index 0000000..c715ae8
--- /dev/null
+++ b/ext/dlaqr2.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublereal* h, integer* ldh, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, integer* ns, integer* nd, doublereal* sr, doublereal* si, doublereal* v, integer* ldv, integer* nh, doublereal* t, integer* ldt, integer* nv, doublereal* wv, integer* ldwv, doublereal* work, integer* lwork);
+
+
+static VALUE
+rblapack_dlaqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sr;
+ doublereal *sr;
+ VALUE rblapack_si;
+ doublereal *si;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+ doublereal *v;
+ doublereal *t;
+ doublereal *wv;
+ doublereal *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldt;
+ integer ldwv;
+
+ 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 ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to DLAQR3 except that it avoids\n* recursion by calling DLAHQR instead of DLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) DOUBLE PRECISION array, dimension (KBOT)\n* SI (output) DOUBLE PRECISION array, dimension (KBOT)\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; DLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sr = NA_PTR_TYPE(rblapack_sr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_si = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ si = NA_PTR_TYPE(rblapack_si, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(doublereal, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(doublereal, (ldt)*(MAX(1,nw)));
+ wv = ALLOC_N(doublereal, (ldwv)*(MAX(1,nw)));
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ dlaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_dlaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqr2", rblapack_dlaqr2, -1);
+}
diff --git a/ext/dlaqr3.c b/ext/dlaqr3.c
new file mode 100644
index 0000000..7623c30
--- /dev/null
+++ b/ext/dlaqr3.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublereal* h, integer* ldh, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, integer* ns, integer* nd, doublereal* sr, doublereal* si, doublereal* v, integer* ldv, integer* nh, doublereal* t, integer* ldt, integer* nv, doublereal* wv, integer* ldwv, doublereal* work, integer* lwork);
+
+
+static VALUE
+rblapack_dlaqr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sr;
+ doublereal *sr;
+ VALUE rblapack_si;
+ doublereal *si;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+ doublereal *v;
+ doublereal *t;
+ doublereal *wv;
+ doublereal *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldt;
+ integer ldwv;
+
+ 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 ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) DOUBLE PRECISION array, dimension (KBOT)\n* SI (output) DOUBLE PRECISION array, dimension (KBOT)\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; DLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sr = NA_PTR_TYPE(rblapack_sr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_si = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ si = NA_PTR_TYPE(rblapack_si, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(doublereal, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(doublereal, (ldt)*(MAX(1,nw)));
+ wv = ALLOC_N(doublereal, (ldwv)*(MAX(1,nw)));
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ dlaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_dlaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqr3", rblapack_dlaqr3, -1);
+}
diff --git a/ext/dlaqr4.c b/ext/dlaqr4.c
new file mode 100644
index 0000000..ce2a459
--- /dev/null
+++ b/ext/dlaqr4.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dlaqr4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ihi;
+
+ 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 wr, wi, work, info, h, z = NumRu::Lapack.dlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to DGEBAL, and then passed to DGEHRD when the\n* matrix output by DGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) DOUBLE PRECISION array, dimension (IHI)\n* WI (output) DOUBLE PRECISION array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then DLAQR4 does a workspace query.\n* In this case, DLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, DLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.dlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [: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_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_h = argv[3];
+ rblapack_iloz = argv[4];
+ rblapack_ihiz = argv[5];
+ rblapack_z = 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;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ ihi = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ wantz = (rblapack_wantz == Qtrue);
+ ihiz = NUM2INT(rblapack_ihiz);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = ihi;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dlaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_dlaqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqr4", rblapack_dlaqr4, -1);
+}
diff --git a/ext/dlaqr5.c b/ext/dlaqr5.c
new file mode 100644
index 0000000..6cade4b
--- /dev/null
+++ b/ext/dlaqr5.c
@@ -0,0 +1,200 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, doublereal* sr, doublereal* si, doublereal* h, integer* ldh, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, doublereal* v, integer* ldv, doublereal* u, integer* ldu, integer* nv, doublereal* wv, integer* ldwv, integer* nh, doublereal* wh, integer* ldwh);
+
+
+static VALUE
+rblapack_dlaqr5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_kacc22;
+ integer kacc22;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_sr;
+ doublereal *sr;
+ VALUE rblapack_si;
+ doublereal *si;
+ VALUE rblapack_h;
+ doublereal *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_sr_out__;
+ doublereal *sr_out__;
+ VALUE rblapack_si_out__;
+ doublereal *si_out__;
+ VALUE rblapack_h_out__;
+ doublereal *h_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+ doublereal *v;
+ doublereal *u;
+ doublereal *wv;
+ doublereal *wh;
+
+ integer nshfts;
+ integer ldh;
+ integer n;
+ integer ldv;
+ integer ldu;
+ integer ldwv;
+ integer ldwh;
+ integer ldz;
+
+ 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 sr, si, h, z = NumRu::Lapack.dlaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by DLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the quasi-triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the orthogonal Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: DLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: DLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: DLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* SR (input/output) DOUBLE PRECISION array of size (NSHFTS)\n* SI (input/output) DOUBLE PRECISION array of size (NSHFTS)\n* SR contains the real parts and SI contains the imaginary\n* parts of the NSHFTS shifts of origin that define the\n* multi-shift QR sweep. On output SR and SI may be\n* reordered.\n*\n* H (input/output) DOUBLE PRECISION array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep orthogonal\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) DOUBLE PRECISION array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) DOUBLE PRECISION array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sr, si, h, z = NumRu::Lapack.dlaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_kacc22 = argv[2];
+ rblapack_ktop = argv[3];
+ rblapack_kbot = argv[4];
+ rblapack_sr = argv[5];
+ rblapack_si = argv[6];
+ rblapack_h = argv[7];
+ rblapack_iloz = argv[8];
+ rblapack_ihiz = argv[9];
+ rblapack_z = argv[10];
+ rblapack_nv = argv[11];
+ rblapack_nh = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ kacc22 = NUM2INT(rblapack_kacc22);
+ kbot = NUM2INT(rblapack_kbot);
+ if (!NA_IsNArray(rblapack_si))
+ rb_raise(rb_eArgError, "si (7th argument) must be NArray");
+ if (NA_RANK(rblapack_si) != 1)
+ rb_raise(rb_eArgError, "rank of si (7th argument) must be %d", 1);
+ nshfts = NA_SHAPE0(rblapack_si);
+ if (NA_TYPE(rblapack_si) != NA_DFLOAT)
+ rblapack_si = na_change_type(rblapack_si, NA_DFLOAT);
+ si = NA_PTR_TYPE(rblapack_si, doublereal*);
+ iloz = NUM2INT(rblapack_iloz);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nv;
+ ldv = 3;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_sr))
+ rb_raise(rb_eArgError, "sr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_sr) != 1)
+ rb_raise(rb_eArgError, "rank of sr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_sr) != nshfts)
+ rb_raise(rb_eRuntimeError, "shape 0 of sr must be the same as shape 0 of si");
+ if (NA_TYPE(rblapack_sr) != NA_DFLOAT)
+ rblapack_sr = na_change_type(rblapack_sr, NA_DFLOAT);
+ sr = NA_PTR_TYPE(rblapack_sr, doublereal*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ nh = NUM2INT(rblapack_nh);
+ ldu = 3*nshfts-3;
+ ktop = NUM2INT(rblapack_ktop);
+ ldwh = 3*nshfts-3;
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (8th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (8th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, doublereal*);
+ ldz = n;
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (11th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nshfts;
+ rblapack_sr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sr_out__ = NA_PTR_TYPE(rblapack_sr_out__, doublereal*);
+ MEMCPY(sr_out__, sr, doublereal, NA_TOTAL(rblapack_sr));
+ rblapack_sr = rblapack_sr_out__;
+ sr = sr_out__;
+ {
+ int shape[1];
+ shape[0] = nshfts;
+ rblapack_si_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ si_out__ = NA_PTR_TYPE(rblapack_si_out__, doublereal*);
+ MEMCPY(si_out__, si, doublereal, NA_TOTAL(rblapack_si));
+ rblapack_si = rblapack_si_out__;
+ si = si_out__;
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
+ MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? ihiz : 0;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(doublereal, (ldv)*(nshfts/2));
+ u = ALLOC_N(doublereal, (ldu)*(3*nshfts-3));
+ wv = ALLOC_N(doublereal, (ldwv)*(3*nshfts-3));
+ wh = ALLOC_N(doublereal, (ldwh)*(MAX(1,nh)));
+
+ dlaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, sr, si, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
+
+ free(v);
+ free(u);
+ free(wv);
+ free(wh);
+ return rb_ary_new3(4, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_dlaqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqr5", rblapack_dlaqr5, -1);
+}
diff --git a/ext/dlaqsb.c b/ext/dlaqsb.c
new file mode 100644
index 0000000..5ff05f6
--- /dev/null
+++ b/ext/dlaqsb.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqsb_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_dlaqsb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.dlaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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, ab = NumRu::Lapack.dlaqsb( uplo, kd, ab, s, scond, amax, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_s = argv[3];
+ rblapack_scond = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ scond = NUM2DBL(rblapack_scond);
+ kd = NUM2INT(rblapack_kd);
+ amax = NUM2DBL(rblapack_amax);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dlaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_dlaqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqsb", rblapack_dlaqsb, -1);
+}
diff --git a/ext/dlaqsp.c b/ext/dlaqsp.c
new file mode 100644
index 0000000..fd3a80d
--- /dev/null
+++ b/ext/dlaqsp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqsp_(char* uplo, integer* n, doublereal* ap, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_dlaqsp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+
+ 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, ap = NumRu::Lapack.dlaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQSP 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* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\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, ap = NumRu::Lapack.dlaqsp( uplo, ap, 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_ap = 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_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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ scond = NUM2DBL(rblapack_scond);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dlaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ap);
+}
+
+void
+init_lapack_dlaqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqsp", rblapack_dlaqsp, -1);
+}
diff --git a/ext/dlaqsy.c b/ext/dlaqsy.c
new file mode 100644
index 0000000..fe21f16
--- /dev/null
+++ b/ext/dlaqsy.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqsy_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_dlaqsy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *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__;
+ 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 equed, a = NumRu::Lapack.dlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* DLAQSY 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) DOUBLE PRECISION 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.dlaqsy( 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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ scond = NUM2DBL(rblapack_scond);
+ {
+ int 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__;
+
+ dlaqsy_(&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_dlaqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqsy", rblapack_dlaqsy, -1);
+}
diff --git a/ext/dlaqtr.c b/ext/dlaqtr.c
new file mode 100644
index 0000000..86ca0d3
--- /dev/null
+++ b/ext/dlaqtr.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID dlaqtr_(logical* ltran, logical* lreal, integer* n, doublereal* t, integer* ldt, doublereal* b, doublereal* w, doublereal* scale, doublereal* x, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlaqtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ltran;
+ logical ltran;
+ VALUE rblapack_lreal;
+ logical lreal;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_w;
+ doublereal w;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *work;
+
+ integer ldt;
+ 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 scale, info, x = NumRu::Lapack.dlaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLAQTR solves the real quasi-triangular system\n*\n* op(T)*p = scale*c, if LREAL = .TRUE.\n*\n* or the complex quasi-triangular systems\n*\n* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.\n*\n* in real arithmetic, where T is upper quasi-triangular.\n* If LREAL = .FALSE., then the first diagonal block of T must be\n* 1 by 1, B is the specially structured matrix\n*\n* B = [ b(1) b(2) ... b(n) ]\n* [ w ]\n* [ w ]\n* [ . ]\n* [ w ]\n*\n* op(A) = A or A', A' denotes the conjugate transpose of\n* matrix A.\n*\n* On input, X = [ c ]. On output, X = [ p ].\n* [ d ] [ q ]\n*\n* This subroutine is designed for the condition number estimation\n* in routine DTRSNA.\n*\n\n* Arguments\n* =========\n*\n* LTRAN (input) LOGICAL\n* On entry, LTRAN specifies the option of conjugate transpose:\n* = .FALSE., op(T+i*B) = T+i*B,\n* = .TRUE., op(T+i*B) = (T+i*B)'.\n*\n* LREAL (input) LOGICAL\n* On entry, LREAL specifies the input matrix structure:\n* = .FALSE., the input is complex\n* = .TRUE., the input is real\n*\n* N (input) INTEGER\n* On entry, N specifies the order of T+i*B. N >= 0.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, T contains a matrix in Schur canonical form.\n* If LREAL = .FALSE., then the first diagonal block of T mu\n* be 1 by 1.\n*\n* LDT (input) INTEGER\n* The leading dimension of the matrix T. LDT >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (N)\n* On entry, B contains the elements to form the matrix\n* B as described above.\n* If LREAL = .TRUE., B is not referenced.\n*\n* W (input) DOUBLE PRECISION\n* On entry, W is the diagonal element of the matrix B.\n* If LREAL = .TRUE., W is not referenced.\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE is the scale factor.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (2*N)\n* On entry, X contains the right hand side of the system.\n* On exit, X is overwritten by the solution.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: the some diagonal 1 by 1 block has been perturbed by\n* a small number SMIN to keep nonsingularity.\n* 2: the some diagonal 2 by 2 block has been perturbed by\n* a small number in DLALN2 to keep nonsingularity.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x = NumRu::Lapack.dlaqtr( ltran, lreal, t, b, w, 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_ltran = argv[0];
+ rblapack_lreal = argv[1];
+ rblapack_t = argv[2];
+ rblapack_b = argv[3];
+ rblapack_w = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ltran = (rblapack_ltran == Qtrue);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (3th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (3th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ n = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ w = NUM2DBL(rblapack_w);
+ lreal = (rblapack_lreal == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (4th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 1)
+ rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 2*n);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2*n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (n));
+
+ dlaqtr_(<ran, &lreal, &n, t, &ldt, b, &w, &scale, x, work, &info);
+
+ free(work);
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_dlaqtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaqtr", rblapack_dlaqtr, -1);
+}
diff --git a/ext/dlar1v.c b/ext/dlar1v.c
new file mode 100644
index 0000000..6ce2d3a
--- /dev/null
+++ b/ext/dlar1v.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID dlar1v_(integer* n, integer* b1, integer* bn, doublereal* lambda, doublereal* d, doublereal* l, doublereal* ld, doublereal* lld, doublereal* pivmin, doublereal* gaptol, doublereal* z, logical* wantnc, integer* negcnt, doublereal* ztz, doublereal* mingma, integer* r, integer* isuppz, doublereal* nrminv, doublereal* resid, doublereal* rqcorr, doublereal* work);
+
+
+static VALUE
+rblapack_dlar1v(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;
+ doublereal *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__;
+ doublereal *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.dlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAR1V( 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* DLAR1V 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) DOUBLE PRECISION 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.dlar1v( 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_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(doublereal, (4*n));
+
+ dlar1v_(&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_dlar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlar1v", rblapack_dlar1v, -1);
+}
diff --git a/ext/dlar2v.c b/ext/dlar2v.c
new file mode 100644
index 0000000..dbb3a80
--- /dev/null
+++ b/ext/dlar2v.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID dlar2v_(integer* n, doublereal* x, doublereal* y, doublereal* z, integer* incx, doublereal* c, doublereal* s, integer* incc);
+
+
+static VALUE
+rblapack_dlar2v(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+ VALUE rblapack_z_out__;
+ doublereal *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.dlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n* Purpose\n* =======\n*\n* DLAR2V applies a vector of real plane rotations from both sides to\n* a sequence of 2-by-2 real symmetric matrices, defined by the elements\n* of the vectors x, y and z. For i = 1,2,...,n\n*\n* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )\n* ( z(i) y(i) ) ( -s(i) c(i) ) ( 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) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* The vector y.\n*\n* Z (input/output) DOUBLE PRECISION array,\n* 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) DOUBLE PRECISION 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, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.dlar2v( 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ 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_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ 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_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ 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_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dlar2v_(&n, x, y, z, &incx, c, s, &incc);
+
+ return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
+}
+
+void
+init_lapack_dlar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlar2v", rblapack_dlar2v, -1);
+}
diff --git a/ext/dlarf.c b/ext/dlarf.c
new file mode 100644
index 0000000..d7262de
--- /dev/null
+++ b/ext/dlarf.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dlarf_(char* side, integer* m, integer* n, doublereal* v, integer* incv, doublereal* tau, doublereal* c, integer* ldc, doublereal* work);
+
+
+static VALUE
+rblapack_dlarf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ 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 c = NumRu::Lapack.dlarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* DLARF applies a real elementary reflector H to a real m by n matrix\n* C, from either the left or the right. H is represented in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) DOUBLE PRECISION array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of H.\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 the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\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* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarf( side, m, v, incv, tau, c, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_v = argv[2];
+ rblapack_incv = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ m = NUM2INT(rblapack_m);
+ tau = NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (3th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int 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));
+
+ dlarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_dlarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarf", rblapack_dlarf, -1);
+}
diff --git a/ext/dlarfb.c b/ext/dlarfb.c
new file mode 100644
index 0000000..fe0bf28
--- /dev/null
+++ b/ext/dlarfb.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID dlarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, doublereal* v, integer* ldv, doublereal* t, integer* ldt, doublereal* c, integer* ldc, doublereal* work, integer* ldwork);
+
+
+static VALUE
+rblapack_dlarfb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ doublereal *work;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.dlarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* DLARFB applies a real block reflector H or its transpose H' to a\n* real m by n matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'T': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) DOUBLE PRECISION array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,K)\n* The triangular k by k matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\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 H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarfb( side, trans, direct, storev, m, v, t, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_v = argv[5];
+ rblapack_t = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th 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*);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ {
+ int 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, (ldwork)*(k));
+
+ dlarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_dlarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarfb", rblapack_dlarfb, -1);
+}
diff --git a/ext/dlarfg.c b/ext/dlarfg.c
new file mode 100644
index 0000000..afbd151
--- /dev/null
+++ b/ext/dlarfg.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID dlarfg_(integer* n, doublereal* alpha, doublereal* x, integer* incx, doublereal* tau);
+
+
+static VALUE
+rblapack_dlarfg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_x_out__;
+ doublereal *x_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 tau, alpha, x = NumRu::Lapack.dlarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* DLARFG generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, and x is an (n-1)-element real\n* vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n* Otherwise 1 <= tau <= 2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) DOUBLE PRECISION array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) DOUBLE PRECISION\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.dlarfg( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(incx);
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ dlarfg_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_alpha = rb_float_new((double)alpha);
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_dlarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarfg", rblapack_dlarfg, -1);
+}
diff --git a/ext/dlarfgp.c b/ext/dlarfgp.c
new file mode 100644
index 0000000..4eec4e4
--- /dev/null
+++ b/ext/dlarfgp.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID dlarfgp_(integer* n, doublereal* alpha, doublereal* x, integer* incx, doublereal* tau);
+
+
+static VALUE
+rblapack_dlarfgp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_x_out__;
+ doublereal *x_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 tau, alpha, x = NumRu::Lapack.dlarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* DLARFGP generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is non-negative, and x is\n* an (n-1)-element real vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) DOUBLE PRECISION array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) DOUBLE PRECISION\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.dlarfgp( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(incx);
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ dlarfgp_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_alpha = rb_float_new((double)alpha);
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_dlarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarfgp", rblapack_dlarfgp, -1);
+}
diff --git a/ext/dlarft.c b/ext/dlarft.c
new file mode 100644
index 0000000..2cfe8a1
--- /dev/null
+++ b/ext/dlarft.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID dlarft_(char* direct, char* storev, integer* n, integer* k, doublereal* v, integer* ldv, doublereal* tau, doublereal* t, integer* ldt);
+
+
+static VALUE
+rblapack_dlarft(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.dlarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* DLARFT forms the triangular factor T of a real block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) DOUBLE PRECISION array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.dlarft( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ dlarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_dlarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarft", rblapack_dlarft, -1);
+}
diff --git a/ext/dlarfx.c b/ext/dlarfx.c
new file mode 100644
index 0000000..6b14b52
--- /dev/null
+++ b/ext/dlarfx.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID dlarfx_(char* side, integer* m, integer* n, doublereal* v, doublereal* tau, doublereal* c, integer* ldc, doublereal* work);
+
+
+static VALUE
+rblapack_dlarfx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ doublereal *work;
+
+ integer m;
+ 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 c = NumRu::Lapack.dlarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* DLARFX applies a real elementary reflector H to a real m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of H.\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 the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= (1,M).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarfx( side, v, tau, c, [: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_side = argv[0];
+ rblapack_v = argv[1];
+ rblapack_tau = argv[2];
+ rblapack_c = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ tau = NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (2th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (4th 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*);
+ {
+ int 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));
+
+ dlarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_dlarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarfx", rblapack_dlarfx, -1);
+}
diff --git a/ext/dlargv.c b/ext/dlargv.c
new file mode 100644
index 0000000..fbb8a57
--- /dev/null
+++ b/ext/dlargv.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID dlargv_(integer* n, doublereal* x, integer* incx, doublereal* y, integer* incy, doublereal* c, integer* incc);
+
+
+static VALUE
+rblapack_dlargv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 c, x, y = NumRu::Lapack.dlargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* DLARGV generates a vector of real plane rotations, determined by\n* elements of the real vectors x and y. For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( a(i) )\n* ( -s(i) c(i) ) ( y(i) ) = ( 0 )\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.dlargv( n, x, incx, y, incy, incc, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ rblapack_incc = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ incc = NUM2INT(rblapack_incc);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incc;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dlargv_(&n, x, &incx, y, &incy, c, &incc);
+
+ return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_dlargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlargv", rblapack_dlargv, -1);
+}
diff --git a/ext/dlarnv.c b/ext/dlarnv.c
new file mode 100644
index 0000000..38d5a00
--- /dev/null
+++ b/ext/dlarnv.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID dlarnv_(integer* idist, integer* iseed, integer* n, doublereal* x);
+
+
+static VALUE
+rblapack_dlarnv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_idist;
+ integer idist;
+ VALUE rblapack_iseed;
+ integer *iseed;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_iseed_out__;
+ integer *iseed_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, iseed = NumRu::Lapack.dlarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* DLARNV returns a vector of n random real numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: uniform (0,1)\n* = 2: uniform (-1,1)\n* = 3: normal (0,1)\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) DOUBLE PRECISION array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine DLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.dlarnv( idist, iseed, n, [: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_idist = argv[0];
+ rblapack_iseed = argv[1];
+ rblapack_n = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ idist = NUM2INT(rblapack_idist);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_iseed))
+ rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
+ if (NA_RANK(rblapack_iseed) != 1)
+ rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iseed) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
+ if (NA_TYPE(rblapack_iseed) != NA_LINT)
+ rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
+ iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 4;
+ rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
+ MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
+ rblapack_iseed = rblapack_iseed_out__;
+ iseed = iseed_out__;
+
+ dlarnv_(&idist, iseed, &n, x);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_iseed);
+}
+
+void
+init_lapack_dlarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarnv", rblapack_dlarnv, -1);
+}
diff --git a/ext/dlarra.c b/ext/dlarra.c
new file mode 100644
index 0000000..95d9ab6
--- /dev/null
+++ b/ext/dlarra.c
@@ -0,0 +1,124 @@
+#include "rb_lapack.h"
+
+extern VOID dlarra_(integer* n, doublereal* d, doublereal* e, doublereal* e2, doublereal* spltol, doublereal* tnrm, integer* nsplit, integer* isplit, integer* info);
+
+
+static VALUE
+rblapack_dlarra(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_e2;
+ doublereal *e2;
+ VALUE rblapack_spltol;
+ doublereal spltol;
+ VALUE rblapack_tnrm;
+ doublereal tnrm;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_e2_out__;
+ doublereal *e2_out__;
+
+ 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 nsplit, isplit, info, e, e2 = NumRu::Lapack.dlarra( d, e, e2, spltol, tnrm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n* Purpose\n* =======\n*\n* Compute the splitting points with threshold SPLTOL.\n* DLARRA sets any \"small\" off-diagonal elements to zero.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n* are set to zero, the other entries of E are untouched.\n*\n* E2 (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* SPLTOL (input) DOUBLE PRECISION\n* The threshold for splitting. Two criteria can be used:\n* SPLTOL<0 : criterion based on absolute off-diagonal value\n* SPLTOL>0 : criterion that preserves relative accuracy\n*\n* TNRM (input) DOUBLE PRECISION\n* The norm of the matrix.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\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 nsplit, isplit, info, e, e2 = NumRu::Lapack.dlarra( d, e, e2, spltol, tnrm, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_e2 = argv[2];
+ rblapack_spltol = argv[3];
+ rblapack_tnrm = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
+ tnrm = NUM2DBL(rblapack_tnrm);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ spltol = NUM2DBL(rblapack_spltol);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, doublereal*);
+ MEMCPY(e2_out__, e2, doublereal, NA_TOTAL(rblapack_e2));
+ rblapack_e2 = rblapack_e2_out__;
+ e2 = e2_out__;
+
+ dlarra_(&n, d, e, e2, &spltol, &tnrm, &nsplit, isplit, &info);
+
+ rblapack_nsplit = INT2NUM(nsplit);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_nsplit, rblapack_isplit, rblapack_info, rblapack_e, rblapack_e2);
+}
+
+void
+init_lapack_dlarra(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarra", rblapack_dlarra, -1);
+}
diff --git a/ext/dlarrb.c b/ext/dlarrb.c
new file mode 100644
index 0000000..49dc8c6
--- /dev/null
+++ b/ext/dlarrb.c
@@ -0,0 +1,178 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrb_(integer* n, doublereal* d, doublereal* lld, integer* ifirst, integer* ilast, doublereal* rtol1, doublereal* rtol2, integer* offset, doublereal* w, doublereal* wgap, doublereal* werr, doublereal* work, integer* iwork, doublereal* pivmin, doublereal* spdiam, integer* twist, integer* info);
+
+
+static VALUE
+rblapack_dlarrb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_lld;
+ doublereal *lld;
+ VALUE rblapack_ifirst;
+ integer ifirst;
+ VALUE rblapack_ilast;
+ integer ilast;
+ VALUE rblapack_rtol1;
+ doublereal rtol1;
+ VALUE rblapack_rtol2;
+ doublereal rtol2;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_wgap;
+ doublereal *wgap;
+ VALUE rblapack_werr;
+ doublereal *werr;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_spdiam;
+ doublereal spdiam;
+ VALUE rblapack_twist;
+ integer twist;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_w_out__;
+ doublereal *w_out__;
+ VALUE rblapack_wgap_out__;
+ doublereal *wgap_out__;
+ VALUE rblapack_werr_out__;
+ doublereal *werr_out__;
+ doublereal *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 info, w, wgap, werr = NumRu::Lapack.dlarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n* Purpose\n* =======\n*\n* Given the relatively robust representation(RRR) L D L^T, DLARRB\n* does \"limited\" bisection to refine the eigenvalues of L D L^T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses and their gaps are input in WERR\n* and WGAP, respectively. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n* where GAP is the (estimated) distance to the nearest\n* eigenvalue.\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST throug\n* ILAST.\n* On output, these estimates are refined.\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On input, the (estimated) gaps between consecutive\n* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n* then WGAP(IFIRST-OFFSET) must be set to ZERO.\n* On output, these gaps are refined.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence.\n*\n* SPDIAM (input) DOUBLE PRECISION\n* The spectral diameter of the matrix.\n*\n* TWIST (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n*\n* INFO (output) INTEGER\n* Error flag.\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 info, w, wgap, werr = NumRu::Lapack.dlarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_d = argv[0];
+ rblapack_lld = argv[1];
+ rblapack_ifirst = argv[2];
+ rblapack_ilast = argv[3];
+ rblapack_rtol1 = argv[4];
+ rblapack_rtol2 = argv[5];
+ rblapack_offset = argv[6];
+ rblapack_w = argv[7];
+ rblapack_wgap = argv[8];
+ rblapack_werr = argv[9];
+ rblapack_pivmin = argv[10];
+ rblapack_spdiam = argv[11];
+ rblapack_twist = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ ifirst = NUM2INT(rblapack_ifirst);
+ rtol1 = NUM2DBL(rblapack_rtol1);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
+ spdiam = NUM2DBL(rblapack_spdiam);
+ ilast = NUM2INT(rblapack_ilast);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (8th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_lld))
+ rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
+ if (NA_RANK(rblapack_lld) != 1)
+ rb_raise(rb_eArgError, "rank of lld (2th 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*);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (9th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", n-1);
+ if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
+ rtol2 = NUM2DBL(rblapack_rtol2);
+ twist = NUM2INT(rblapack_twist);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
+ MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
+ MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
+ MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ work = ALLOC_N(doublereal, (2*n));
+ iwork = ALLOC_N(integer, (2*n));
+
+ dlarrb_(&n, d, lld, &ifirst, &ilast, &rtol1, &rtol2, &offset, w, wgap, werr, work, iwork, &pivmin, &spdiam, &twist, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_w, rblapack_wgap, rblapack_werr);
+}
+
+void
+init_lapack_dlarrb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrb", rblapack_dlarrb, -1);
+}
diff --git a/ext/dlarrc.c b/ext/dlarrc.c
new file mode 100644
index 0000000..094fbd7
--- /dev/null
+++ b/ext/dlarrc.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrc_(char* jobt, integer* n, doublereal* vl, doublereal* vu, doublereal* d, doublereal* e, doublereal* pivmin, integer* eigcnt, integer* lcnt, integer* rcnt, integer* info);
+
+
+static VALUE
+rblapack_dlarrc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobt;
+ char jobt;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_eigcnt;
+ integer eigcnt;
+ VALUE rblapack_lcnt;
+ integer lcnt;
+ VALUE rblapack_rcnt;
+ integer rcnt;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 eigcnt, lcnt, rcnt, info = NumRu::Lapack.dlarrc( jobt, vl, vu, d, e, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n* Purpose\n* =======\n*\n* Find the number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n* if JOBT = 'L'.\n*\n\n* Arguments\n* =========\n*\n* JOBT (input) CHARACTER*1\n* = 'T': Compute Sturm count for matrix T.\n* = 'L': Compute Sturm count for matrix L D L^T.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* The lower and upper bounds for the eigenvalues.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n* JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n*\n* E (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence for T.\n*\n* EIGCNT (output) INTEGER\n* The number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU]\n*\n* LCNT (output) INTEGER\n* RCNT (output) INTEGER\n* The left and right negcounts of the interval.\n*\n* INFO (output) INTEGER\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 eigcnt, lcnt, rcnt, info = NumRu::Lapack.dlarrc( jobt, vl, vu, d, e, pivmin, [: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_jobt = argv[0];
+ rblapack_vl = argv[1];
+ rblapack_vu = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e = argv[4];
+ rblapack_pivmin = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobt = StringValueCStr(rblapack_jobt)[0];
+ vu = NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_e);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ vl = NUM2DBL(rblapack_vl);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ 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 e");
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+
+ dlarrc_(&jobt, &n, &vl, &vu, d, e, &pivmin, &eigcnt, &lcnt, &rcnt, &info);
+
+ rblapack_eigcnt = INT2NUM(eigcnt);
+ rblapack_lcnt = INT2NUM(lcnt);
+ rblapack_rcnt = INT2NUM(rcnt);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_eigcnt, rblapack_lcnt, rblapack_rcnt, rblapack_info);
+}
+
+void
+init_lapack_dlarrc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrc", rblapack_dlarrc, -1);
+}
diff --git a/ext/dlarrd.c b/ext/dlarrd.c
new file mode 100644
index 0000000..e6ede43
--- /dev/null
+++ b/ext/dlarrd.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrd_(char* range, char* order, integer* n, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* gers, doublereal* reltol, doublereal* d, doublereal* e, doublereal* e2, doublereal* pivmin, integer* nsplit, integer* isplit, integer* m, doublereal* w, doublereal* werr, doublereal* wl, doublereal* wu, integer* iblock, integer* indexw, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlarrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_order;
+ char order;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_gers;
+ doublereal *gers;
+ VALUE rblapack_reltol;
+ doublereal reltol;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_e2;
+ doublereal *e2;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_werr;
+ doublereal *werr;
+ VALUE rblapack_wl;
+ doublereal wl;
+ VALUE rblapack_wu;
+ doublereal wu;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *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 m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.dlarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLARRD computes the eigenvalues of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from DSTEMR.\n* The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* GERS (input) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* RELTOL (input) DOUBLE PRECISION\n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* NSPLIT (input) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalue approximations. DLARRD computes an interval\n* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n* approximation is given as the interval midpoint\n* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n* WERR(j) = abs( a_j - b_j)/2\n*\n* WERR (output) DOUBLE PRECISION array, dimension (N)\n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* WL (output) DOUBLE PRECISION\n* WU (output) DOUBLE PRECISION\n* The interval (WL, WU] contains all the wanted eigenvalues.\n* If RANGE='V', then WL=VL and WU=VU.\n* If RANGE='A', then WL and WU are the global Gerschgorin bounds\n* on the spectrum.\n* If RANGE='I', then WL and WU are computed by DLAEBZ from the\n* index range specified.\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (DLARRD may use the remaining N-M elements as\n* workspace.)\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n* i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE DOUBLE PRECISION, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n* Based on contributions by\n* W. Kahan, University of California, Berkeley, USA\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\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.dlarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 14 && argc != 14)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
+ rblapack_range = argv[0];
+ rblapack_order = argv[1];
+ rblapack_vl = argv[2];
+ rblapack_vu = argv[3];
+ rblapack_il = argv[4];
+ rblapack_iu = argv[5];
+ rblapack_gers = argv[6];
+ rblapack_reltol = argv[7];
+ rblapack_d = argv[8];
+ rblapack_e = argv[9];
+ rblapack_e2 = argv[10];
+ rblapack_pivmin = argv[11];
+ rblapack_nsplit = argv[12];
+ rblapack_isplit = argv[13];
+ if (argc == 14) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ range = StringValueCStr(rblapack_range)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ reltol = NUM2DBL(rblapack_reltol);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (14th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (14th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_isplit);
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ order = StringValueCStr(rblapack_order)[0];
+ iu = NUM2INT(rblapack_iu);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (9th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (9th 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 isplit");
+ 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_e2))
+ rb_raise(rb_eArgError, "e2 (11th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
+ if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
+ vu = NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (10th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (!NA_IsNArray(rblapack_gers))
+ rb_raise(rb_eArgError, "gers (7th argument) must be NArray");
+ if (NA_RANK(rblapack_gers) != 1)
+ rb_raise(rb_eArgError, "rank of gers (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_gers) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
+ if (NA_TYPE(rblapack_gers) != NA_DFLOAT)
+ rblapack_gers = na_change_type(rblapack_gers, NA_DFLOAT);
+ gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
+ nsplit = NUM2INT(rblapack_nsplit);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (3*n));
+
+ dlarrd_(&range, &order, &n, &vl, &vu, &il, &iu, gers, &reltol, d, e, e2, &pivmin, &nsplit, isplit, &m, w, werr, &wl, &wu, iblock, indexw, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_wl = rb_float_new((double)wl);
+ rblapack_wu = rb_float_new((double)wu);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_werr, rblapack_wl, rblapack_wu, rblapack_iblock, rblapack_indexw, rblapack_info);
+}
+
+void
+init_lapack_dlarrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrd", rblapack_dlarrd, -1);
+}
diff --git a/ext/dlarre.c b/ext/dlarre.c
new file mode 100644
index 0000000..6e37e09
--- /dev/null
+++ b/ext/dlarre.c
@@ -0,0 +1,221 @@
+#include "rb_lapack.h"
+
+extern VOID dlarre_(char* range, integer* n, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* d, doublereal* e, doublereal* e2, doublereal* rtol1, doublereal* rtol2, doublereal* spltol, integer* nsplit, integer* isplit, integer* m, doublereal* w, doublereal* werr, doublereal* wgap, integer* iblock, integer* indexw, doublereal* gers, doublereal* pivmin, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlarre(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_e2;
+ doublereal *e2;
+ VALUE rblapack_rtol1;
+ doublereal rtol1;
+ VALUE rblapack_rtol2;
+ doublereal rtol2;
+ VALUE rblapack_spltol;
+ doublereal spltol;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_werr;
+ doublereal *werr;
+ VALUE rblapack_wgap;
+ doublereal *wgap;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ VALUE rblapack_gers;
+ doublereal *gers;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_e2_out__;
+ doublereal *e2_out__;
+ doublereal *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 nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.dlarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* To find the desired eigenvalues of a given real symmetric\n* tridiagonal matrix T, DLARRE sets any \"small\" off-diagonal\n* elements to zero, and for each unreduced block T_i, it finds\n* (a) a suitable shift at one end of the block's spectrum,\n* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n* (c) eigenvalues of each L_i D_i L_i^T.\n* The representations and eigenvalues found are then used by\n* DSTEMR to compute the eigenvectors of T.\n* The accuracy varies depending on whether bisection is used to\n* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to\n* conpute all and then discard any unwanted one.\n* As an added benefit, DLARRE also outputs the n\n* Gerschgorin intervals for the matrices L_i D_i L_i^T.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input/output) DOUBLE PRECISION\n* VU (input/output) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds for the eigenvalues.\n* Eigenvalues less than or equal to VL, or greater than VU,\n* will not be returned. VL < VU.\n* If RANGE='I' or ='A', DLARRE computes bounds on the desired\n* part of the spectrum.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n* On exit, the N diagonal elements of the diagonal\n* matrices D_i.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, E contains the subdiagonal elements of the unit\n* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, contain the base points sigma_i on output.\n*\n* E2 (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* SPLTOL (input) DOUBLE PRECISION\n* The threshold for splitting.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n* M (output) INTEGER\n* The total number of eigenvalues (of all L_i D_i L_i^T)\n* found.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the eigenvalues. The\n* eigenvalues of each of the blocks, L_i D_i L_i^T, are\n* sorted in ascending order ( DLARRE may use the\n* remaining N-M elements as workspace).\n*\n* WERR (output) DOUBLE PRECISION array, dimension (N)\n* The error bound on the corresponding eigenvalue in W.\n*\n* WGAP (output) DOUBLE PRECISION array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n* The gap is only with respect to the eigenvalues of the same block\n* as each block has its own representation tree.\n* Exception: at the right end of a block we store the left gap\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n*\n* GERS (output) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* PIVMIN (output) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence for T.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: A problem occured in DLARRE.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in DLARRD.\n* = 2: No base representation could be found in MAXTRY iterations.\n* Increasing MAXTRY and recompilation might be a remedy.\n* =-3: Problem in DLARRB when computing the refined root\n* representation for DLASQ2.\n* =-4: Problem in DLARRB when preforming bisection on the\n* desired part of the spectrum.\n* =-5: Problem in DLASQ2.\n* =-6: Problem in DLASQ2.\n*\n\n* Further Details\n* The base representations are required to suffer very little\n* element growth and consequently define all their eigenvalues to\n* high relative accuracy.\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 nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.dlarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [: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_range = argv[0];
+ rblapack_vl = argv[1];
+ rblapack_vu = argv[2];
+ rblapack_il = argv[3];
+ rblapack_iu = argv[4];
+ rblapack_d = argv[5];
+ rblapack_e = argv[6];
+ rblapack_e2 = argv[7];
+ rblapack_rtol1 = argv[8];
+ rblapack_rtol2 = argv[9];
+ rblapack_spltol = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (7th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_e);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ rtol1 = NUM2DBL(rblapack_rtol1);
+ spltol = NUM2DBL(rblapack_spltol);
+ vl = NUM2DBL(rblapack_vl);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (6th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (6th 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 e");
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ rtol2 = NUM2DBL(rblapack_rtol2);
+ il = NUM2INT(rblapack_il);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
+ if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wgap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ {
+ int shape[1];
+ shape[0] = 2*n;
+ rblapack_gers = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, doublereal*);
+ MEMCPY(e2_out__, e2, doublereal, NA_TOTAL(rblapack_e2));
+ rblapack_e2 = rblapack_e2_out__;
+ e2 = e2_out__;
+ work = ALLOC_N(doublereal, (6*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ dlarre_(&range, &n, &vl, &vu, &il, &iu, d, e, e2, &rtol1, &rtol2, &spltol, &nsplit, isplit, &m, w, werr, wgap, iblock, indexw, gers, &pivmin, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_nsplit = INT2NUM(nsplit);
+ rblapack_m = INT2NUM(m);
+ rblapack_pivmin = rb_float_new((double)pivmin);
+ rblapack_info = INT2NUM(info);
+ rblapack_vl = rb_float_new((double)vl);
+ rblapack_vu = rb_float_new((double)vu);
+ return rb_ary_new3(16, rblapack_nsplit, rblapack_isplit, rblapack_m, rblapack_w, rblapack_werr, rblapack_wgap, rblapack_iblock, rblapack_indexw, rblapack_gers, rblapack_pivmin, rblapack_info, rblapack_vl, rblapack_vu, rblapack_d, rblapack_e, rblapack_e2);
+}
+
+void
+init_lapack_dlarre(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarre", rblapack_dlarre, -1);
+}
diff --git a/ext/dlarrf.c b/ext/dlarrf.c
new file mode 100644
index 0000000..b01fad6
--- /dev/null
+++ b/ext/dlarrf.c
@@ -0,0 +1,176 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrf_(integer* n, doublereal* d, doublereal* l, doublereal* ld, integer* clstrt, integer* clend, doublereal* w, doublereal* wgap, doublereal* werr, doublereal* spdiam, doublereal* clgapl, doublereal* clgapr, doublereal* pivmin, doublereal* sigma, doublereal* dplus, doublereal* lplus, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlarrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_l;
+ doublereal *l;
+ VALUE rblapack_ld;
+ doublereal *ld;
+ VALUE rblapack_clstrt;
+ integer clstrt;
+ VALUE rblapack_clend;
+ integer clend;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_wgap;
+ doublereal *wgap;
+ VALUE rblapack_werr;
+ doublereal *werr;
+ VALUE rblapack_spdiam;
+ doublereal spdiam;
+ VALUE rblapack_clgapl;
+ doublereal clgapl;
+ VALUE rblapack_clgapr;
+ doublereal clgapr;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_sigma;
+ doublereal sigma;
+ VALUE rblapack_dplus;
+ doublereal *dplus;
+ VALUE rblapack_lplus;
+ doublereal *lplus;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_wgap_out__;
+ doublereal *wgap_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 sigma, dplus, lplus, info, wgap = NumRu::Lapack.dlarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial representation L D L^T and its cluster of close\n* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n* W( CLEND ), DLARRF finds a new relatively robust representation\n* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix (subblock, if the matrix splitted).\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* L (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) subdiagonal elements of the unit bidiagonal\n* matrix L.\n*\n* LD (input) DOUBLE PRECISION array, dimension (N-1)\n* The (N-1) elements L(i)*D(i).\n*\n* CLSTRT (input) INTEGER\n* The index of the first eigenvalue in the cluster.\n*\n* CLEND (input) INTEGER\n* The index of the last eigenvalue in the cluster.\n*\n* W (input) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n* W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n* close eigenalues.\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The separation from the right neighbor eigenvalue in W.\n*\n* WERR (input) DOUBLE PRECISION array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* WERR contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue APPROXIMATION in W\n*\n* SPDIAM (input) DOUBLE PRECISION\n* estimate of the spectral diameter obtained from the\n* Gerschgorin intervals\n*\n* CLGAPL (input) DOUBLE PRECISION\n*\n* CLGAPR (input) DOUBLE PRECISION\n* absolute gap on each end of the cluster.\n* Set by the calling routine to protect against shifts too close\n* to eigenvalues outside the cluster.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* SIGMA (output) DOUBLE PRECISION\n* The shift used to form L(+) D(+) L(+)^T.\n*\n* DPLUS (output) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the diagonal matrix D(+).\n*\n* LPLUS (output) DOUBLE PRECISION array, dimension (N-1)\n* The first (N-1) elements of LPLUS contain the subdiagonal\n* elements of the unit bidiagonal matrix L(+).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Workspace.\n*\n* INFO (output) INTEGER\n* Signals processing OK (=0) or failure (=1)\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 sigma, dplus, lplus, info, wgap = NumRu::Lapack.dlarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [: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_d = argv[0];
+ rblapack_l = argv[1];
+ rblapack_ld = argv[2];
+ rblapack_clstrt = argv[3];
+ rblapack_clend = argv[4];
+ rblapack_w = argv[5];
+ rblapack_wgap = argv[6];
+ rblapack_werr = argv[7];
+ rblapack_spdiam = argv[8];
+ rblapack_clgapl = argv[9];
+ rblapack_clgapr = argv[10];
+ rblapack_pivmin = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_ld))
+ rb_raise(rb_eArgError, "ld (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ld) != 1)
+ rb_raise(rb_eArgError, "rank of ld (3th 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*);
+ clend = NUM2INT(rblapack_clend);
+ spdiam = NUM2DBL(rblapack_spdiam);
+ clgapr = NUM2DBL(rblapack_clgapr);
+ if (!NA_IsNArray(rblapack_l))
+ rb_raise(rb_eArgError, "l (2th argument) must be NArray");
+ if (NA_RANK(rblapack_l) != 1)
+ rb_raise(rb_eArgError, "rank of l (2th 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*);
+ clgapl = NUM2DBL(rblapack_clgapl);
+ clstrt = NUM2INT(rblapack_clstrt);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (7th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != (clend-clstrt+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", clend-clstrt+1);
+ if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (6th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != (clend-clstrt+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be %d", clend-clstrt+1);
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != (clend-clstrt+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be %d", clend-clstrt+1);
+ if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dplus = NA_PTR_TYPE(rblapack_dplus, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_lplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ lplus = NA_PTR_TYPE(rblapack_lplus, doublereal*);
+ {
+ int shape[1];
+ shape[0] = clend-clstrt+1;
+ rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
+ MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ dlarrf_(&n, d, l, ld, &clstrt, &clend, w, wgap, werr, &spdiam, &clgapl, &clgapr, &pivmin, &sigma, dplus, lplus, work, &info);
+
+ free(work);
+ rblapack_sigma = rb_float_new((double)sigma);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_sigma, rblapack_dplus, rblapack_lplus, rblapack_info, rblapack_wgap);
+}
+
+void
+init_lapack_dlarrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrf", rblapack_dlarrf, -1);
+}
diff --git a/ext/dlarrj.c b/ext/dlarrj.c
new file mode 100644
index 0000000..02d4b09
--- /dev/null
+++ b/ext/dlarrj.c
@@ -0,0 +1,147 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrj_(integer* n, doublereal* d, doublereal* e2, integer* ifirst, integer* ilast, doublereal* rtol, integer* offset, doublereal* w, doublereal* werr, doublereal* work, integer* iwork, doublereal* pivmin, doublereal* spdiam, integer* info);
+
+
+static VALUE
+rblapack_dlarrj(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e2;
+ doublereal *e2;
+ VALUE rblapack_ifirst;
+ integer ifirst;
+ VALUE rblapack_ilast;
+ integer ilast;
+ VALUE rblapack_rtol;
+ doublereal rtol;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_werr;
+ doublereal *werr;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_spdiam;
+ doublereal spdiam;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_w_out__;
+ doublereal *w_out__;
+ VALUE rblapack_werr_out__;
+ doublereal *werr_out__;
+ doublereal *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 info, w, werr = NumRu::Lapack.dlarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial eigenvalue approximations of T, DLARRJ\n* does bisection to refine the eigenvalues of T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses in WERR. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of T.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N-1)\n* The Squares of the (N-1) subdiagonal elements of T.\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL (input) DOUBLE PRECISION\n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST through\n* ILAST.\n* On output, these estimates are refined.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot in the Sturm sequence for T.\n*\n* SPDIAM (input) DOUBLE PRECISION\n* The spectral diameter of T.\n*\n* INFO (output) INTEGER\n* Error flag.\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 info, w, werr = NumRu::Lapack.dlarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_d = argv[0];
+ rblapack_e2 = argv[1];
+ rblapack_ifirst = argv[2];
+ rblapack_ilast = argv[3];
+ rblapack_rtol = argv[4];
+ rblapack_offset = argv[5];
+ rblapack_w = argv[6];
+ rblapack_werr = argv[7];
+ rblapack_pivmin = argv[8];
+ rblapack_spdiam = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ ifirst = NUM2INT(rblapack_ifirst);
+ rtol = NUM2DBL(rblapack_rtol);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (7th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ ilast = NUM2INT(rblapack_ilast);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
+ if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
+ spdiam = NUM2DBL(rblapack_spdiam);
+ offset = NUM2INT(rblapack_offset);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
+ MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
+ MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ work = ALLOC_N(doublereal, (2*n));
+ iwork = ALLOC_N(integer, (2*n));
+
+ dlarrj_(&n, d, e2, &ifirst, &ilast, &rtol, &offset, w, werr, work, iwork, &pivmin, &spdiam, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_w, rblapack_werr);
+}
+
+void
+init_lapack_dlarrj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrj", rblapack_dlarrj, -1);
+}
diff --git a/ext/dlarrk.c b/ext/dlarrk.c
new file mode 100644
index 0000000..4aa5693
--- /dev/null
+++ b/ext/dlarrk.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrk_(integer* n, integer* iw, doublereal* gl, doublereal* gu, doublereal* d, doublereal* e2, doublereal* pivmin, doublereal* reltol, doublereal* w, doublereal* werr, integer* info);
+
+
+static VALUE
+rblapack_dlarrk(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_iw;
+ integer iw;
+ VALUE rblapack_gl;
+ doublereal gl;
+ VALUE rblapack_gu;
+ doublereal gu;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e2;
+ doublereal *e2;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_reltol;
+ doublereal reltol;
+ VALUE rblapack_w;
+ doublereal w;
+ VALUE rblapack_werr;
+ doublereal werr;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 w, werr, info = NumRu::Lapack.dlarrk( iw, gl, gu, d, e2, pivmin, reltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n* Purpose\n* =======\n*\n* DLARRK computes one eigenvalue of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from DSTEMR.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* IW (input) INTEGER\n* The index of the eigenvalues to be returned.\n*\n* GL (input) DOUBLE PRECISION\n* GU (input) DOUBLE PRECISION\n* An upper and a lower bound on the eigenvalue.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* RELTOL (input) DOUBLE PRECISION\n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* W (output) DOUBLE PRECISION\n*\n* WERR (output) DOUBLE PRECISION\n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* INFO (output) INTEGER\n* = 0: Eigenvalue converged\n* = -1: Eigenvalue did NOT converge\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE DOUBLE PRECISION, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, werr, info = NumRu::Lapack.dlarrk( iw, gl, gu, d, e2, pivmin, reltol, [: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_iw = argv[0];
+ rblapack_gl = argv[1];
+ rblapack_gu = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e2 = argv[4];
+ rblapack_pivmin = argv[5];
+ rblapack_reltol = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ iw = NUM2INT(rblapack_iw);
+ gu = NUM2DBL(rblapack_gu);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ gl = NUM2DBL(rblapack_gl);
+ reltol = NUM2DBL(rblapack_reltol);
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
+ if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
+
+ dlarrk_(&n, &iw, &gl, &gu, d, e2, &pivmin, &reltol, &w, &werr, &info);
+
+ rblapack_w = rb_float_new((double)w);
+ rblapack_werr = rb_float_new((double)werr);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_w, rblapack_werr, rblapack_info);
+}
+
+void
+init_lapack_dlarrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrk", rblapack_dlarrk, -1);
+}
diff --git a/ext/dlarrr.c b/ext/dlarrr.c
new file mode 100644
index 0000000..f1ad800
--- /dev/null
+++ b/ext/dlarrr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrr_(integer* n, doublereal* d, doublereal* e, integer* info);
+
+
+static VALUE
+rblapack_dlarrr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ 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, e = NumRu::Lapack.dlarrr( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRR( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* Perform tests to decide whether the symmetric tridiagonal matrix T\n* warrants expensive computations which guarantee high relative accuracy\n* in the eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The N diagonal elements of the tridiagonal matrix T.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) is set to ZERO.\n*\n* INFO (output) INTEGER\n* INFO = 0(default) : the matrix warrants computations preserving\n* relative accuracy.\n* INFO = 1 : the matrix warrants computations guaranteeing\n* only absolute accuracy.\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 info, e = NumRu::Lapack.dlarrr( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ dlarrr_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_e);
+}
+
+void
+init_lapack_dlarrr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrr", rblapack_dlarrr, -1);
+}
diff --git a/ext/dlarrv.c b/ext/dlarrv.c
new file mode 100644
index 0000000..501fb91
--- /dev/null
+++ b/ext/dlarrv.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID dlarrv_(integer* n, doublereal* vl, doublereal* vu, doublereal* d, doublereal* l, doublereal* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, doublereal* minrgp, doublereal* rtol1, doublereal* rtol2, doublereal* w, doublereal* werr, doublereal* wgap, integer* iblock, integer* indexw, doublereal* gers, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlarrv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_l;
+ doublereal *l;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_dol;
+ integer dol;
+ VALUE rblapack_dou;
+ integer dou;
+ VALUE rblapack_minrgp;
+ doublereal minrgp;
+ VALUE rblapack_rtol1;
+ doublereal rtol1;
+ VALUE rblapack_rtol2;
+ doublereal rtol2;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_werr;
+ doublereal *werr;
+ VALUE rblapack_wgap;
+ doublereal *wgap;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ VALUE rblapack_gers;
+ doublereal *gers;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_l_out__;
+ doublereal *l_out__;
+ VALUE rblapack_w_out__;
+ doublereal *w_out__;
+ VALUE rblapack_werr_out__;
+ doublereal *werr_out__;
+ VALUE rblapack_wgap_out__;
+ doublereal *wgap_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+
+ 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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.dlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by DLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by DLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (input) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) DOUBLE PRECISION\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from DLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in DLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in DLARRB when refining a child's eigenvalues.\n* =-2: Problem in DLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in DLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.dlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 18 && argc != 18)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
+ rblapack_vl = argv[0];
+ rblapack_vu = argv[1];
+ rblapack_d = argv[2];
+ rblapack_l = argv[3];
+ rblapack_pivmin = argv[4];
+ rblapack_isplit = argv[5];
+ rblapack_m = argv[6];
+ rblapack_dol = argv[7];
+ rblapack_dou = argv[8];
+ rblapack_minrgp = argv[9];
+ rblapack_rtol1 = argv[10];
+ rblapack_rtol2 = argv[11];
+ rblapack_w = argv[12];
+ rblapack_werr = argv[13];
+ rblapack_wgap = argv[14];
+ rblapack_iblock = argv[15];
+ rblapack_indexw = argv[16];
+ rblapack_gers = argv[17];
+ if (argc == 18) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vl = NUM2DBL(rblapack_vl);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ m = NUM2INT(rblapack_m);
+ dou = NUM2INT(rblapack_dou);
+ rtol1 = NUM2DBL(rblapack_rtol1);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (13th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
+ if (!NA_IsNArray(rblapack_indexw))
+ rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
+ if (NA_RANK(rblapack_indexw) != 1)
+ rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indexw) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indexw) != NA_LINT)
+ rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ vu = NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ minrgp = NUM2DBL(rblapack_minrgp);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
+ if (!NA_IsNArray(rblapack_l))
+ rb_raise(rb_eArgError, "l (4th argument) must be NArray");
+ if (NA_RANK(rblapack_l) != 1)
+ rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_l) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_l) != NA_DFLOAT)
+ rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
+ l = NA_PTR_TYPE(rblapack_l, doublereal*);
+ rtol2 = NUM2DBL(rblapack_rtol2);
+ dol = NUM2INT(rblapack_dol);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ ldz = n;
+ if (!NA_IsNArray(rblapack_gers))
+ rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
+ if (NA_RANK(rblapack_gers) != 1)
+ rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_gers) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
+ if (NA_TYPE(rblapack_gers) != NA_DFLOAT)
+ rblapack_gers = na_change_type(rblapack_gers, NA_DFLOAT);
+ gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_l_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ l_out__ = NA_PTR_TYPE(rblapack_l_out__, doublereal*);
+ MEMCPY(l_out__, l, doublereal, NA_TOTAL(rblapack_l));
+ rblapack_l = rblapack_l_out__;
+ l = l_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
+ MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
+ MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
+ MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ work = ALLOC_N(doublereal, (12*n));
+ iwork = ALLOC_N(integer, (7*n));
+
+ dlarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
+}
+
+void
+init_lapack_dlarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarrv", rblapack_dlarrv, -1);
+}
diff --git a/ext/dlarscl2.c b/ext/dlarscl2.c
new file mode 100644
index 0000000..e34b713
--- /dev/null
+++ b/ext/dlarscl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dlarscl2_(integer* m, integer* n, doublereal* d, doublereal* x, integer* ldx);
+
+
+static VALUE
+rblapack_dlarscl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.dlarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* DLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (M)\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.dlarscl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ dlarscl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_dlarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarscl2", rblapack_dlarscl2, -1);
+}
diff --git a/ext/dlartg.c b/ext/dlartg.c
new file mode 100644
index 0000000..9cf1e6d
--- /dev/null
+++ b/ext/dlartg.c
@@ -0,0 +1,61 @@
+#include "rb_lapack.h"
+
+extern VOID dlartg_(doublereal* f, doublereal* g, doublereal* cs, doublereal* sn, doublereal* r);
+
+
+static VALUE
+rblapack_dlartg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ doublereal f;
+ VALUE rblapack_g;
+ doublereal g;
+ VALUE rblapack_cs;
+ doublereal cs;
+ VALUE rblapack_sn;
+ doublereal sn;
+ VALUE rblapack_r;
+ doublereal r;
+
+
+ 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 cs, sn, r = NumRu::Lapack.dlartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* DLARTG generate a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the BLAS1 routine DROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n* floating point operations (saves work in DBDSQR when\n* there are zeros on the diagonal).\n*\n* If F exceeds G in magnitude, CS will be positive.\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The first component of vector to be rotated.\n*\n* G (input) DOUBLE PRECISION\n* The second component of vector to be rotated.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) DOUBLE PRECISION\n* The sine of the rotation.\n*\n* R (output) DOUBLE PRECISION\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.dlartg( f, g, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = NUM2DBL(rblapack_f);
+ g = NUM2DBL(rblapack_g);
+
+ dlartg_(&f, &g, &cs, &sn, &r);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ rblapack_r = rb_float_new((double)r);
+ return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
+}
+
+void
+init_lapack_dlartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlartg", rblapack_dlartg, -1);
+}
diff --git a/ext/dlartgp.c b/ext/dlartgp.c
new file mode 100644
index 0000000..d720a54
--- /dev/null
+++ b/ext/dlartgp.c
@@ -0,0 +1,61 @@
+#include "rb_lapack.h"
+
+extern VOID dlartgp_(doublereal* f, doublereal* g, doublereal* cs, doublereal* sn, doublereal* r);
+
+
+static VALUE
+rblapack_dlartgp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ doublereal f;
+ VALUE rblapack_g;
+ doublereal g;
+ VALUE rblapack_cs;
+ doublereal cs;
+ VALUE rblapack_sn;
+ doublereal sn;
+ VALUE rblapack_r;
+ doublereal r;
+
+
+ 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 cs, sn, r = NumRu::Lapack.dlartgp( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTGP( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* DLARTGP generates a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the Level 1 BLAS routine DROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=(+/-)1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n*\n* The sign is chosen so that R >= 0.\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The first component of vector to be rotated.\n*\n* G (input) DOUBLE PRECISION\n* The second component of vector to be rotated.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) DOUBLE PRECISION\n* The sine of the rotation.\n*\n* R (output) DOUBLE PRECISION\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.dlartgp( f, g, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = NUM2DBL(rblapack_f);
+ g = NUM2DBL(rblapack_g);
+
+ dlartgp_(&f, &g, &cs, &sn, &r);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ rblapack_r = rb_float_new((double)r);
+ return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
+}
+
+void
+init_lapack_dlartgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlartgp", rblapack_dlartgp, -1);
+}
diff --git a/ext/dlartgs.c b/ext/dlartgs.c
new file mode 100644
index 0000000..8e10d7e
--- /dev/null
+++ b/ext/dlartgs.c
@@ -0,0 +1,62 @@
+#include "rb_lapack.h"
+
+extern VOID dlartgs_(doublereal* x, doublereal* y, doublereal* sigma, doublereal* cs, doublereal* sn);
+
+
+static VALUE
+rblapack_dlartgs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublereal x;
+ VALUE rblapack_y;
+ doublereal y;
+ VALUE rblapack_sigma;
+ doublereal sigma;
+ VALUE rblapack_cs;
+ doublereal cs;
+ VALUE rblapack_sn;
+ doublereal sn;
+
+
+ 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 cs, sn = NumRu::Lapack.dlartgs( x, y, sigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )\n\n* Purpose\n* =======\n*\n* DLARTGS generates a plane rotation designed to introduce a bulge in\n* Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n* problem. X and Y are the top-row entries, and SIGMA is the shift.\n* The computed CS and SN define a plane rotation satisfying\n*\n* [ CS SN ] . [ X^2 - SIGMA ] = [ R ],\n* [ -SN CS ] [ X * Y ] [ 0 ]\n*\n* with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the\n* rotation is by PI/2.\n*\n\n* Arguments\n* =========\n*\n* X (input) DOUBLE PRECISION\n* The (1,1) entry of an upper bidiagonal matrix.\n*\n* Y (input) DOUBLE PRECISION\n* The (1,2) entry of an upper bidiagonal matrix.\n*\n* SIGMA (input) DOUBLE PRECISION\n* The shift.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) DOUBLE PRECISION\n* The sine of the rotation.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn = NumRu::Lapack.dlartgs( x, y, sigma, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_sigma = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x = NUM2DBL(rblapack_x);
+ sigma = NUM2DBL(rblapack_sigma);
+ y = NUM2DBL(rblapack_y);
+
+ dlartgs_(&x, &y, &sigma, &cs, &sn);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ return rb_ary_new3(2, rblapack_cs, rblapack_sn);
+}
+
+void
+init_lapack_dlartgs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlartgs", rblapack_dlartgs, -1);
+}
diff --git a/ext/dlartv.c b/ext/dlartv.c
new file mode 100644
index 0000000..a103d9b
--- /dev/null
+++ b/ext/dlartv.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID dlartv_(integer* n, doublereal* x, integer* incx, doublereal* y, integer* incy, doublereal* c, doublereal* s, integer* incc);
+
+
+static VALUE
+rblapack_dlartv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 = NumRu::Lapack.dlartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* DLARTV applies a vector of real plane rotations to elements of the\n* real vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -s(i) c(i) ) ( y(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) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) DOUBLE PRECISION array,\n* dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) DOUBLE PRECISION 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, IY\n DOUBLE PRECISION XI, YI\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.dlartv( n, x, incx, y, incy, 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_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = 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);
+ incy = NUM2INT(rblapack_incy);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ 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*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ 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_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ dlartv_(&n, x, &incx, y, &incy, c, s, &incc);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_dlartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlartv", rblapack_dlartv, -1);
+}
diff --git a/ext/dlaruv.c b/ext/dlaruv.c
new file mode 100644
index 0000000..4686214
--- /dev/null
+++ b/ext/dlaruv.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID dlaruv_(integer* iseed, integer* n, doublereal* x);
+
+
+static VALUE
+rblapack_dlaruv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_iseed;
+ integer *iseed;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_iseed_out__;
+ integer *iseed_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, iseed = NumRu::Lapack.dlaruv( iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARUV( ISEED, N, X )\n\n* Purpose\n* =======\n*\n* DLARUV returns a vector of n random real numbers from a uniform (0,1)\n* distribution (n <= 128).\n*\n* This is an auxiliary routine called by DLARNV and ZLARNV.\n*\n\n* Arguments\n* =========\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated. N <= 128.\n*\n* X (output) DOUBLE PRECISION array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine uses a multiplicative congruential method with modulus\n* 2**48 and multiplier 33952834046453 (see G.S.Fishman,\n* 'Multiplicative congruential random number generators with modulus\n* 2**b: an exhaustive analysis for b = 32 and a partial analysis for\n* b = 48', Math. Comp. 189, pp 331-344, 1990).\n*\n* 48-bit integers are stored in 4 integer array elements with 12 bits\n* per element. Hence the routine is portable across machines with\n* integers of 32 bits or more.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.dlaruv( iseed, n, [: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_iseed = argv[0];
+ rblapack_n = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_iseed))
+ rb_raise(rb_eArgError, "iseed (1th argument) must be NArray");
+ if (NA_RANK(rblapack_iseed) != 1)
+ rb_raise(rb_eArgError, "rank of iseed (1th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iseed) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
+ if (NA_TYPE(rblapack_iseed) != NA_LINT)
+ rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
+ iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
+ n = NUM2INT(rblapack_n);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 4;
+ rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
+ MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
+ rblapack_iseed = rblapack_iseed_out__;
+ iseed = iseed_out__;
+
+ dlaruv_(iseed, &n, x);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_iseed);
+}
+
+void
+init_lapack_dlaruv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaruv", rblapack_dlaruv, -1);
+}
diff --git a/ext/dlarz.c b/ext/dlarz.c
new file mode 100644
index 0000000..635e7cd
--- /dev/null
+++ b/ext/dlarz.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID dlarz_(char* side, integer* m, integer* n, integer* l, doublereal* v, integer* incv, doublereal* tau, doublereal* c, integer* ldc, doublereal* work);
+
+
+static VALUE
+rblapack_dlarz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ 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 c = NumRu::Lapack.dlarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* DLARZ applies a real elementary reflector H to a real M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n*\n* H is a product of k elementary reflectors as returned by DTZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* DTZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of H.\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 the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\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* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarz( side, m, l, v, incv, 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_m = argv[1];
+ rblapack_l = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ incv = NUM2INT(rblapack_incv);
+ 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*);
+ m = NUM2INT(rblapack_m);
+ tau = NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int 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));
+
+ dlarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_dlarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarz", rblapack_dlarz, -1);
+}
diff --git a/ext/dlarzb.c b/ext/dlarzb.c
new file mode 100644
index 0000000..c7f178b
--- /dev/null
+++ b/ext/dlarzb.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID dlarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, doublereal* v, integer* ldv, doublereal* t, integer* ldt, doublereal* c, integer* ldc, doublereal* work, integer* ldwork);
+
+
+static VALUE
+rblapack_dlarzb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ doublereal *work;
+
+ integer ldv;
+ integer nv;
+ integer ldt;
+ integer k;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.dlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* DLARZB applies a real block reflector H or its transpose H**T to\n* a real distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) DOUBLE PRECISION array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\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 H*C or H'*C or C*H or C*H'.\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 (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.dlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_l = argv[5];
+ rblapack_v = argv[6];
+ rblapack_t = argv[7];
+ rblapack_c = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ nv = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (9th 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ l = NUM2INT(rblapack_l);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (8th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ {
+ int 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, (ldwork)*(k));
+
+ dlarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_dlarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarzb", rblapack_dlarzb, -1);
+}
diff --git a/ext/dlarzt.c b/ext/dlarzt.c
new file mode 100644
index 0000000..3b14f9f
--- /dev/null
+++ b/ext/dlarzt.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID dlarzt_(char* direct, char* storev, integer* n, integer* k, doublereal* v, integer* ldv, doublereal* tau, doublereal* t, integer* ldt);
+
+
+static VALUE
+rblapack_dlarzt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.dlarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* DLARZT forms the triangular factor T of a real block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) DOUBLE PRECISION array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) DOUBLE PRECISION array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.dlarzt( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ dlarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_dlarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlarzt", rblapack_dlarzt, -1);
+}
diff --git a/ext/dlas2.c b/ext/dlas2.c
new file mode 100644
index 0000000..905eba5
--- /dev/null
+++ b/ext/dlas2.c
@@ -0,0 +1,62 @@
+#include "rb_lapack.h"
+
+extern VOID dlas2_(doublereal* f, doublereal* g, doublereal* h, doublereal* ssmin, doublereal* ssmax);
+
+
+static VALUE
+rblapack_dlas2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ doublereal f;
+ VALUE rblapack_g;
+ doublereal g;
+ VALUE rblapack_h;
+ doublereal h;
+ VALUE rblapack_ssmin;
+ doublereal ssmin;
+ VALUE rblapack_ssmax;
+ doublereal ssmax;
+
+
+ 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 ssmin, ssmax = NumRu::Lapack.dlas2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )\n\n* Purpose\n* =======\n*\n* DLAS2 computes the singular values of the 2-by-2 matrix\n* [ F G ]\n* [ 0 H ].\n* On return, SSMIN is the smaller singular value and SSMAX is the\n* larger singular value.\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) DOUBLE PRECISION\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) DOUBLE PRECISION\n* The smaller singular value.\n*\n* SSMAX (output) DOUBLE PRECISION\n* The larger singular value.\n*\n\n* Further Details\n* ===============\n*\n* Barring over/underflow, all output quantities are correct to within\n* a few units in the last place (ulps), even in the absence of a guard\n* digit in addition/subtraction.\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows, or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* ====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, ssmax = NumRu::Lapack.dlas2( f, g, h, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ rblapack_h = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = NUM2DBL(rblapack_f);
+ h = NUM2DBL(rblapack_h);
+ g = NUM2DBL(rblapack_g);
+
+ dlas2_(&f, &g, &h, &ssmin, &ssmax);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ rblapack_ssmax = rb_float_new((double)ssmax);
+ return rb_ary_new3(2, rblapack_ssmin, rblapack_ssmax);
+}
+
+void
+init_lapack_dlas2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlas2", rblapack_dlas2, -1);
+}
diff --git a/ext/dlascl.c b/ext/dlascl.c
new file mode 100644
index 0000000..3786261
--- /dev/null
+++ b/ext/dlascl.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dlascl_(char* type, integer* kl, integer* ku, doublereal* cfrom, doublereal* cto, integer* m, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dlascl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_type;
+ char type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_cfrom;
+ doublereal cfrom;
+ VALUE rblapack_cto;
+ doublereal cto;
+ VALUE rblapack_m;
+ integer m;
+ 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.dlascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DLASCL multiplies the M by N real matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See DGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) DOUBLE PRECISION\n* CTO (input) DOUBLE PRECISION\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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, a = NumRu::Lapack.dlascl( type, kl, ku, cfrom, cto, m, a, [: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_type = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_cfrom = argv[3];
+ rblapack_cto = argv[4];
+ rblapack_m = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ type = StringValueCStr(rblapack_type)[0];
+ ku = NUM2INT(rblapack_ku);
+ cto = NUM2DBL(rblapack_cto);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th 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*);
+ kl = NUM2INT(rblapack_kl);
+ m = NUM2INT(rblapack_m);
+ cfrom = NUM2DBL(rblapack_cfrom);
+ {
+ int 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__;
+
+ dlascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dlascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlascl", rblapack_dlascl, -1);
+}
diff --git a/ext/dlascl2.c b/ext/dlascl2.c
new file mode 100644
index 0000000..3d46276
--- /dev/null
+++ b/ext/dlascl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dlascl2_(integer* m, integer* n, doublereal* d, doublereal* x, integer* ldx);
+
+
+static VALUE
+rblapack_dlascl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.dlascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* DLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.dlascl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+
+ dlascl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_dlascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlascl2", rblapack_dlascl2, -1);
+}
diff --git a/ext/dlasd0.c b/ext/dlasd0.c
new file mode 100644
index 0000000..06d0f9d
--- /dev/null
+++ b/ext/dlasd0.c
@@ -0,0 +1,120 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd0_(integer* n, integer* sqre, doublereal* d, doublereal* e, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, integer* smlsiz, integer* iwork, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlasd0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ integer *iwork;
+ doublereal *work;
+
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, info, d = NumRu::Lapack.dlasd0( sqre, d, e, smlsiz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, DLASD0 computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M\n* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n* The algorithm computes orthogonal matrices U and VT such that\n* B = U * S * VT. The singular values S are overwritten on D.\n*\n* A related subroutine, DLASDA, computes only the singular values,\n* and optionally, the singular vectors in compact form.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the row dimension of the upper bidiagonal matrix.\n* This is also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N+1;\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix.\n* On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) DOUBLE PRECISION array, dimension (M-1)\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N)\n* On exit, U contains the left singular vectors.\n*\n* LDU (input) INTEGER\n* On entry, leading dimension of U.\n*\n* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M)\n* On exit, VT' contains the right singular vectors.\n*\n* LDVT (input) INTEGER\n* On entry, leading dimension of VT.\n*\n* SMLSIZ (input) INTEGER\n* On entry, maximum size of the subproblems at the\n* bottom of the computation tree.\n*\n* IWORK (workspace) INTEGER work array.\n* Dimension must be at least (8 * N)\n*\n* WORK (workspace) DOUBLE PRECISION work array.\n* Dimension must be at least (3 * M**2 + 2 * M)\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n DOUBLE PRECISION ALPHA, BETA\n* ..\n* .. External Subroutines ..\n EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, info, d = NumRu::Lapack.dlasd0( sqre, d, e, smlsiz, [: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_sqre = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_smlsiz = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ sqre = NUM2INT(rblapack_sqre);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
+ ldu = n;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ ldvt = n;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ iwork = ALLOC_N(integer, ((8 * n)));
+ work = ALLOC_N(doublereal, ((3 * pow(m,2) + 2 * m)));
+
+ dlasd0_(&n, &sqre, d, e, u, &ldu, vt, &ldvt, &smlsiz, iwork, work, &info);
+
+ free(iwork);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_u, rblapack_vt, rblapack_info, rblapack_d);
+}
+
+void
+init_lapack_dlasd0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd0", rblapack_dlasd0, -1);
+}
diff --git a/ext/dlasd1.c b/ext/dlasd1.c
new file mode 100644
index 0000000..e532084
--- /dev/null
+++ b/ext/dlasd1.c
@@ -0,0 +1,162 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd1_(integer* nl, integer* nr, integer* sqre, doublereal* d, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, integer* idxq, integer* iwork, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlasd1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_u_out__;
+ doublereal *u_out__;
+ VALUE rblapack_vt_out__;
+ doublereal *vt_out__;
+ integer *iwork;
+ doublereal *work;
+
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.dlasd1( nl, nr, sqre, d, alpha, beta, u, vt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.\n*\n* A related subroutine DLASD7 handles the case in which the singular\n* values (and the singular vectors in factored form) are desired.\n*\n* DLASD1 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The left singular vectors of the original matrix are stored in U, and\n* the transpose of the right singular vectors are stored in VT, and the\n* singular values are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or when there are zeros in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLASD2.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the square roots of the\n* roots of the secular equation via the routine DLASD4 (as called\n* by DLASD3). This routine also calculates the singular vectors of\n* the current problem.\n*\n* The final stage consists of computing the updated singular vectors\n* directly using the updated singular values. The singular vectors\n* for the current problem are multiplied with the singular vectors\n* from the overall problem.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) DOUBLE PRECISION array,\n* dimension (N = NL+NR+1).\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block; and D(NL+2:N) contains the singular values of\n* the lower block. On exit D(1:N) contains the singular values\n* of the modified matrix.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n* On entry U(1:NL, 1:NL) contains the left singular vectors of\n* the upper block; U(NL+2:N, NL+2:N) contains the left singular\n* vectors of the lower block. On exit U contains the left\n* singular vectors of the bidiagonal matrix.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max( 1, N ).\n*\n* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n* where M = N + SQRE.\n* On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n* the right singular vectors of the lower block. On exit\n* VT' contains the right singular vectors of the\n* bidiagonal matrix.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= max( 1, M ).\n*\n* IDXQ (output) INTEGER array, dimension(N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension( 4 * N )\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.dlasd1( nl, nr, sqre, d, alpha, beta, u, vt, [: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_nl = argv[0];
+ rblapack_nr = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_d = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_u = argv[6];
+ rblapack_vt = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nl = NUM2INT(rblapack_nl);
+ sqre = NUM2INT(rblapack_sqre);
+ alpha = NUM2DBL(rblapack_alpha);
+ nr = NUM2INT(rblapack_nr);
+ beta = NUM2DBL(rblapack_beta);
+ n = nl+nr+1;
+ 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 nl+nr+1");
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ m = n + sqre;
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (7th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ if (NA_SHAPE1(rblapack_u) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of u must be nl+nr+1");
+ if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ if (NA_SHAPE1(rblapack_vt) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vt must be n + sqre");
+ if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
+ MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
+ MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ iwork = ALLOC_N(integer, (4 * n));
+ work = ALLOC_N(doublereal, (3*pow(m,2) + 2*m));
+
+ dlasd1_(&nl, &nr, &sqre, d, &alpha, &beta, u, &ldu, vt, &ldvt, idxq, iwork, work, &info);
+
+ free(iwork);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ rblapack_alpha = rb_float_new((double)alpha);
+ rblapack_beta = rb_float_new((double)beta);
+ return rb_ary_new3(7, rblapack_idxq, rblapack_info, rblapack_d, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_vt);
+}
+
+void
+init_lapack_dlasd1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd1", rblapack_dlasd1, -1);
+}
diff --git a/ext/dlasd2.c b/ext/dlasd2.c
new file mode 100644
index 0000000..570714e
--- /dev/null
+++ b/ext/dlasd2.c
@@ -0,0 +1,228 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd2_(integer* nl, integer* nr, integer* sqre, integer* k, doublereal* d, doublereal* z, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* dsigma, doublereal* u2, integer* ldu2, doublereal* vt2, integer* ldvt2, integer* idxp, integer* idx, integer* idxc, integer* idxq, integer* coltyp, integer* info);
+
+
+static VALUE
+rblapack_dlasd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_dsigma;
+ doublereal *dsigma;
+ VALUE rblapack_u2;
+ doublereal *u2;
+ VALUE rblapack_vt2;
+ doublereal *vt2;
+ VALUE rblapack_idxc;
+ integer *idxc;
+ VALUE rblapack_coltyp;
+ integer *coltyp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_u_out__;
+ doublereal *u_out__;
+ VALUE rblapack_vt_out__;
+ doublereal *vt_out__;
+ VALUE rblapack_idxq_out__;
+ integer *idxq_out__;
+ integer *idxp;
+ integer *idx;
+
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+ integer ldu2;
+ integer ldvt2;
+
+ 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 k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.dlasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* DLASD2 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* singular values are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n* DLASD2 is called from DLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) DOUBLE PRECISION array, dimension(N)\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) DOUBLE PRECISION array, dimension(N)\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ALPHA (input) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n* On entry U contains the left singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL, NL), and (NL+2, NL+2), (N,N).\n* On exit U contains the trailing (N-K) updated left singular\n* vectors (those which were deflated) in its last N-K columns.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n* On entry VT' contains the right singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n* On exit VT' contains the trailing (N-K) updated right singular\n* vectors (those which were deflated) in its last N-K columns.\n* In case SQRE =1, the last row of VT spans the right null\n* space.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= M.\n*\n* DSIGMA (output) DOUBLE PRECISION array, dimension (N)\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N)\n* Contains a copy of the first K-1 left singular vectors which\n* will be used by DLASD3 in a matrix multiply (DGEMM) to solve\n* for the new left singular vectors. U2 is arranged into four\n* blocks. The first block contains a column with 1 at NL+1 and\n* zero everywhere else; the second block contains non-zero\n* entries only at and above NL; the third contains non-zero\n* entries only below NL+1; and the fourth is dense.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N)\n* VT2' contains a copy of the first K right singular vectors\n* which will be used by DLASD3 in a matrix multiply (DGEMM) to\n* solve for the new right singular vectors. VT2 is arranged into\n* three blocks. The first block contains a row that corresponds\n* to the special 0 diagonal element in SIGMA; the second block\n* contains non-zeros only at and before NL +1; the third block\n* contains non-zeros only at and after NL +2.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= M.\n*\n* IDXP (workspace) INTEGER array dimension(N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDX (workspace) INTEGER array dimension(N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXC (output) INTEGER array dimension(N)\n* This will contain the permutation used to arrange the columns\n* of the deflated U matrix into three groups: the first group\n* contains non-zero entries only at and above NL, the second\n* contains non-zero entries only below NL+2, and the third is\n* dense.\n*\n* IDXQ (input/output) INTEGER array dimension(N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first hlaf of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* COLTYP (workspace/output) INTEGER array dimension(N)\n* As workspace, this will contain a label which will indicate\n* which of the following types a column in the U2 matrix or a\n* row in the VT2 matrix is:\n* 1 : non-zero in the upper half only\n* 2 : non-zero in the lower half only\n* 3 : dense\n* 4 : deflated\n*\n* On exit, it is an array of dimension 4, with COLTYP(I) being\n* the dimension of the I-th type columns.\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* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.dlasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_nl = argv[0];
+ rblapack_nr = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_d = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_u = argv[6];
+ rblapack_vt = argv[7];
+ rblapack_idxq = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nl = NUM2INT(rblapack_nl);
+ sqre = NUM2INT(rblapack_sqre);
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (7th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ n = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ if (!NA_IsNArray(rblapack_idxq))
+ rb_raise(rb_eArgError, "idxq (9th argument) must be NArray");
+ if (NA_RANK(rblapack_idxq) != 1)
+ rb_raise(rb_eArgError, "rank of idxq (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_idxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 1 of u");
+ if (NA_TYPE(rblapack_idxq) != NA_LINT)
+ rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ nr = NUM2INT(rblapack_nr);
+ beta = NUM2DBL(rblapack_beta);
+ 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 1 of u");
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ ldu2 = n;
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ m = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ ldvt2 = m;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu2;
+ shape[1] = n;
+ rblapack_u2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvt2;
+ shape[1] = n;
+ rblapack_vt2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt2 = NA_PTR_TYPE(rblapack_vt2, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxc = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
+ MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
+ MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxq_out__ = NA_PTR_TYPE(rblapack_idxq_out__, integer*);
+ MEMCPY(idxq_out__, idxq, integer, NA_TOTAL(rblapack_idxq));
+ rblapack_idxq = rblapack_idxq_out__;
+ idxq = idxq_out__;
+ idxp = ALLOC_N(integer, (n));
+ idx = ALLOC_N(integer, (n));
+
+ dlasd2_(&nl, &nr, &sqre, &k, d, z, &alpha, &beta, u, &ldu, vt, &ldvt, dsigma, u2, &ldu2, vt2, &ldvt2, idxp, idx, idxc, idxq, coltyp, &info);
+
+ free(idxp);
+ free(idx);
+ rblapack_k = INT2NUM(k);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_u2, rblapack_vt2, rblapack_idxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_u, rblapack_vt, rblapack_idxq);
+}
+
+void
+init_lapack_dlasd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd2", rblapack_dlasd2, -1);
+}
diff --git a/ext/dlasd3.c b/ext/dlasd3.c
new file mode 100644
index 0000000..1edc9cd
--- /dev/null
+++ b/ext/dlasd3.c
@@ -0,0 +1,202 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd3_(integer* nl, integer* nr, integer* sqre, integer* k, doublereal* d, doublereal* q, integer* ldq, doublereal* dsigma, doublereal* u, integer* ldu, doublereal* u2, integer* ldu2, doublereal* vt, integer* ldvt, doublereal* vt2, integer* ldvt2, integer* idxc, integer* ctot, doublereal* z, integer* info);
+
+
+static VALUE
+rblapack_dlasd3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_dsigma;
+ doublereal *dsigma;
+ VALUE rblapack_u2;
+ doublereal *u2;
+ VALUE rblapack_vt2;
+ doublereal *vt2;
+ VALUE rblapack_idxc;
+ integer *idxc;
+ VALUE rblapack_ctot;
+ integer *ctot;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_u2_out__;
+ doublereal *u2_out__;
+ VALUE rblapack_vt2_out__;
+ doublereal *vt2_out__;
+ doublereal *q;
+
+ integer k;
+ integer ldu2;
+ integer n;
+ integer ldvt2;
+ integer ldu;
+ integer ldvt;
+ integer m;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, u, vt, info, u2, vt2 = NumRu::Lapack.dlasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n* Purpose\n* =======\n*\n* DLASD3 finds all the square roots of the roots of the secular\n* equation, as defined by the values in D and Z. It makes the\n* appropriate calls to DLASD4 and then updates the singular\n* vectors by matrix multiplication.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* DLASD3 is called from DLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (input) INTEGER\n* The size of the secular equation, 1 =< K = < N.\n*\n* D (output) DOUBLE PRECISION array, dimension(K)\n* On exit the square roots of the roots of the secular equation,\n* in ascending order.\n*\n* Q (workspace) DOUBLE PRECISION array,\n* dimension at least (LDQ,K).\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= K.\n*\n* DSIGMA (input) DOUBLE PRECISION array, dimension(K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* U (output) DOUBLE PRECISION array, dimension (LDU, N)\n* The last N - K columns of this matrix contain the deflated\n* left singular vectors.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N)\n* The first K columns of this matrix contain the non-deflated\n* left singular vectors for the split problem.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT (output) DOUBLE PRECISION array, dimension (LDVT, M)\n* The last M - K columns of VT' contain the deflated\n* right singular vectors.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= N.\n*\n* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)\n* The first K columns of VT2' contain the non-deflated\n* right singular vectors for the split problem.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= N.\n*\n* IDXC (input) INTEGER array, dimension ( N )\n* The permutation used to arrange the columns of U (and rows of\n* VT) into three groups: the first group contains non-zero\n* entries only at and above (or before) NL +1; the second\n* contains non-zero entries only at and below (or after) NL+2;\n* and the third is dense. The first column of U and the row of\n* VT are treated separately, however.\n*\n* The rows of the singular vectors found by DLASD4\n* must be likewise permuted before the matrix multiplies can\n* take place.\n*\n* CTOT (input) INTEGER array, dimension ( 4 )\n* A count of the total number of the various types of columns\n* in U (or rows in VT), as described in IDXC. The fourth column\n* type is any column which has been deflated.\n*\n* Z (input) DOUBLE PRECISION array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, u, vt, info, u2, vt2 = NumRu::Lapack.dlasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_nl = argv[0];
+ rblapack_nr = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_dsigma = argv[3];
+ rblapack_u2 = argv[4];
+ rblapack_vt2 = argv[5];
+ rblapack_idxc = argv[6];
+ rblapack_ctot = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nl = NUM2INT(rblapack_nl);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_ctot))
+ rb_raise(rb_eArgError, "ctot (8th argument) must be NArray");
+ if (NA_RANK(rblapack_ctot) != 1)
+ rb_raise(rb_eArgError, "rank of ctot (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ctot) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
+ if (NA_TYPE(rblapack_ctot) != NA_LINT)
+ rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
+ ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
+ nr = NUM2INT(rblapack_nr);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ n = nl + nr + 1;
+ ldvt = n;
+ ldu = n;
+ if (!NA_IsNArray(rblapack_dsigma))
+ rb_raise(rb_eArgError, "dsigma (4th argument) must be NArray");
+ if (NA_RANK(rblapack_dsigma) != 1)
+ rb_raise(rb_eArgError, "rank of dsigma (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dsigma) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of z");
+ if (NA_TYPE(rblapack_dsigma) != NA_DFLOAT)
+ rblapack_dsigma = na_change_type(rblapack_dsigma, NA_DFLOAT);
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
+ if (!NA_IsNArray(rblapack_idxc))
+ rb_raise(rb_eArgError, "idxc (7th argument) must be NArray");
+ if (NA_RANK(rblapack_idxc) != 1)
+ rb_raise(rb_eArgError, "rank of idxc (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_idxc) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of idxc must be nl + nr + 1");
+ if (NA_TYPE(rblapack_idxc) != NA_LINT)
+ rblapack_idxc = na_change_type(rblapack_idxc, NA_LINT);
+ idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
+ ldq = k;
+ ldvt2 = n;
+ if (!NA_IsNArray(rblapack_vt2))
+ rb_raise(rb_eArgError, "vt2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vt2) != 2)
+ rb_raise(rb_eArgError, "rank of vt2 (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_vt2) != ldvt2)
+ rb_raise(rb_eRuntimeError, "shape 0 of vt2 must be n");
+ if (NA_SHAPE1(rblapack_vt2) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of vt2 must be nl + nr + 1");
+ if (NA_TYPE(rblapack_vt2) != NA_DFLOAT)
+ rblapack_vt2 = na_change_type(rblapack_vt2, NA_DFLOAT);
+ vt2 = NA_PTR_TYPE(rblapack_vt2, doublereal*);
+ ldu2 = n;
+ if (!NA_IsNArray(rblapack_u2))
+ rb_raise(rb_eArgError, "u2 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_u2) != 2)
+ rb_raise(rb_eArgError, "rank of u2 (5th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_u2) != ldu2)
+ rb_raise(rb_eRuntimeError, "shape 0 of u2 must be n");
+ if (NA_SHAPE1(rblapack_u2) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of u2 must be nl + nr + 1");
+ if (NA_TYPE(rblapack_u2) != NA_DFLOAT)
+ rblapack_u2 = na_change_type(rblapack_u2, NA_DFLOAT);
+ u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
+ m = n + sqre;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu2;
+ shape[1] = n;
+ rblapack_u2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, doublereal*);
+ MEMCPY(u2_out__, u2, doublereal, NA_TOTAL(rblapack_u2));
+ rblapack_u2 = rblapack_u2_out__;
+ u2 = u2_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt2;
+ shape[1] = n;
+ rblapack_vt2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt2_out__ = NA_PTR_TYPE(rblapack_vt2_out__, doublereal*);
+ MEMCPY(vt2_out__, vt2, doublereal, NA_TOTAL(rblapack_vt2));
+ rblapack_vt2 = rblapack_vt2_out__;
+ vt2 = vt2_out__;
+ q = ALLOC_N(doublereal, (ldq)*(k));
+
+ dlasd3_(&nl, &nr, &sqre, &k, d, q, &ldq, dsigma, u, &ldu, u2, &ldu2, vt, &ldvt, vt2, &ldvt2, idxc, ctot, z, &info);
+
+ free(q);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_u, rblapack_vt, rblapack_info, rblapack_u2, rblapack_vt2);
+}
+
+void
+init_lapack_dlasd3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd3", rblapack_dlasd3, -1);
+}
diff --git a/ext/dlasd4.c b/ext/dlasd4.c
new file mode 100644
index 0000000..e1d81df
--- /dev/null
+++ b/ext/dlasd4.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd4_(integer* n, integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* sigma, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlasd4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_delta;
+ doublereal *delta;
+ VALUE rblapack_sigma;
+ doublereal sigma;
+ VALUE rblapack_info;
+ integer info;
+ 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 delta, sigma, info = NumRu::Lapack.dlasd4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th updated\n* eigenvalue of a positive symmetric rank-one modification to\n* a positive diagonal matrix whose entries are given as the squares\n* of the corresponding entries in the array d, and that\n*\n* 0 <= D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) * diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) DOUBLE PRECISION array, dimension ( N )\n* The original eigenvalues. It is assumed that they are in\n* order, 0 <= D(I) < D(J) for I < J.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( N )\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension ( N )\n* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. The vector DELTA\n* contains the information necessary to construct the\n* (singular) eigenvectors.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* SIGMA (output) DOUBLE PRECISION\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( N )\n* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th\n* component. If N = 1, then WORK( 1 ) = 1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, sigma, info = NumRu::Lapack.dlasd4( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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*);
+ rho = NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, doublereal*);
+ work = ALLOC_N(doublereal, (n));
+
+ dlasd4_(&n, &i, d, z, delta, &rho, &sigma, work, &info);
+
+ free(work);
+ rblapack_sigma = rb_float_new((double)sigma);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_delta, rblapack_sigma, rblapack_info);
+}
+
+void
+init_lapack_dlasd4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd4", rblapack_dlasd4, -1);
+}
diff --git a/ext/dlasd5.c b/ext/dlasd5.c
new file mode 100644
index 0000000..30e4580
--- /dev/null
+++ b/ext/dlasd5.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd5_(integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* dsigma, doublereal* work);
+
+
+static VALUE
+rblapack_dlasd5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_delta;
+ doublereal *delta;
+ VALUE rblapack_dsigma;
+ doublereal dsigma;
+ doublereal *work;
+
+
+ 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 delta, dsigma = NumRu::Lapack.dlasd5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th eigenvalue\n* of a positive symmetric rank-one modification of a 2-by-2 diagonal\n* matrix\n*\n* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal entries in the array D are assumed to satisfy\n*\n* 0 <= D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) DOUBLE PRECISION array, dimension ( 2 )\n* The original eigenvalues. We assume 0 <= D(1) < D(2).\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 2 )\n* The components of the updating vector.\n*\n* DELTA (output) DOUBLE PRECISION array, dimension ( 2 )\n* Contains (D(j) - sigma_I) in its j-th component.\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) DOUBLE PRECISION\n* The scalar in the symmetric updating formula.\n*\n* DSIGMA (output) DOUBLE PRECISION\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 )\n* WORK contains (D(j) + sigma_I) in its j-th component.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, dsigma = NumRu::Lapack.dlasd5( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_d) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ rho = NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, doublereal*);
+ work = ALLOC_N(doublereal, (2));
+
+ dlasd5_(&i, d, z, delta, &rho, &dsigma, work);
+
+ free(work);
+ rblapack_dsigma = rb_float_new((double)dsigma);
+ return rb_ary_new3(2, rblapack_delta, rblapack_dsigma);
+}
+
+void
+init_lapack_dlasd5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd5", rblapack_dlasd5, -1);
+}
diff --git a/ext/dlasd6.c b/ext/dlasd6.c
new file mode 100644
index 0000000..5e5e548
--- /dev/null
+++ b/ext/dlasd6.c
@@ -0,0 +1,236 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd6_(integer* icompq, integer* nl, integer* nr, integer* sqre, doublereal* d, doublereal* vf, doublereal* vl, doublereal* alpha, doublereal* beta, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* poles, doublereal* difl, doublereal* difr, doublereal* z, integer* k, doublereal* c, doublereal* s, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlasd6(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_vf;
+ doublereal *vf;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_poles;
+ doublereal *poles;
+ VALUE rblapack_difl;
+ doublereal *difl;
+ VALUE rblapack_difr;
+ doublereal *difr;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_s;
+ doublereal s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_vf_out__;
+ doublereal *vf_out__;
+ VALUE rblapack_vl_out__;
+ doublereal *vl_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer m;
+ integer n;
+ integer ldgcol;
+ integer ldgnum;
+
+ 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 idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASD6 computes the SVD of an updated upper bidiagonal matrix B\n* obtained by merging two smaller ones by appending a row. This\n* routine is used only for the problem which requires all singular\n* values and optionally singular vector matrices in factored form.\n* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n* A related subroutine, DLASD1, handles the case in which all singular\n* values and singular vectors of the bidiagonal matrix are desired.\n*\n* DLASD6 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The singular values of B can be computed using D1, D2, the first\n* components of all the right singular vectors of the lower block, and\n* the last components of all the right singular vectors of the upper\n* block. These components are stored and updated in VF and VL,\n* respectively, in DLASD6. Hence U and VT are not explicitly\n* referenced.\n*\n* The singular values are stored in D. The algorithm consists of two\n* stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or if there is a zero\n* in the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLASD7.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the roots of the\n* secular equation via the routine DLASD4 (as called by DLASD8).\n* This routine also updates VF and VL and computes the distances\n* between the updated singular values and the old singular\n* values.\n*\n* DLASD6 is called from DLASDA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block, and D(NL+2:N) contains the singular values\n* of the lower block. On exit D(1:N) contains the singular\n* values of the modified matrix.\n*\n* VF (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors of\n* the lower block. On exit, VL contains the last components of\n* all right singular vectors of the bidiagonal matrix.\n*\n* ALPHA (input/output) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* IDXQ (output) INTEGER array, dimension ( N )\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM and POLES, must be at least N.\n*\n* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* On exit, POLES(1,*) is an array containing the new singular\n* values obtained from solving the secular equation, and\n* POLES(2,*) is an array containing the poles in the secular\n* equation. Not referenced if ICOMPQ = 0.\n*\n* DIFL (output) DOUBLE PRECISION array, dimension ( N )\n* On exit, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (output) DOUBLE PRECISION array,\n* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* On exit, DIFR(I, 1) is the distance between I-th updated\n* (undeflated) singular value and the I+1-th (undeflated) old\n* singular value.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* See DLASD8 for details on DIFL and DIFR.\n*\n* Z (output) DOUBLE PRECISION array, dimension ( M )\n* The first elements of this array contain the components\n* of the deflation-adjusted updating row vector.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (output) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M )\n*\n* IWORK (workspace) INTEGER array, dimension ( 3 * N )\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_d = argv[4];
+ rblapack_vf = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_alpha = argv[7];
+ rblapack_beta = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ alpha = NUM2DBL(rblapack_alpha);
+ nl = NUM2INT(rblapack_nl);
+ 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);
+ if (NA_SHAPE0(rblapack_d) != (nl+nr+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ beta = NUM2DBL(rblapack_beta);
+ n = nl + nr + 1;
+ ldgcol = n;
+ sqre = NUM2INT(rblapack_sqre);
+ m = n + sqre;
+ if (!NA_IsNArray(rblapack_vf))
+ rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vf) != 1)
+ rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vf) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of vf must be n + sqre");
+ if (NA_TYPE(rblapack_vf) != NA_DFLOAT)
+ rblapack_vf = na_change_type(rblapack_vf, NA_DFLOAT);
+ vf = NA_PTR_TYPE(rblapack_vf, doublereal*);
+ ldgnum = n;
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 1)
+ rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vl) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of vl must be n + sqre");
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = 2;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgnum;
+ shape[1] = 2;
+ rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldgnum;
+ shape[1] = 2;
+ rblapack_poles = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? ldgnum : icompq == 0 ? n : 0;
+ shape[1] = icompq == 1 ? 2 : 0;
+ rblapack_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nl+nr+1;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, doublereal*);
+ MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rblapack_vf));
+ rblapack_vf = rblapack_vf_out__;
+ vf = vf_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
+ MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ work = ALLOC_N(doublereal, (4 * m));
+ iwork = ALLOC_N(integer, (3 * n));
+
+ dlasd6_(&icompq, &nl, &nr, &sqre, d, vf, vl, &alpha, &beta, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_k = INT2NUM(k);
+ rblapack_c = rb_float_new((double)c);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_info = INT2NUM(info);
+ rblapack_alpha = rb_float_new((double)alpha);
+ rblapack_beta = rb_float_new((double)beta);
+ return rb_ary_new3(18, rblapack_idxq, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_poles, rblapack_difl, rblapack_difr, rblapack_z, rblapack_k, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl, rblapack_alpha, rblapack_beta);
+}
+
+void
+init_lapack_dlasd6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd6", rblapack_dlasd6, -1);
+}
diff --git a/ext/dlasd7.c b/ext/dlasd7.c
new file mode 100644
index 0000000..622f4ea
--- /dev/null
+++ b/ext/dlasd7.c
@@ -0,0 +1,225 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd7_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* k, doublereal* d, doublereal* z, doublereal* zw, doublereal* vf, doublereal* vfw, doublereal* vl, doublereal* vlw, doublereal* alpha, doublereal* beta, doublereal* dsigma, integer* idx, integer* idxp, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* c, doublereal* s, integer* info);
+
+
+static VALUE
+rblapack_dlasd7(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_vf;
+ doublereal *vf;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_dsigma;
+ doublereal *dsigma;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_s;
+ doublereal s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_vf_out__;
+ doublereal *vf_out__;
+ VALUE rblapack_vl_out__;
+ doublereal *vl_out__;
+ doublereal *zw;
+ doublereal *vfw;
+ doublereal *vlw;
+ integer *idx;
+ integer *idxp;
+
+ integer n;
+ integer m;
+ integer ldgcol;
+ integer ldgnum;
+
+ 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 k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.dlasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n* Purpose\n* =======\n*\n* DLASD7 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem. There\n* are two ways in which deflation can occur: when two or more singular\n* values are close together or if there is a tiny entry in the Z\n* vector. For each such occurrence the order of the related\n* secular equation problem is reduced by one.\n*\n* DLASD7 is called from DLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper\n* bidiagonal matrix in compact form.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix, this is\n* the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) DOUBLE PRECISION array, dimension ( N )\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) DOUBLE PRECISION array, dimension ( M )\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ZW (workspace) DOUBLE PRECISION array, dimension ( M )\n* Workspace for Z.\n*\n* VF (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VFW (workspace) DOUBLE PRECISION array, dimension ( M )\n* Workspace for VF.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension ( M )\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors\n* of the lower block. On exit, VL contains the last components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VLW (workspace) DOUBLE PRECISION array, dimension ( M )\n* Workspace for VL.\n*\n* ALPHA (input) DOUBLE PRECISION\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) DOUBLE PRECISION\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* DSIGMA (output) DOUBLE PRECISION array, dimension ( N )\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* IDX (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXP (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDXQ (input) INTEGER array, dimension ( N )\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first half of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each singular block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM, must be at least N.\n*\n* C (output) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.dlasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_d = argv[4];
+ rblapack_vf = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_alpha = argv[7];
+ rblapack_beta = argv[8];
+ rblapack_idxq = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 1)
+ rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ beta = NUM2DBL(rblapack_beta);
+ nl = NUM2INT(rblapack_nl);
+ if (!NA_IsNArray(rblapack_vf))
+ rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vf) != 1)
+ rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vf) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
+ if (NA_TYPE(rblapack_vf) != NA_DFLOAT)
+ rblapack_vf = na_change_type(rblapack_vf, NA_DFLOAT);
+ vf = NA_PTR_TYPE(rblapack_vf, doublereal*);
+ if (!NA_IsNArray(rblapack_idxq))
+ rb_raise(rb_eArgError, "idxq (10th argument) must be NArray");
+ if (NA_RANK(rblapack_idxq) != 1)
+ rb_raise(rb_eArgError, "rank of idxq (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_idxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_idxq) != NA_LINT)
+ rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ ldgcol = n;
+ sqre = NUM2INT(rblapack_sqre);
+ ldgnum = n;
+ alpha = NUM2DBL(rblapack_alpha);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = 2;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgnum;
+ shape[1] = 2;
+ rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, doublereal*);
+ MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rblapack_vf));
+ rblapack_vf = rblapack_vf_out__;
+ vf = vf_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
+ MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ zw = ALLOC_N(doublereal, (m));
+ vfw = ALLOC_N(doublereal, (m));
+ vlw = ALLOC_N(doublereal, (m));
+ idx = ALLOC_N(integer, (n));
+ idxp = ALLOC_N(integer, (n));
+
+ dlasd7_(&icompq, &nl, &nr, &sqre, &k, d, z, zw, vf, vfw, vl, vlw, &alpha, &beta, dsigma, idx, idxp, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, &c, &s, &info);
+
+ free(zw);
+ free(vfw);
+ free(vlw);
+ free(idx);
+ free(idxp);
+ rblapack_k = INT2NUM(k);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_c = rb_float_new((double)c);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(13, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl);
+}
+
+void
+init_lapack_dlasd7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd7", rblapack_dlasd7, -1);
+}
diff --git a/ext/dlasd8.c b/ext/dlasd8.c
new file mode 100644
index 0000000..cdb1398
--- /dev/null
+++ b/ext/dlasd8.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID dlasd8_(integer* icompq, integer* k, doublereal* d, doublereal* z, doublereal* vf, doublereal* vl, doublereal* difl, doublereal* difr, integer* lddifr, doublereal* dsigma, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlasd8(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_vf;
+ doublereal *vf;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_dsigma;
+ doublereal *dsigma;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_difl;
+ doublereal *difl;
+ VALUE rblapack_difr;
+ doublereal *difr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+ VALUE rblapack_vf_out__;
+ doublereal *vf_out__;
+ VALUE rblapack_vl_out__;
+ doublereal *vl_out__;
+ VALUE rblapack_dsigma_out__;
+ doublereal *dsigma_out__;
+ doublereal *work;
+
+ integer k;
+ integer lddifr;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.dlasd8( icompq, z, vf, vl, dsigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASD8 finds the square roots of the roots of the secular equation,\n* as defined by the values in DSIGMA and Z. It makes the appropriate\n* calls to DLASD4, and stores, for each element in D, the distance\n* to its two nearest poles (elements in DSIGMA). It also updates\n* the arrays VF and VL, the first and last components of all the\n* right singular vectors of the original bidiagonal matrix.\n*\n* DLASD8 is called from DLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form in the calling routine:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved\n* by DLASD4. K >= 1.\n*\n* D (output) DOUBLE PRECISION array, dimension ( K )\n* On output, D contains the updated singular values.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, the first K elements of this array contain the\n* components of the deflation-adjusted updating row vector.\n* On exit, Z is updated.\n*\n* VF (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, VF contains information passed through DBEDE8.\n* On exit, VF contains the first K components of the first\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* VL (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, VL contains information passed through DBEDE8.\n* On exit, VL contains the first K components of the last\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* DIFL (output) DOUBLE PRECISION array, dimension ( K )\n* On exit, DIFL(I) = D(I) - DSIGMA(I).\n*\n* DIFR (output) DOUBLE PRECISION array,\n* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n* dimension ( K ) if ICOMPQ = 0.\n* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n* defined and will not be referenced.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* LDDIFR (input) INTEGER\n* The leading dimension of DIFR, must be at least K.\n*\n* DSIGMA (input/output) DOUBLE PRECISION array, dimension ( K )\n* On entry, the first K elements of this array contain the old\n* roots of the deflated updating problem. These are the poles\n* of the secular equation.\n* On exit, the elements of DSIGMA may be very slightly altered\n* in value.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.dlasd8( icompq, z, vf, vl, dsigma, [: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_icompq = argv[0];
+ rblapack_z = argv[1];
+ rblapack_vf = argv[2];
+ rblapack_vl = argv[3];
+ rblapack_dsigma = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_vf))
+ rb_raise(rb_eArgError, "vf (3th argument) must be NArray");
+ if (NA_RANK(rblapack_vf) != 1)
+ rb_raise(rb_eArgError, "rank of vf (3th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_vf);
+ if (NA_TYPE(rblapack_vf) != NA_DFLOAT)
+ rblapack_vf = na_change_type(rblapack_vf, NA_DFLOAT);
+ vf = NA_PTR_TYPE(rblapack_vf, doublereal*);
+ if (!NA_IsNArray(rblapack_dsigma))
+ rb_raise(rb_eArgError, "dsigma (5th argument) must be NArray");
+ if (NA_RANK(rblapack_dsigma) != 1)
+ rb_raise(rb_eArgError, "rank of dsigma (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dsigma) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of vf");
+ if (NA_TYPE(rblapack_dsigma) != NA_DFLOAT)
+ rblapack_dsigma = na_change_type(rblapack_dsigma, NA_DFLOAT);
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of vf");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (4th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 1)
+ rb_raise(rb_eArgError, "rank of vl (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vl) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of vl must be the same as shape 0 of vf");
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ lddifr = k;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? lddifr : icompq == 0 ? k : 0;
+ shape[1] = icompq == 1 ? 2 : 0;
+ rblapack_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, doublereal*);
+ MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rblapack_vf));
+ rblapack_vf = rblapack_vf_out__;
+ vf = vf_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
+ MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_dsigma_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dsigma_out__ = NA_PTR_TYPE(rblapack_dsigma_out__, doublereal*);
+ MEMCPY(dsigma_out__, dsigma, doublereal, NA_TOTAL(rblapack_dsigma));
+ rblapack_dsigma = rblapack_dsigma_out__;
+ dsigma = dsigma_out__;
+ work = ALLOC_N(doublereal, (3 * k));
+
+ dlasd8_(&icompq, &k, d, z, vf, vl, difl, difr, &lddifr, dsigma, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_d, rblapack_difl, rblapack_difr, rblapack_info, rblapack_z, rblapack_vf, rblapack_vl, rblapack_dsigma);
+}
+
+void
+init_lapack_dlasd8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasd8", rblapack_dlasd8, -1);
+}
diff --git a/ext/dlasda.c b/ext/dlasda.c
new file mode 100644
index 0000000..88e9ab9
--- /dev/null
+++ b/ext/dlasda.c
@@ -0,0 +1,221 @@
+#include "rb_lapack.h"
+
+extern VOID dlasda_(integer* icompq, integer* smlsiz, integer* n, integer* sqre, doublereal* d, doublereal* e, doublereal* u, integer* ldu, doublereal* vt, integer* k, doublereal* difl, doublereal* difr, doublereal* z, doublereal* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, doublereal* givnum, doublereal* c, doublereal* s, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dlasda(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_difl;
+ doublereal *difl;
+ VALUE rblapack_difr;
+ doublereal *difr;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_poles;
+ doublereal *poles;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldu;
+ integer nlvl;
+ integer ldgcol;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.dlasda( icompq, smlsiz, sqre, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, DLASDA computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n* B with diagonal D and offdiagonal E, where M = N + SQRE. The\n* algorithm computes the singular values in the SVD B = U * S * VT.\n* The orthogonal matrices U and VT are optionally computed in\n* compact form.\n*\n* A related subroutine, DLASD0, computes the singular values and\n* the singular vectors in explicit form.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper bidiagonal\n* matrix in compact form.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row dimension of the upper bidiagonal matrix. This is\n* also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N + 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension ( N )\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) DOUBLE PRECISION array, dimension ( M-1 )\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) DOUBLE PRECISION array,\n* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n* GIVNUM, and Z.\n*\n* VT (output) DOUBLE PRECISION array,\n* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* K (output) INTEGER array,\n* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n* secular equation on the computation tree.\n*\n* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),\n* where NLVL = floor(log_2 (N/SMLSIZ))).\n*\n* DIFR (output) DOUBLE PRECISION array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n* record distances between singular values on the I-th\n* level and singular values on the (I -1)-th level, and\n* DIFR(1:N, 2 * I ) contains the normalizing factors for\n* the right singular vector matrix. See DLASD8 for details.\n*\n* Z (output) DOUBLE PRECISION array,\n* dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* The first K elements of Z(1, I) contain the components of\n* the deflation-adjusted updating row vector for subproblems\n* on the I-th level.\n*\n* POLES (output) DOUBLE PRECISION array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n* POLES(1, 2*I) contain the new and old singular values\n* involved in the secular equations on the I-th level.\n*\n* GIVPTR (output) INTEGER array,\n* dimension ( N ) if ICOMPQ = 1, and not referenced if\n* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n* the number of Givens rotations performed on the I-th\n* problem on the computation tree.\n*\n* GIVCOL (output) INTEGER array,\n* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n* of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (output) INTEGER array,\n* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n* permutations done on the I-th level of the computation tree.\n*\n* GIVNUM (output) DOUBLE PRECISION array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n* values of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* C (output) DOUBLE PRECISION array,\n* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (output) DOUBLE PRECISION array, dimension ( N ) if\n* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n* and the I-th subproblem is not square, on exit, S( I )\n* contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n*\n* IWORK (workspace) INTEGER array.\n* Dimension must be at least (7 * N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.dlasda( icompq, smlsiz, sqre, d, e, [: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_icompq = argv[0];
+ rblapack_smlsiz = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ sqre = NUM2INT(rblapack_sqre);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
+ nlvl = floor(1.0/log(2.0)*log((double)n/smlsiz));
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ ldgcol = n;
+ ldu = n;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = MAX(1,smlsiz);
+ rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = smlsiz+1;
+ rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ {
+ int shape[1];
+ shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
+ rblapack_k = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = nlvl;
+ rblapack_difl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
+ shape[1] = icompq == 1 ? 2 * nlvl : 0;
+ rblapack_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
+ shape[1] = icompq == 1 ? nlvl : 0;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = 2 * nlvl;
+ rblapack_poles = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_givptr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = 2 * nlvl;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = nlvl;
+ rblapack_perm = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = 2 * nlvl;
+ rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ {
+ int shape[1];
+ shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int shape[1];
+ shape[0] = icompq==1 ? n : icompq==0 ? 1 : 0;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ work = ALLOC_N(doublereal, (6 * n + (smlsiz + 1)*(smlsiz + 1)));
+ iwork = ALLOC_N(integer, ((7 * n)));
+
+ dlasda_(&icompq, &smlsiz, &n, &sqre, d, e, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(15, rblapack_u, rblapack_vt, rblapack_k, rblapack_difl, rblapack_difr, rblapack_z, rblapack_poles, rblapack_givptr, rblapack_givcol, rblapack_perm, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d);
+}
+
+void
+init_lapack_dlasda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasda", rblapack_dlasda, -1);
+}
diff --git a/ext/dlasdq.c b/ext/dlasdq.c
new file mode 100644
index 0000000..207161a
--- /dev/null
+++ b/ext/dlasdq.c
@@ -0,0 +1,186 @@
+#include "rb_lapack.h"
+
+extern VOID dlasdq_(char* uplo, integer* sqre, integer* n, integer* ncvt, integer* nru, integer* ncc, doublereal* d, doublereal* e, doublereal* vt, integer* ldvt, doublereal* u, integer* ldu, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlasdq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_nru;
+ integer nru;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_vt_out__;
+ doublereal *vt_out__;
+ VALUE rblapack_u_out__;
+ doublereal *u_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldvt;
+ integer ncvt;
+ integer ldu;
+ integer ldc;
+ integer ncc;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.dlasdq( uplo, sqre, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASDQ computes the singular value decomposition (SVD) of a real\n* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n* E, accumulating the transformations if desired. Letting B denote\n* the input bidiagonal matrix, the algorithm computes orthogonal\n* matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n* of P). The singular values S are overwritten on D.\n*\n* The input matrix U is changed to U * Q if desired.\n* The input matrix VT is changed to P' * VT if desired.\n* The input matrix C is changed to Q' * C if desired.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3, for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the input bidiagonal matrix\n* is upper or lower bidiagonal, and wether it is square are\n* not.\n* UPLO = 'U' or 'u' B is upper bidiagonal.\n* UPLO = 'L' or 'l' B is lower bidiagonal.\n*\n* SQRE (input) INTEGER\n* = 0: then the input matrix is N-by-N.\n* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n* (N+1)-by-N if UPLU = 'L'.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of rows and columns\n* in the matrix. N must be at least 0.\n*\n* NCVT (input) INTEGER\n* On entry, NCVT specifies the number of columns of\n* the matrix VT. NCVT must be at least 0.\n*\n* NRU (input) INTEGER\n* On entry, NRU specifies the number of rows of\n* the matrix U. NRU must be at least 0.\n*\n* NCC (input) INTEGER\n* On entry, NCC specifies the number of columns of\n* the matrix C. NCC must be at least 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the diagonal entries of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array.\n* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n* On entry, the entries of E contain the offdiagonal entries\n* of the bidiagonal matrix whose SVD is desired. On normal\n* exit, E will contain 0. If the algorithm does not converge,\n* D and E will contain the diagonal and superdiagonal entries\n* of a bidiagonal matrix orthogonally equivalent to the one\n* given as input.\n*\n* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n* On entry, contains a matrix which on exit has been\n* premultiplied by P', dimension N-by-NCVT if SQRE = 0\n* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n*\n* LDVT (input) INTEGER\n* On entry, LDVT specifies the leading dimension of VT as\n* declared in the calling (sub) program. LDVT must be at\n* least 1. If NCVT is nonzero LDVT must also be at least N.\n*\n* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n* On entry, contains a matrix which on exit has been\n* postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n*\n* LDU (input) INTEGER\n* On entry, LDU specifies the leading dimension of U as\n* declared in the calling (sub) program. LDU must be at\n* least max( 1, NRU ) .\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n* On entry, contains an N-by-NCC matrix which on exit\n* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0\n* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n*\n* LDC (input) INTEGER\n* On entry, LDC specifies the leading dimension of C as\n* declared in the calling (sub) program. LDC must be at\n* least 1. If NCC is nonzero, LDC must also be at least N.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n* Workspace. Only referenced if one of NCVT, NRU, or NCC is\n* nonzero, and if N is at least 2.\n*\n* INFO (output) INTEGER\n* On exit, a value of 0 indicates a successful exit.\n* If INFO < 0, argument number -INFO is illegal.\n* If INFO > 0, the algorithm did not converge, and INFO\n* specifies how many superdiagonals did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.dlasdq( uplo, sqre, nru, d, e, vt, u, c, [: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_uplo = argv[0];
+ rblapack_sqre = argv[1];
+ rblapack_nru = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e = argv[4];
+ rblapack_vt = argv[5];
+ rblapack_u = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ nru = NUM2INT(rblapack_nru);
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (6th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ ncvt = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (7th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ n = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ if (!NA_IsNArray(rblapack_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 1 of u");
+ 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_e))
+ rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (sqre==0 ? n-1 : sqre==1 ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", sqre==0 ? n-1 : sqre==1 ? n : 0);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = sqre==0 ? n-1 : sqre==1 ? n : 0;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = ncvt;
+ rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
+ MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
+ MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+ MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublereal, (4*n));
+
+ dlasdq_(&uplo, &sqre, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
+}
+
+void
+init_lapack_dlasdq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasdq", rblapack_dlasdq, -1);
+}
diff --git a/ext/dlasdt.c b/ext/dlasdt.c
new file mode 100644
index 0000000..42c8484
--- /dev/null
+++ b/ext/dlasdt.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dlasdt_(integer* n, integer* lvl, integer* nd, integer* inode, integer* ndiml, integer* ndimr, integer* msub);
+
+
+static VALUE
+rblapack_dlasdt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_msub;
+ integer msub;
+ VALUE rblapack_lvl;
+ integer lvl;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_inode;
+ integer *inode;
+ VALUE rblapack_ndiml;
+ integer *ndiml;
+ VALUE rblapack_ndimr;
+ integer *ndimr;
+
+
+ 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 lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.dlasdt( n, msub, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n* Purpose\n* =======\n*\n* DLASDT creates a tree of subproblems for bidiagonal divide and\n* conquer.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the number of diagonal elements of the\n* bidiagonal matrix.\n*\n* LVL (output) INTEGER\n* On exit, the number of levels on the computation tree.\n*\n* ND (output) INTEGER\n* On exit, the number of nodes on the tree.\n*\n* INODE (output) INTEGER array, dimension ( N )\n* On exit, centers of subproblems.\n*\n* NDIML (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of left children.\n*\n* NDIMR (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of right children.\n*\n* MSUB (input) INTEGER\n* On entry, the maximum row dimension each subproblem at the\n* bottom of the tree can be of.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.dlasdt( n, msub, [: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_n = argv[0];
+ rblapack_msub = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ msub = NUM2INT(rblapack_msub);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_inode = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ inode = NA_PTR_TYPE(rblapack_inode, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_ndiml = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ndiml = NA_PTR_TYPE(rblapack_ndiml, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_ndimr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ndimr = NA_PTR_TYPE(rblapack_ndimr, integer*);
+
+ dlasdt_(&n, &lvl, &nd, inode, ndiml, ndimr, &msub);
+
+ rblapack_lvl = INT2NUM(lvl);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(5, rblapack_lvl, rblapack_nd, rblapack_inode, rblapack_ndiml, rblapack_ndimr);
+}
+
+void
+init_lapack_dlasdt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasdt", rblapack_dlasdt, -1);
+}
diff --git a/ext/dlaset.c b/ext/dlaset.c
new file mode 100644
index 0000000..c052974
--- /dev/null
+++ b/ext/dlaset.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID dlaset_(char* uplo, integer* m, integer* n, doublereal* alpha, doublereal* beta, doublereal* a, integer* lda);
+
+
+static VALUE
+rblapack_dlaset(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_a;
+ doublereal *a;
+ 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 a = NumRu::Lapack.dlaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* DLASET initializes an m-by-n matrix A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set; the strictly lower\n* triangular part of A is not changed.\n* = 'L': Lower triangular part is set; the strictly upper\n* triangular part of A is not changed.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* ALPHA (input) DOUBLE PRECISION\n* The constant to which the offdiagonal elements are to be set.\n*\n* BETA (input) DOUBLE PRECISION\n* The constant to which the diagonal elements are to be set.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the leading m-by-n submatrix of A is set as follows:\n*\n* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n*\n* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.dlaset( uplo, m, alpha, beta, a, [: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_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_beta = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ m = NUM2INT(rblapack_m);
+ beta = NUM2DBL(rblapack_beta);
+ {
+ int 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__;
+
+ dlaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_dlaset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaset", rblapack_dlaset, -1);
+}
diff --git a/ext/dlasq1.c b/ext/dlasq1.c
new file mode 100644
index 0000000..9a955bc
--- /dev/null
+++ b/ext/dlasq1.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID dlasq1_(integer* n, doublereal* d, doublereal* e, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dlasq1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_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 info, d, e = NumRu::Lapack.dlasq1( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ1( N, D, E, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DLASQ1 computes the singular values of a real N-by-N bidiagonal\n* matrix with diagonal D and off-diagonal E. The singular values\n* are computed to high relative accuracy, in the absence of\n* denormalization, underflow and overflow. The algorithm was first\n* presented in\n*\n* \"Accurate singular values and differential qd algorithms\" by K. V.\n* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n* 1994,\n*\n* and the present implementation is described in \"An implementation of\n* the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the diagonal elements of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in decreasing order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, elements E(1:N-1) contain the off-diagonal elements\n* of the bidiagonal matrix whose SVD is desired.\n* On exit, E is overwritten.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.dlasq1( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(doublereal, (4*n));
+
+ dlasq1_(&n, d, e, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dlasq1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasq1", rblapack_dlasq1, -1);
+}
diff --git a/ext/dlasq2.c b/ext/dlasq2.c
new file mode 100644
index 0000000..8e3b18a
--- /dev/null
+++ b/ext/dlasq2.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID dlasq2_(integer* n, doublereal* z, integer* info);
+
+
+static VALUE
+rblapack_dlasq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_z_out__;
+ doublereal *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 info, z = NumRu::Lapack.dlasq2( n, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ2( N, Z, INFO )\n\n* Purpose\n* =======\n*\n* DLASQ2 computes all the eigenvalues of the symmetric positive \n* definite tridiagonal matrix associated with the qd array Z to high\n* relative accuracy are computed to high relative accuracy, in the\n* absence of denormalization, underflow and overflow.\n*\n* To see the relation of Z to the tridiagonal matrix, let L be a\n* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n* let U be an upper bidiagonal matrix with 1's above and diagonal\n* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n* symmetric tridiagonal to which it is similar.\n*\n* Note : DLASQ2 defines a logical variable, IEEE, which is true\n* on machines which follow ieee-754 floating-point standard in their\n* handling of infinities and NaNs, and false otherwise. This variable\n* is passed to DLASQ3.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N )\n* On entry Z holds the qd array. On exit, entries 1 to N hold\n* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n* shifts that failed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if the i-th argument is a scalar and had an illegal\n* value, then INFO = -i, if the i-th argument is an\n* array and the j-entry had an illegal value, then\n* INFO = -(i*100+j)\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* Further Details\n* ===============\n* Local Variables: I0:N0 defines a current unreduced segment of Z.\n* The shifts are accumulated in SIGMA. Iteration count is in ITER.\n* Ping-pong is controlled by PP (alternates between 0 and 1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, z = NumRu::Lapack.dlasq2( n, z, [: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_n = argv[0];
+ rblapack_z = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 4*n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dlasq2_(&n, z, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_z);
+}
+
+void
+init_lapack_dlasq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasq2", rblapack_dlasq2, -1);
+}
diff --git a/ext/dlasq3.c b/ext/dlasq3.c
new file mode 100644
index 0000000..cd1d6f3
--- /dev/null
+++ b/ext/dlasq3.c
@@ -0,0 +1,138 @@
+#include "rb_lapack.h"
+
+extern VOID dlasq3_(integer* i0, integer* n0, doublereal* z, integer* pp, doublereal* dmin, doublereal* sigma, doublereal* desig, doublereal* qmax, integer* nfail, integer* iter, integer* ndiv, logical* ieee, integer* ttype, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dn1, doublereal* dn2, doublereal* g, doublereal* tau);
+
+
+static VALUE
+rblapack_dlasq3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_desig;
+ doublereal desig;
+ VALUE rblapack_qmax;
+ doublereal qmax;
+ VALUE rblapack_ieee;
+ logical ieee;
+ VALUE rblapack_ttype;
+ integer ttype;
+ VALUE rblapack_dmin1;
+ doublereal dmin1;
+ VALUE rblapack_dmin2;
+ doublereal dmin2;
+ VALUE rblapack_dn;
+ doublereal dn;
+ VALUE rblapack_dn1;
+ doublereal dn1;
+ VALUE rblapack_dn2;
+ doublereal dn2;
+ VALUE rblapack_g;
+ doublereal g;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_dmin;
+ doublereal dmin;
+ VALUE rblapack_sigma;
+ doublereal sigma;
+ VALUE rblapack_nfail;
+ integer nfail;
+ VALUE rblapack_iter;
+ integer iter;
+ VALUE rblapack_ndiv;
+ integer ndiv;
+
+
+ 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 dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.dlasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n* Purpose\n* =======\n*\n* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n* In case of failure it changes shifts, and tries again until output\n* is positive.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input/output) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input/output) INTEGER\n* PP=0 for ping, PP=1 for pong.\n* PP=2 indicates that flipping was applied to the Z array \n* and that the initial tests for deflation should not be \n* performed.\n*\n* DMIN (output) DOUBLE PRECISION\n* Minimum value of d.\n*\n* SIGMA (output) DOUBLE PRECISION\n* Sum of shifts used in current segment.\n*\n* DESIG (input/output) DOUBLE PRECISION\n* Lower order part of SIGMA\n*\n* QMAX (input) DOUBLE PRECISION\n* Maximum value of q.\n*\n* NFAIL (output) INTEGER\n* Number of times shift was too big.\n*\n* ITER (output) INTEGER\n* Number of iterations.\n*\n* NDIV (output) INTEGER\n* Number of divisions.\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).\n*\n* TTYPE (input/output) INTEGER\n* Shift type.\n*\n* DMIN1 (input/output) DOUBLE PRECISION\n*\n* DMIN2 (input/output) DOUBLE PRECISION\n*\n* DN (input/output) DOUBLE PRECISION\n*\n* DN1 (input/output) DOUBLE PRECISION\n*\n* DN2 (input/output) DOUBLE PRECISION\n*\n* G (input/output) DOUBLE PRECISION\n*\n* TAU (input/output) DOUBLE PRECISION\n*\n* These are passed as arguments in order to save their values\n* between calls to DLASQ3.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.dlasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ rblapack_desig = argv[4];
+ rblapack_qmax = argv[5];
+ rblapack_ieee = argv[6];
+ rblapack_ttype = argv[7];
+ rblapack_dmin1 = argv[8];
+ rblapack_dmin2 = argv[9];
+ rblapack_dn = argv[10];
+ rblapack_dn1 = argv[11];
+ rblapack_dn2 = argv[12];
+ rblapack_g = argv[13];
+ rblapack_tau = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ qmax = NUM2DBL(rblapack_qmax);
+ ttype = NUM2INT(rblapack_ttype);
+ dmin2 = NUM2DBL(rblapack_dmin2);
+ dn1 = NUM2DBL(rblapack_dn1);
+ g = NUM2DBL(rblapack_g);
+ n0 = NUM2INT(rblapack_n0);
+ desig = NUM2DBL(rblapack_desig);
+ dmin1 = NUM2DBL(rblapack_dmin1);
+ dn2 = NUM2DBL(rblapack_dn2);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ dn = NUM2DBL(rblapack_dn);
+ ieee = (rblapack_ieee == Qtrue);
+ tau = NUM2DBL(rblapack_tau);
+
+ dlasq3_(&i0, &n0, z, &pp, &dmin, &sigma, &desig, &qmax, &nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau);
+
+ rblapack_dmin = rb_float_new((double)dmin);
+ rblapack_sigma = rb_float_new((double)sigma);
+ rblapack_nfail = INT2NUM(nfail);
+ rblapack_iter = INT2NUM(iter);
+ rblapack_ndiv = INT2NUM(ndiv);
+ rblapack_n0 = INT2NUM(n0);
+ rblapack_pp = INT2NUM(pp);
+ rblapack_desig = rb_float_new((double)desig);
+ rblapack_ttype = INT2NUM(ttype);
+ rblapack_dmin1 = rb_float_new((double)dmin1);
+ rblapack_dmin2 = rb_float_new((double)dmin2);
+ rblapack_dn = rb_float_new((double)dn);
+ rblapack_dn1 = rb_float_new((double)dn1);
+ rblapack_dn2 = rb_float_new((double)dn2);
+ rblapack_g = rb_float_new((double)g);
+ rblapack_tau = rb_float_new((double)tau);
+ return rb_ary_new3(16, rblapack_dmin, rblapack_sigma, rblapack_nfail, rblapack_iter, rblapack_ndiv, rblapack_n0, rblapack_pp, rblapack_desig, rblapack_ttype, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dn1, rblapack_dn2, rblapack_g, rblapack_tau);
+}
+
+void
+init_lapack_dlasq3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasq3", rblapack_dlasq3, -1);
+}
diff --git a/ext/dlasq4.c b/ext/dlasq4.c
new file mode 100644
index 0000000..61c9f2a
--- /dev/null
+++ b/ext/dlasq4.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dlasq4_(integer* i0, integer* n0, doublereal* z, integer* pp, integer* n0in, doublereal* dmin, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dn1, doublereal* dn2, doublereal* tau, integer* ttype, real* g);
+
+
+static VALUE
+rblapack_dlasq4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_n0in;
+ integer n0in;
+ VALUE rblapack_dmin;
+ doublereal dmin;
+ VALUE rblapack_dmin1;
+ doublereal dmin1;
+ VALUE rblapack_dmin2;
+ doublereal dmin2;
+ VALUE rblapack_dn;
+ doublereal dn;
+ VALUE rblapack_dn1;
+ doublereal dn1;
+ VALUE rblapack_dn2;
+ doublereal dn2;
+ VALUE rblapack_g;
+ real g;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_ttype;
+ integer ttype;
+
+
+ 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 tau, ttype, g = NumRu::Lapack.dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n* Purpose\n* =======\n*\n* DLASQ4 computes an approximation TAU to the smallest eigenvalue\n* using values of d from the previous transform.\n*\n\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* NOIN (input) INTEGER\n* The value of N0 at start of EIGTEST.\n*\n* DMIN (input) DOUBLE PRECISION\n* Minimum value of d.\n*\n* DMIN1 (input) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (input) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (input) DOUBLE PRECISION\n* d(N)\n*\n* DN1 (input) DOUBLE PRECISION\n* d(N-1)\n*\n* DN2 (input) DOUBLE PRECISION\n* d(N-2)\n*\n* TAU (output) DOUBLE PRECISION\n* This is the shift.\n*\n* TTYPE (output) INTEGER\n* Shift type.\n*\n* G (input/output) REAL\n* G is passed as an argument in order to save its value between\n* calls to DLASQ4.\n*\n\n* Further Details\n* ===============\n* CNST1 = 9/16\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, ttype, g = NumRu::Lapack.dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [: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_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ rblapack_n0in = argv[4];
+ rblapack_dmin = argv[5];
+ rblapack_dmin1 = argv[6];
+ rblapack_dmin2 = argv[7];
+ rblapack_dn = argv[8];
+ rblapack_dn1 = argv[9];
+ rblapack_dn2 = argv[10];
+ rblapack_g = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ dmin = NUM2DBL(rblapack_dmin);
+ dmin2 = NUM2DBL(rblapack_dmin2);
+ dn1 = NUM2DBL(rblapack_dn1);
+ g = (real)NUM2DBL(rblapack_g);
+ n0 = NUM2INT(rblapack_n0);
+ n0in = NUM2INT(rblapack_n0in);
+ dn = NUM2DBL(rblapack_dn);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ dn2 = NUM2DBL(rblapack_dn2);
+ dmin1 = NUM2DBL(rblapack_dmin1);
+
+ dlasq4_(&i0, &n0, z, &pp, &n0in, &dmin, &dmin1, &dmin2, &dn, &dn1, &dn2, &tau, &ttype, &g);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_ttype = INT2NUM(ttype);
+ rblapack_g = rb_float_new((double)g);
+ return rb_ary_new3(3, rblapack_tau, rblapack_ttype, rblapack_g);
+}
+
+void
+init_lapack_dlasq4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasq4", rblapack_dlasq4, -1);
+}
diff --git a/ext/dlasq5.c b/ext/dlasq5.c
new file mode 100644
index 0000000..24de34e
--- /dev/null
+++ b/ext/dlasq5.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID dlasq5_(integer* i0, integer* n0, doublereal* z, integer* pp, doublereal* tau, doublereal* dmin, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dnm1, doublereal* dnm2, logical* ieee);
+
+
+static VALUE
+rblapack_dlasq5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_ieee;
+ logical ieee;
+ VALUE rblapack_dmin;
+ doublereal dmin;
+ VALUE rblapack_dmin1;
+ doublereal dmin1;
+ VALUE rblapack_dmin2;
+ doublereal dmin2;
+ VALUE rblapack_dn;
+ doublereal dn;
+ VALUE rblapack_dnm1;
+ doublereal dnm1;
+ VALUE rblapack_dnm2;
+ doublereal dnm2;
+
+
+ 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 dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq5( i0, n0, z, pp, tau, ieee, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n* Purpose\n* =======\n*\n* DLASQ5 computes one dqds transform in ping-pong form, one\n* version for IEEE machines another for non IEEE machines.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* TAU (input) DOUBLE PRECISION\n* This is the shift.\n*\n* DMIN (output) DOUBLE PRECISION\n* Minimum value of d.\n*\n* DMIN1 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) DOUBLE PRECISION\n* d(N0), the last value of d.\n*\n* DNM1 (output) DOUBLE PRECISION\n* d(N0-1).\n*\n* DNM2 (output) DOUBLE PRECISION\n* d(N0-2).\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic.\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n DOUBLE PRECISION D, EMIN, TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq5( i0, n0, z, pp, tau, ieee, [: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_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_ieee = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ ieee = (rblapack_ieee == Qtrue);
+ n0 = NUM2INT(rblapack_n0);
+ tau = NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+
+ dlasq5_(&i0, &n0, z, &pp, &tau, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2, &ieee);
+
+ rblapack_dmin = rb_float_new((double)dmin);
+ rblapack_dmin1 = rb_float_new((double)dmin1);
+ rblapack_dmin2 = rb_float_new((double)dmin2);
+ rblapack_dn = rb_float_new((double)dn);
+ rblapack_dnm1 = rb_float_new((double)dnm1);
+ rblapack_dnm2 = rb_float_new((double)dnm2);
+ return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
+}
+
+void
+init_lapack_dlasq5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasq5", rblapack_dlasq5, -1);
+}
diff --git a/ext/dlasq6.c b/ext/dlasq6.c
new file mode 100644
index 0000000..48f9847
--- /dev/null
+++ b/ext/dlasq6.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID dlasq6_(integer* i0, integer* n0, doublereal* z, integer* pp, doublereal* dmin, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dnm1, doublereal* dnm2);
+
+
+static VALUE
+rblapack_dlasq6(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_dmin;
+ doublereal dmin;
+ VALUE rblapack_dmin1;
+ doublereal dmin1;
+ VALUE rblapack_dmin2;
+ doublereal dmin2;
+ VALUE rblapack_dn;
+ doublereal dn;
+ VALUE rblapack_dnm1;
+ doublereal dnm1;
+ VALUE rblapack_dnm2;
+ doublereal dnm2;
+
+
+ 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 dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq6( i0, n0, z, pp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n* Purpose\n* =======\n*\n* DLASQ6 computes one dqd (shift equal to zero) transform in\n* ping-pong form, with protection against underflow and overflow.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* DMIN (output) DOUBLE PRECISION\n* Minimum value of d.\n*\n* DMIN1 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) DOUBLE PRECISION\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) DOUBLE PRECISION\n* d(N0), the last value of d.\n*\n* DNM1 (output) DOUBLE PRECISION\n* d(N0-1).\n*\n* DNM2 (output) DOUBLE PRECISION\n* d(N0-2).\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n DOUBLE PRECISION D, EMIN, SAFMIN, TEMP\n* ..\n* .. External Function ..\n DOUBLE PRECISION DLAMCH\n EXTERNAL DLAMCH\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq6( i0, n0, z, pp, [: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_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ n0 = NUM2INT(rblapack_n0);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+
+ dlasq6_(&i0, &n0, z, &pp, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2);
+
+ rblapack_dmin = rb_float_new((double)dmin);
+ rblapack_dmin1 = rb_float_new((double)dmin1);
+ rblapack_dmin2 = rb_float_new((double)dmin2);
+ rblapack_dn = rb_float_new((double)dn);
+ rblapack_dnm1 = rb_float_new((double)dnm1);
+ rblapack_dnm2 = rb_float_new((double)dnm2);
+ return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
+}
+
+void
+init_lapack_dlasq6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasq6", rblapack_dlasq6, -1);
+}
diff --git a/ext/dlasr.c b/ext/dlasr.c
new file mode 100644
index 0000000..2eb8c47
--- /dev/null
+++ b/ext/dlasr.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID dlasr_(char* side, char* pivot, char* direct, integer* m, integer* n, doublereal* c, doublereal* s, doublereal* a, integer* lda);
+
+
+static VALUE
+rblapack_dlasr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_pivot;
+ char pivot;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_a;
+ doublereal *a;
+ 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 a = NumRu::Lapack.dlasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* DLASR applies a sequence of plane rotations to a real matrix A,\n* from either the left or the right.\n* \n* When SIDE = 'L', the transformation takes the form\n* \n* A := P*A\n* \n* and when SIDE = 'R', the transformation takes the form\n* \n* A := A*P**T\n* \n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.dlasr( side, pivot, direct, m, c, s, a, [: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_pivot = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_m = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th 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*);
+ pivot = StringValueCStr(rblapack_pivot)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int 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__;
+
+ dlasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_dlasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasr", rblapack_dlasr, -1);
+}
diff --git a/ext/dlasrt.c b/ext/dlasrt.c
new file mode 100644
index 0000000..3c6ae7a
--- /dev/null
+++ b/ext/dlasrt.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID dlasrt_(char* id, integer* n, doublereal* d, integer* info);
+
+
+static VALUE
+rblapack_dlasrt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_id;
+ char id;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+
+ 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, d = NumRu::Lapack.dlasrt( id, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASRT( ID, N, D, INFO )\n\n* Purpose\n* =======\n*\n* Sort the numbers in D in increasing order (if ID = 'I') or\n* in decreasing order (if ID = 'D' ).\n*\n* Use Quick Sort, reverting to Insertion sort on arrays of\n* size <= 20. Dimension of STACK limits N to about 2**32.\n*\n\n* Arguments\n* =========\n*\n* ID (input) CHARACTER*1\n* = 'I': sort D in increasing order;\n* = 'D': sort D in decreasing order.\n*\n* N (input) INTEGER\n* The length of the array D.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the array to be sorted.\n* On exit, D has been sorted into increasing order\n* (D(1) <= ... <= D(N) ) or into decreasing order\n* (D(1) >= ... >= D(N) ), depending on ID.\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, d = NumRu::Lapack.dlasrt( id, d, [: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_id = argv[0];
+ rblapack_d = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ id = StringValueCStr(rblapack_id)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+
+ dlasrt_(&id, &n, d, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_d);
+}
+
+void
+init_lapack_dlasrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasrt", rblapack_dlasrt, -1);
+}
diff --git a/ext/dlassq.c b/ext/dlassq.c
new file mode 100644
index 0000000..3260d87
--- /dev/null
+++ b/ext/dlassq.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern VOID dlassq_(integer* n, doublereal* x, integer* incx, doublereal* scale, doublereal* sumsq);
+
+
+static VALUE
+rblapack_dlassq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_sumsq;
+ doublereal sumsq;
+
+ 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 scale, sumsq = NumRu::Lapack.dlassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* DLASSQ returns the values scl and smsq such that\n*\n* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is\n* assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( x( i ) ) ).\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ and\n* scl and smsq are overwritten on SCALE and SUMSQ respectively.\n*\n* The routine makes only one pass through the vector x.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) DOUBLE PRECISION array, dimension (N)\n* The vector for which a scaled sum of squares is computed.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) DOUBLE PRECISION\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with scl , the scaling factor\n* for the sum of squares.\n*\n* SUMSQ (input/output) DOUBLE PRECISION\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with smsq , the basic sum of\n* squares from which scl has been factored out.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.dlassq( x, incx, scale, sumsq, [: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_x = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_scale = argv[2];
+ rblapack_sumsq = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ scale = NUM2DBL(rblapack_scale);
+ incx = NUM2INT(rblapack_incx);
+ sumsq = NUM2DBL(rblapack_sumsq);
+
+ dlassq_(&n, x, &incx, &scale, &sumsq);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_sumsq = rb_float_new((double)sumsq);
+ return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
+}
+
+void
+init_lapack_dlassq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlassq", rblapack_dlassq, -1);
+}
diff --git a/ext/dlasv2.c b/ext/dlasv2.c
new file mode 100644
index 0000000..eed3bff
--- /dev/null
+++ b/ext/dlasv2.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID dlasv2_(doublereal* f, doublereal* g, doublereal* h, doublereal* ssmin, doublereal* ssmax, doublereal* snr, doublereal* csr, doublereal* snl, doublereal* csl);
+
+
+static VALUE
+rblapack_dlasv2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ doublereal f;
+ VALUE rblapack_g;
+ doublereal g;
+ VALUE rblapack_h;
+ doublereal h;
+ VALUE rblapack_ssmin;
+ doublereal ssmin;
+ VALUE rblapack_ssmax;
+ doublereal ssmax;
+ VALUE rblapack_snr;
+ doublereal snr;
+ VALUE rblapack_csr;
+ doublereal csr;
+ VALUE rblapack_snl;
+ doublereal snl;
+ VALUE rblapack_csl;
+ doublereal csl;
+
+
+ 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 ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.dlasv2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n* Purpose\n* =======\n*\n* DLASV2 computes the singular value decomposition of a 2-by-2\n* triangular matrix\n* [ F G ]\n* [ 0 H ].\n* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n* right singular vectors for abs(SSMAX), giving the decomposition\n*\n* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]\n* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].\n*\n\n* Arguments\n* =========\n*\n* F (input) DOUBLE PRECISION\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) DOUBLE PRECISION\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) DOUBLE PRECISION\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) DOUBLE PRECISION\n* abs(SSMIN) is the smaller singular value.\n*\n* SSMAX (output) DOUBLE PRECISION\n* abs(SSMAX) is the larger singular value.\n*\n* SNL (output) DOUBLE PRECISION\n* CSL (output) DOUBLE PRECISION\n* The vector (CSL, SNL) is a unit left singular vector for the\n* singular value abs(SSMAX).\n*\n* SNR (output) DOUBLE PRECISION\n* CSR (output) DOUBLE PRECISION\n* The vector (CSR, SNR) is a unit right singular vector for the\n* singular value abs(SSMAX).\n*\n\n* Further Details\n* ===============\n*\n* Any input parameter may be aliased with any output parameter.\n*\n* Barring over/underflow and assuming a guard digit in subtraction, all\n* output quantities are correct to within a few units in the last\n* place (ulps).\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.dlasv2( f, g, h, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ rblapack_h = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = NUM2DBL(rblapack_f);
+ h = NUM2DBL(rblapack_h);
+ g = NUM2DBL(rblapack_g);
+
+ dlasv2_(&f, &g, &h, &ssmin, &ssmax, &snr, &csr, &snl, &csl);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ rblapack_ssmax = rb_float_new((double)ssmax);
+ rblapack_snr = rb_float_new((double)snr);
+ rblapack_csr = rb_float_new((double)csr);
+ rblapack_snl = rb_float_new((double)snl);
+ rblapack_csl = rb_float_new((double)csl);
+ return rb_ary_new3(6, rblapack_ssmin, rblapack_ssmax, rblapack_snr, rblapack_csr, rblapack_snl, rblapack_csl);
+}
+
+void
+init_lapack_dlasv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasv2", rblapack_dlasv2, -1);
+}
diff --git a/ext/dlaswp.c b/ext/dlaswp.c
new file mode 100644
index 0000000..b17531b
--- /dev/null
+++ b/ext/dlaswp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID dlaswp_(integer* n, doublereal* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);
+
+
+static VALUE
+rblapack_dlaswp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_k1;
+ integer k1;
+ VALUE rblapack_k2;
+ integer k2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_incx;
+ integer incx;
+ 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 a = NumRu::Lapack.dlaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* DLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n DOUBLE PRECISION TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.dlaswp( a, k1, k2, ipiv, incx, [: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_a = argv[0];
+ rblapack_k1 = argv[1];
+ rblapack_k2 = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_incx = argv[4];
+ if (argc == 5) {
+ } 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);
+ 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*);
+ k2 = NUM2INT(rblapack_k2);
+ incx = NUM2INT(rblapack_incx);
+ k1 = NUM2INT(rblapack_k1);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ dlaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_dlaswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlaswp", rblapack_dlaswp, -1);
+}
diff --git a/ext/dlasy2.c b/ext/dlasy2.c
new file mode 100644
index 0000000..63a0282
--- /dev/null
+++ b/ext/dlasy2.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID dlasy2_(logical* ltranl, logical* ltranr, integer* isgn, integer* n1, integer* n2, doublereal* tl, integer* ldtl, doublereal* tr, integer* ldtr, doublereal* b, integer* ldb, doublereal* scale, doublereal* x, integer* ldx, doublereal* xnorm, integer* info);
+
+
+static VALUE
+rblapack_dlasy2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ltranl;
+ logical ltranl;
+ VALUE rblapack_ltranr;
+ logical ltranr;
+ VALUE rblapack_isgn;
+ integer isgn;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_tl;
+ doublereal *tl;
+ VALUE rblapack_tr;
+ doublereal *tr;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_xnorm;
+ doublereal xnorm;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldtl;
+ integer ldtr;
+ integer ldb;
+ 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 scale, x, xnorm, info = NumRu::Lapack.dlasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n*\n* op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n*\n* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n* -1. op(T) = T or T', where T' denotes the transpose of T.\n*\n\n* Arguments\n* =========\n*\n* LTRANL (input) LOGICAL\n* On entry, LTRANL specifies the op(TL):\n* = .FALSE., op(TL) = TL,\n* = .TRUE., op(TL) = TL'.\n*\n* LTRANR (input) LOGICAL\n* On entry, LTRANR specifies the op(TR):\n* = .FALSE., op(TR) = TR,\n* = .TRUE., op(TR) = TR'.\n*\n* ISGN (input) INTEGER\n* On entry, ISGN specifies the sign of the equation\n* as described before. ISGN may only be 1 or -1.\n*\n* N1 (input) INTEGER\n* On entry, N1 specifies the order of matrix TL.\n* N1 may only be 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* On entry, N2 specifies the order of matrix TR.\n* N2 may only be 0, 1 or 2.\n*\n* TL (input) DOUBLE PRECISION array, dimension (LDTL,2)\n* On entry, TL contains an N1 by N1 matrix.\n*\n* LDTL (input) INTEGER\n* The leading dimension of the matrix TL. LDTL >= max(1,N1).\n*\n* TR (input) DOUBLE PRECISION array, dimension (LDTR,2)\n* On entry, TR contains an N2 by N2 matrix.\n*\n* LDTR (input) INTEGER\n* The leading dimension of the matrix TR. LDTR >= max(1,N2).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,2)\n* On entry, the N1 by N2 matrix B contains the right-hand\n* side of the equation.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1,N1).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* less than or equal to 1 to prevent the solution overflowing.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,2)\n* On exit, X contains the N1 by N2 solution.\n*\n* LDX (input) INTEGER\n* The leading dimension of the matrix X. LDX >= max(1,N1).\n*\n* XNORM (output) DOUBLE PRECISION\n* On exit, XNORM is the infinity-norm of the solution.\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: TL and TR have too close eigenvalues, so TL or\n* TR is perturbed to get a nonsingular equation.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, x, xnorm, info = NumRu::Lapack.dlasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [: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_ltranl = argv[0];
+ rblapack_ltranr = argv[1];
+ rblapack_isgn = argv[2];
+ rblapack_n1 = argv[3];
+ rblapack_n2 = argv[4];
+ rblapack_tl = argv[5];
+ rblapack_tr = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ltranl = (rblapack_ltranl == Qtrue);
+ isgn = NUM2INT(rblapack_isgn);
+ n2 = NUM2INT(rblapack_n2);
+ if (!NA_IsNArray(rblapack_tr))
+ rb_raise(rb_eArgError, "tr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_tr) != 2)
+ rb_raise(rb_eArgError, "rank of tr (7th argument) must be %d", 2);
+ ldtr = NA_SHAPE0(rblapack_tr);
+ if (NA_SHAPE1(rblapack_tr) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of tr must be %d", 2);
+ if (NA_TYPE(rblapack_tr) != NA_DFLOAT)
+ rblapack_tr = na_change_type(rblapack_tr, NA_DFLOAT);
+ tr = NA_PTR_TYPE(rblapack_tr, doublereal*);
+ ltranr = (rblapack_ltranr == Qtrue);
+ if (!NA_IsNArray(rblapack_tl))
+ rb_raise(rb_eArgError, "tl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_tl) != 2)
+ rb_raise(rb_eArgError, "rank of tl (6th argument) must be %d", 2);
+ ldtl = NA_SHAPE0(rblapack_tl);
+ if (NA_SHAPE1(rblapack_tl) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of tl must be %d", 2);
+ if (NA_TYPE(rblapack_tl) != NA_DFLOAT)
+ rblapack_tl = na_change_type(rblapack_tl, NA_DFLOAT);
+ tl = NA_PTR_TYPE(rblapack_tl, doublereal*);
+ n1 = NUM2INT(rblapack_n1);
+ ldx = MAX(1,n1);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ if (NA_SHAPE1(rblapack_b) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = 2;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+
+ dlasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &ldtl, tr, &ldtr, b, &ldb, &scale, x, &ldx, &xnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_xnorm = rb_float_new((double)xnorm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_x, rblapack_xnorm, rblapack_info);
+}
+
+void
+init_lapack_dlasy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasy2", rblapack_dlasy2, -1);
+}
diff --git a/ext/dlasyf.c b/ext/dlasyf.c
new file mode 100644
index 0000000..c82b5fb
--- /dev/null
+++ b/ext/dlasyf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dlasyf_(char* uplo, integer* n, integer* nb, integer* kb, doublereal* a, integer* lda, integer* ipiv, doublereal* w, integer* ldw, integer* info);
+
+
+static VALUE
+rblapack_dlasyf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *w;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 kb, ipiv, info, a = NumRu::Lapack.dlasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* DLASYF computes a partial factorization of a real symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n*\n* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) DOUBLE PRECISION 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.dlasyf( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+ w = ALLOC_N(doublereal, (ldw)*(MAX(1,nb)));
+
+ dlasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
+
+ free(w);
+ rblapack_kb = INT2NUM(kb);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dlasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlasyf", rblapack_dlasyf, -1);
+}
diff --git a/ext/dlat2s.c b/ext/dlat2s.c
new file mode 100644
index 0000000..e1f0f27
--- /dev/null
+++ b/ext/dlat2s.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID dlat2s_(char* uplo, integer* n, doublereal* a, integer* lda, real* sa, integer* ldsa, integer* info);
+
+
+static VALUE
+rblapack_dlat2s(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_sa;
+ real *sa;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer ldsa;
+
+ 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 sa, info = NumRu::Lapack.dlat2s( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE\n* PRECISION triangular matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* DLAS2S checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\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* N (input) INTEGER\n* The number of rows and columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N triangular coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SA (output) REAL array, dimension (LDSA,N)\n* Only the UPLO part of SA is referenced. On exit, if INFO=0,\n* the N-by-N coefficient matrix SA; if INFO>0, the content of\n* the UPLO part of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of the UPLO part of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n LOGICAL UPPER\n* ..\n* .. External Functions ..\n REAL SLAMCH\n LOGICAL LSAME\n EXTERNAL SLAMCH, LSAME\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.dlat2s( 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*);
+ ldsa = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldsa;
+ shape[1] = n;
+ rblapack_sa = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ sa = NA_PTR_TYPE(rblapack_sa, real*);
+
+ dlat2s_(&uplo, &n, a, &lda, sa, &ldsa, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_sa, rblapack_info);
+}
+
+void
+init_lapack_dlat2s(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlat2s", rblapack_dlat2s, -1);
+}
diff --git a/ext/dlatbs.c b/ext/dlatbs.c
new file mode 100644
index 0000000..68c2ecf
--- /dev/null
+++ b/ext/dlatbs.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID dlatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* x, doublereal* scale, doublereal* cnorm, integer* info);
+
+
+static VALUE
+rblapack_dlatbs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_cnorm;
+ doublereal *cnorm;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_cnorm_out__;
+ doublereal *cnorm_out__;
+
+ integer ldab;
+ 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 scale, info, x, cnorm = NumRu::Lapack.dlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLATBS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, DTBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.dlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [: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_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_kd = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_x = argv[6];
+ rblapack_cnorm = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
+ MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ dlatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_dlatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlatbs", rblapack_dlatbs, -1);
+}
diff --git a/ext/dlatdf.c b/ext/dlatdf.c
new file mode 100644
index 0000000..5bd827a
--- /dev/null
+++ b/ext/dlatdf.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID dlatdf_(integer* ijob, integer* n, doublereal* z, integer* ldz, doublereal* rhs, doublereal* rdsum, doublereal* rdscal, integer* ipiv, integer* jpiv);
+
+
+static VALUE
+rblapack_dlatdf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_rhs;
+ doublereal *rhs;
+ VALUE rblapack_rdsum;
+ doublereal rdsum;
+ VALUE rblapack_rdscal;
+ doublereal rdscal;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_rhs_out__;
+ doublereal *rhs_out__;
+
+ integer ldz;
+ 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 rhs, rdsum, rdscal = NumRu::Lapack.dlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* DLATDF uses the LU factorization of the n-by-n matrix Z computed by\n* DGETC2 and computes a contribution to the reciprocal Dif-estimate\n* by solving Z * x = b for x, and choosing the r.h.s. b such that\n* the norm of x is as large as possible. On entry RHS = b holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,\n* where P and Q are permutation matrices. L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using DGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value\n* of 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where all entries of\n* the r.h.s. b is choosen as either +1 or -1 (Default).\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by DGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries acoording to the value of IJOB (see above).\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by DTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when DTGSY2 is called by\n* DTGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report IMINF-95.05, Departement of\n* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.dlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [: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_ijob = argv[0];
+ rblapack_z = argv[1];
+ rblapack_rhs = argv[2];
+ rblapack_rdsum = argv[3];
+ rblapack_rdscal = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_jpiv = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ if (!NA_IsNArray(rblapack_rhs))
+ rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_rhs);
+ if (NA_TYPE(rblapack_rhs) != NA_DFLOAT)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_DFLOAT);
+ rhs = NA_PTR_TYPE(rblapack_rhs, doublereal*);
+ rdscal = NUM2DBL(rblapack_rdscal);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ 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 rhs");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ rdsum = NUM2DBL(rblapack_rdsum);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublereal*);
+ MEMCPY(rhs_out__, rhs, doublereal, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ dlatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
+
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_dlatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlatdf", rblapack_dlatdf, -1);
+}
diff --git a/ext/dlatps.c b/ext/dlatps.c
new file mode 100644
index 0000000..1a33b11
--- /dev/null
+++ b/ext/dlatps.c
@@ -0,0 +1,124 @@
+#include "rb_lapack.h"
+
+extern VOID dlatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublereal* ap, doublereal* x, doublereal* scale, doublereal* cnorm, integer* info);
+
+
+static VALUE
+rblapack_dlatps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_cnorm;
+ doublereal *cnorm;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_cnorm_out__;
+ doublereal *cnorm_out__;
+
+ 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 scale, info, x, cnorm = NumRu::Lapack.dlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLATPS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A' denotes the\n* transpose of A, x and b are n-element vectors, and s is a scaling\n* factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION 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*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, DTPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.dlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ 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) != (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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
+ MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ dlatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_dlatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlatps", rblapack_dlatps, -1);
+}
diff --git a/ext/dlatrd.c b/ext/dlatrd.c
new file mode 100644
index 0000000..050a418
--- /dev/null
+++ b/ext/dlatrd.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID dlatrd_(char* uplo, integer* n, integer* nb, doublereal* a, integer* lda, doublereal* e, doublereal* tau, doublereal* w, integer* ldw);
+
+
+static VALUE
+rblapack_dlatrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 e, tau, w, a = NumRu::Lapack.dlatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* DLATRD reduces NB rows and columns of a real symmetric matrix A to\n* symmetric tridiagonal form by an orthogonal similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by DSYTRD.\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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) DOUBLE PRECISION 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= (1,N).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) DOUBLE PRECISION array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a symmetric rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.dlatrd( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldw;
+ shape[1] = MAX(n,nb);
+ rblapack_w = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int 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__;
+
+ dlatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
+
+ return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
+}
+
+void
+init_lapack_dlatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlatrd", rblapack_dlatrd, -1);
+}
diff --git a/ext/dlatrs.c b/ext/dlatrs.c
new file mode 100644
index 0000000..427b1a4
--- /dev/null
+++ b/ext/dlatrs.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID dlatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublereal* a, integer* lda, doublereal* x, doublereal* scale, doublereal* cnorm, integer* info);
+
+
+static VALUE
+rblapack_dlatrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_cnorm;
+ doublereal *cnorm;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_cnorm_out__;
+ doublereal *cnorm_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 scale, info, x, cnorm = NumRu::Lapack.dlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* DLATRS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A' denotes the transpose of A, x and b are\n* n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, DTRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.dlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_a = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
+ 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) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
+ MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ dlatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_dlatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlatrs", rblapack_dlatrs, -1);
+}
diff --git a/ext/dlatrz.c b/ext/dlatrz.c
new file mode 100644
index 0000000..8101f9e
--- /dev/null
+++ b/ext/dlatrz.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID dlatrz_(integer* m, integer* n, integer* l, doublereal* a, integer* lda, doublereal* tau, doublereal* work);
+
+
+static VALUE
+rblapack_dlatrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.dlatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means\n* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.dlatrz( l, 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_l = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ l = NUM2INT(rblapack_l);
+ 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (m));
+
+ dlatrz_(&m, &n, &l, a, &lda, tau, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_tau, rblapack_a);
+}
+
+void
+init_lapack_dlatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlatrz", rblapack_dlatrz, -1);
+}
diff --git a/ext/dlatzm.c b/ext/dlatzm.c
new file mode 100644
index 0000000..50301b2
--- /dev/null
+++ b/ext/dlatzm.c
@@ -0,0 +1,131 @@
+#include "rb_lapack.h"
+
+extern VOID dlatzm_(char* side, integer* m, integer* n, doublereal* v, integer* incv, doublereal* tau, doublereal* c1, doublereal* c2, integer* ldc, doublereal* work);
+
+
+static VALUE
+rblapack_dlatzm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ doublereal tau;
+ VALUE rblapack_c1;
+ doublereal *c1;
+ VALUE rblapack_c2;
+ doublereal *c2;
+ VALUE rblapack_c1_out__;
+ doublereal *c1_out__;
+ VALUE rblapack_c2_out__;
+ doublereal *c2_out__;
+ doublereal *work;
+
+ 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 c1, c2 = NumRu::Lapack.dlatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DORMRZ.\n*\n* DLATZM applies a Householder matrix generated by DTZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) DOUBLE PRECISION array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) DOUBLE PRECISION\n* The value tau in the representation of P.\n*\n* C1 (input/output) DOUBLE PRECISION array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) DOUBLE PRECISION array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.dlatzm( side, m, n, v, incv, tau, c1, c2, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c1 = argv[6];
+ rblapack_c2 = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ n = NUM2INT(rblapack_n);
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c2))
+ rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c2) != 2)
+ rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c2);
+ if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
+ if (NA_TYPE(rblapack_c2) != NA_DFLOAT)
+ rblapack_c2 = na_change_type(rblapack_c2, NA_DFLOAT);
+ c2 = NA_PTR_TYPE(rblapack_c2, doublereal*);
+ m = NUM2INT(rblapack_m);
+ tau = NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ if (!NA_IsNArray(rblapack_c1))
+ rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c1) != 2)
+ rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
+ if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
+ if (NA_TYPE(rblapack_c1) != NA_DFLOAT)
+ rblapack_c1 = na_change_type(rblapack_c1, NA_DFLOAT);
+ c1 = NA_PTR_TYPE(rblapack_c1, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
+ rblapack_c1_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, doublereal*);
+ MEMCPY(c1_out__, c1, doublereal, NA_TOTAL(rblapack_c1));
+ rblapack_c1 = rblapack_c1_out__;
+ c1 = c1_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
+ rblapack_c2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, doublereal*);
+ MEMCPY(c2_out__, c2, doublereal, NA_TOTAL(rblapack_c2));
+ rblapack_c2 = rblapack_c2_out__;
+ c2 = c2_out__;
+ work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ dlatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_c1, rblapack_c2);
+}
+
+void
+init_lapack_dlatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dlatzm", rblapack_dlatzm, -1);
+}
diff --git a/ext/dlauu2.c b/ext/dlauu2.c
new file mode 100644
index 0000000..3511fba
--- /dev/null
+++ b/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*);
+ {
+ int 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);
+}
diff --git a/ext/dlauum.c b/ext/dlauum.c
new file mode 100644
index 0000000..508c83e
--- /dev/null
+++ b/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*);
+ {
+ int 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);
+}
diff --git a/ext/dopgtr.c b/ext/dopgtr.c
new file mode 100644
index 0000000..af3a9ed
--- /dev/null
+++ b/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);
+ {
+ int 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);
+}
diff --git a/ext/dopmtr.c b/ext/dopmtr.c
new file mode 100644
index 0000000..6ef02e6
--- /dev/null
+++ b/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*);
+ {
+ int 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);
+}
diff --git a/ext/dorbdb.c b/ext/dorbdb.c
new file mode 100644
index 0000000..470be55
--- /dev/null
+++ b/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*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_taup1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taup1 = NA_PTR_TYPE(rblapack_taup1, doublereal*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_taup2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ taup2 = NA_PTR_TYPE(rblapack_taup2, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_tauq1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tauq1 = NA_PTR_TYPE(rblapack_tauq1, doublereal*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_tauq2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tauq2 = NA_PTR_TYPE(rblapack_tauq2, doublereal*);
+ {
+ int 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__;
+ {
+ int 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__;
+ {
+ int 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__;
+ {
+ int 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);
+}
diff --git a/ext/dorcsd.c b/ext/dorcsd.c
new file mode 100644
index 0000000..4ead744
--- /dev/null
+++ b/ext/dorcsd.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID dorcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, 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* u1, integer* ldu1, doublereal* u2, integer* ldu2, doublereal* v1t, integer* ldv1t, doublereal* v2t, integer* ldv2t, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dorcsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ 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_u1;
+ doublereal *u1;
+ VALUE rblapack_u2;
+ doublereal *u2;
+ VALUE rblapack_v1t;
+ doublereal *v1t;
+ VALUE rblapack_v2t;
+ doublereal *v2t;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldx11;
+ integer q;
+ integer ldx12;
+ integer ldx21;
+ integer ldx22;
+ integer p;
+ integer ldv2t;
+ integer ldv1t;
+ integer ldu1;
+ integer ldu2;
+
+ 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, u1, u2, v1t, v2t, info = NumRu::Lapack.dorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORCSD computes the CS decomposition of an M-by-M partitioned\n* orthogonal matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) DOUBLE PRECISION array, dimension (LDX,M)\n* On entry, the orthogonal matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) DOUBLE PRECISION array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) DOUBLE PRECISION array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) DOUBLE PRECISION array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) DOUBLE PRECISION array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n* matrix V1**T.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) DOUBLE PRECISION array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n* matrix V2**T.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n* If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\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-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: DBBCSD did not converge. See the description of WORK\n* above for details.\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\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.dorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [: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_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_signs = argv[5];
+ rblapack_m = argv[6];
+ rblapack_x11 = argv[7];
+ rblapack_x12 = argv[8];
+ rblapack_x21 = argv[9];
+ rblapack_x22 = argv[10];
+ rblapack_lwork = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ m = NUM2INT(rblapack_m);
+ lwork = NUM2INT(rblapack_lwork);
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ signs = StringValueCStr(rblapack_signs)[0];
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_x11))
+ rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x11) != 2)
+ rb_raise(rb_eArgError, "rank of x11 (8th 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 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_x21) != 2)
+ rb_raise(rb_eArgError, "rank of x21 (10th 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*);
+ ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
+ ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
+ ldx12 = p;
+ if (!NA_IsNArray(rblapack_x12))
+ rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x12) != 2)
+ rb_raise(rb_eArgError, "rank of x12 (9th 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*);
+ ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
+ ldx22 = p;
+ if (!NA_IsNArray(rblapack_x22))
+ rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
+ if (NA_RANK(rblapack_x22) != 2)
+ rb_raise(rb_eArgError, "rank of x22 (11th 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*);
+ ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
+ {
+ int shape[1];
+ shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
+ rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_u1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ u1 = NA_PTR_TYPE(rblapack_u1, doublereal*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_u2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_v1t = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ v1t = NA_PTR_TYPE(rblapack_v1t, doublereal*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_v2t = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ v2t = NA_PTR_TYPE(rblapack_v2t, doublereal*);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+ iwork = ALLOC_N(integer, (m-q));
+
+ dorcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
+}
+
+void
+init_lapack_dorcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorcsd", rblapack_dorcsd, -1);
+}
diff --git a/ext/dorg2l.c b/ext/dorg2l.c
new file mode 100644
index 0000000..bc668fa
--- /dev/null
+++ b/ext/dorg2l.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID dorg2l_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dorg2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.dorg2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORG2L generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.dorg2l( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = 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*);
+ 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*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n));
+
+ dorg2l_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorg2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorg2l", rblapack_dorg2l, -1);
+}
diff --git a/ext/dorg2r.c b/ext/dorg2r.c
new file mode 100644
index 0000000..b031c9d
--- /dev/null
+++ b/ext/dorg2r.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID dorg2r_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dorg2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.dorg2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORG2R generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.dorg2r( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = 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*);
+ 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*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n));
+
+ dorg2r_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorg2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorg2r", rblapack_dorg2r, -1);
+}
diff --git a/ext/dorgbr.c b/ext/dorgbr.c
new file mode 100644
index 0000000..477b3f4
--- /dev/null
+++ b/ext/dorgbr.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID dorgbr_(char* vect, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorgbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 work, info, a = NumRu::Lapack.dorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGBR generates one of the real orthogonal matrices Q or P**T\n* determined by DGEBRD when reducing a real matrix A to bidiagonal\n* form: A = Q * B * P**T. Q and P**T are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n* is of order N:\n* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m\n* rows of P**T, where n >= m >= k;\n* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**T is\n* required, as defined in the transformation applied by DGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**T.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**T to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**T to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by DGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by DGEBRD.\n* K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by DGEBRD.\n* On exit, the M-by-N matrix Q or P**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**T, as\n* returned by DGEBRD in its array argument TAUQ or TAUP.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_m = argv[1];
+ rblapack_k = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ k = NUM2INT(rblapack_k);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
+ 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_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);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = MIN(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dorgbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorgbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorgbr", rblapack_dorgbr, -1);
+}
diff --git a/ext/dorghr.c b/ext/dorghr.c
new file mode 100644
index 0000000..42be238
--- /dev/null
+++ b/ext/dorghr.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID dorghr_(integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorghr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 work, info, a = NumRu::Lapack.dorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGHR generates a real orthogonal matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* DGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of DGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by DGEHRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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 DGEHRD.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ 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*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = ihi-ilo;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dorghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorghr", rblapack_dorghr, -1);
+}
diff --git a/ext/dorgl2.c b/ext/dorgl2.c
new file mode 100644
index 0000000..090e476
--- /dev/null
+++ b/ext/dorgl2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID dorgl2_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dorgl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dorgl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGL2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by DGELQF in the first k rows of its array argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.dorgl2( a, tau, [: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_tau = 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);
+ 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*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = 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*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (m));
+
+ dorgl2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorgl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorgl2", rblapack_dorgl2, -1);
+}
diff --git a/ext/dorglq.c b/ext/dorglq.c
new file mode 100644
index 0000000..0f1d33d
--- /dev/null
+++ b/ext/dorglq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dorglq_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorglq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.dorglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by DGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = 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*);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dorglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorglq", rblapack_dorglq, -1);
+}
diff --git a/ext/dorgql.c b/ext/dorgql.c
new file mode 100644
index 0000000..1304b80
--- /dev/null
+++ b/ext/dorgql.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dorgql_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorgql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.dorgql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGQL generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = 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*);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dorgql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorgql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorgql", rblapack_dorgql, -1);
+}
diff --git a/ext/dorgqr.c b/ext/dorgqr.c
new file mode 100644
index 0000000..3966f45
--- /dev/null
+++ b/ext/dorgqr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dorgqr_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorgqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.dorgqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGQR generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = 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*);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dorgqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorgqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorgqr", rblapack_dorgqr, -1);
+}
diff --git a/ext/dorgr2.c b/ext/dorgr2.c
new file mode 100644
index 0000000..17d0ecc
--- /dev/null
+++ b/ext/dorgr2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID dorgr2_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dorgr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dorgr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGR2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGERQF in the last k rows of its array argument\n* A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.dorgr2( a, tau, [: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_tau = 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);
+ 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*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = 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*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (m));
+
+ dorgr2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorgr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorgr2", rblapack_dorgr2, -1);
+}
diff --git a/ext/dorgrq.c b/ext/dorgrq.c
new file mode 100644
index 0000000..117249e
--- /dev/null
+++ b/ext/dorgrq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dorgrq_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorgrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.dorgrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by DGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = 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*);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dorgrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorgrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorgrq", rblapack_dorgrq, -1);
+}
diff --git a/ext/dorgtr.c b/ext/dorgtr.c
new file mode 100644
index 0000000..0439401
--- /dev/null
+++ b/ext/dorgtr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dorgtr_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dorgtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 work, info, a = NumRu::Lapack.dorgtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORGTR generates a real orthogonal matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* DSYTRD:\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 triangle of A contains elementary reflectors\n* from DSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from DSYTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by DSYTRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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 DSYTRD.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N-1).\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.dorgtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dorgtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dorgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorgtr", rblapack_dorgtr, -1);
+}
diff --git a/ext/dorm2l.c b/ext/dorm2l.c
new file mode 100644
index 0000000..b89a54f
--- /dev/null
+++ b/ext/dorm2l.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID dorm2l_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dorm2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ 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 lda;
+ integer k;
+ 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.dorm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORM2L overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\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'*C or C*Q' 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.dorm2l( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int 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));
+
+ dorm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dorm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorm2l", rblapack_dorm2l, -1);
+}
diff --git a/ext/dorm2r.c b/ext/dorm2r.c
new file mode 100644
index 0000000..a3d7bf0
--- /dev/null
+++ b/ext/dorm2r.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID dorm2r_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dorm2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ 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 lda;
+ integer k;
+ 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.dorm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORM2R overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\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'*C or C*Q' 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.dorm2r( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int 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));
+
+ dorm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dorm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorm2r", rblapack_dorm2r, -1);
+}
diff --git a/ext/dormbr.c b/ext/dormbr.c
new file mode 100644
index 0000000..00fa36d
--- /dev/null
+++ b/ext/dormbr.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID dormbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer ldc;
+ integer n;
+ integer nq;
+
+ 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 work, info, c = NumRu::Lapack.dormbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'T': Q**T * C C * Q**T\n*\n* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'T': P**T * C C * P**T\n*\n* Here Q and P**T are the orthogonal matrices determined by DGEBRD when\n* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n* P**T are defined as products of elementary reflectors H(i) and G(i)\n* respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the orthogonal matrix Q or P**T that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**T;\n* = 'P': apply P or P**T.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**T, P or P**T from the Left;\n* = 'R': apply Q, Q**T, P or P**T from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'T': Transpose, apply Q**T or P**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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by DGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by DGEBRD.\n* K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by DGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by DGEBRD in the array argument TAUQ or TAUP.\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* or P*C or P**T*C or C*P or C*P**T.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DORMLQ, DORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormbr( vect, side, trans, m, k, a, tau, c, [: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_vect = argv[0];
+ rblapack_side = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_m = argv[3];
+ rblapack_k = argv[4];
+ rblapack_a = argv[5];
+ rblapack_tau = argv[6];
+ rblapack_c = 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;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th 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*);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
+ if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormbr", rblapack_dormbr, -1);
+}
diff --git a/ext/dormhr.c b/ext/dormhr.c
new file mode 100644
index 0000000..2df3c5e
--- /dev/null
+++ b/ext/dormhr.c
@@ -0,0 +1,133 @@
+#include "rb_lapack.h"
+
+extern VOID dormhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormhr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.dormhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMHR 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* IHI-ILO elementary reflectors, as returned by DGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-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* 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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of DGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by DGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEHRD.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormhr( side, trans, ilo, ihi, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = 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;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormhr", rblapack_dormhr, -1);
+}
diff --git a/ext/dorml2.c b/ext/dorml2.c
new file mode 100644
index 0000000..743b574
--- /dev/null
+++ b/ext/dorml2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID dorml2_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dorml2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ 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 lda;
+ integer m;
+ integer k;
+ 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.dorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORML2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\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'*C or C*Q' 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.dorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = 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*);
+ {
+ int 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));
+
+ dorml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dorml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dorml2", rblapack_dorml2, -1);
+}
diff --git a/ext/dormlq.c b/ext/dormlq.c
new file mode 100644
index 0000000..5eaf2c8
--- /dev/null
+++ b/ext/dormlq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID dormlq_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormlq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.dormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMLQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGELQF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = 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*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormlq", rblapack_dormlq, -1);
+}
diff --git a/ext/dormql.c b/ext/dormql.c
new file mode 100644
index 0000000..0f19a6c
--- /dev/null
+++ b/ext/dormql.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID dormql_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.dormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMQL 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQLF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormql", rblapack_dormql, -1);
+}
diff --git a/ext/dormqr.c b/ext/dormqr.c
new file mode 100644
index 0000000..b6db132
--- /dev/null
+++ b/ext/dormqr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID dormqr_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.dormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMQR 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGEQRF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormqr", rblapack_dormqr, -1);
+}
diff --git a/ext/dormr2.c b/ext/dormr2.c
new file mode 100644
index 0000000..9c60a3f
--- /dev/null
+++ b/ext/dormr2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID dormr2_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dormr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ 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 lda;
+ integer m;
+ integer k;
+ 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.dormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMR2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\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'*C or C*Q' 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.dormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = 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*);
+ {
+ int 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));
+
+ dormr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormr2", rblapack_dormr2, -1);
+}
diff --git a/ext/dormr3.c b/ext/dormr3.c
new file mode 100644
index 0000000..2e3ebb0
--- /dev/null
+++ b/ext/dormr3.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID dormr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dormr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublereal *a;
+ 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 lda;
+ integer m;
+ integer k;
+ 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.dormr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMR3 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DTZRZF.\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'*C or C*Q' 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLARZ, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.dormr3( side, trans, l, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ 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);
+ 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*);
+ {
+ int 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));
+
+ dormr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormr3", rblapack_dormr3, -1);
+}
diff --git a/ext/dormrq.c b/ext/dormrq.c
new file mode 100644
index 0000000..794f540
--- /dev/null
+++ b/ext/dormrq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID dormrq_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.dormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMRQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DGERQF.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = 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*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormrq", rblapack_dormrq, -1);
+}
diff --git a/ext/dormrz.c b/ext/dormrz.c
new file mode 100644
index 0000000..a8535c3
--- /dev/null
+++ b/ext/dormrz.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID dormrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.dormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMRZ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* DTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) DOUBLE PRECISION array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DTZRZF.\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**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ 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);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormrz", rblapack_dormrz, -1);
+}
diff --git a/ext/dormtr.c b/ext/dormtr.c
new file mode 100644
index 0000000..ad49ebb
--- /dev/null
+++ b/ext/dormtr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID dormtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dormtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.dormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DORMTR 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 DSYTRD:\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 triangle of A contains elementary reflectors\n* from DSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from DSYTRD.\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* A (input) DOUBLE PRECISION array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by DSYTRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by DSYTRD.\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/output) DOUBLE PRECISION 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DORMQL, DORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.dormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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];
+ 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);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th 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*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dormtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dormtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dormtr", rblapack_dormtr, -1);
+}
diff --git a/ext/dpbcon.c b/ext/dpbcon.c
new file mode 100644
index 0000000..36dc74c
--- /dev/null
+++ b/ext/dpbcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dpbcon_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dpbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ 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.dpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite band matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the symmetric band matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dpbcon( uplo, kd, ab, anorm, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dpbcon_(&uplo, &n, &kd, ab, &ldab, &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_dpbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbcon", rblapack_dpbcon, -1);
+}
diff --git a/ext/dpbequ.c b/ext/dpbequ.c
new file mode 100644
index 0000000..f226b76
--- /dev/null
+++ b/ext/dpbequ.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID dpbequ_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dpbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 s, scond, amax, info = NumRu::Lapack.dpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPBEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dpbequ( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ dpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dpbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbequ", rblapack_dpbequ, -1);
+}
diff --git a/ext/dpbrfs.c b/ext/dpbrfs.c
new file mode 100644
index 0000000..efa5003
--- /dev/null
+++ b/ext/dpbrfs.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID dpbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dpbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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.dpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A as computed by\n* DPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dpbrfs( uplo, kd, ab, afb, 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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_afb = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, 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_dpbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbrfs", rblapack_dpbrfs, -1);
+}
diff --git a/ext/dpbstf.c b/ext/dpbstf.c
new file mode 100644
index 0000000..7e2343c
--- /dev/null
+++ b/ext/dpbstf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID dpbstf_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_dpbstf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.dpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* DPBSTF computes a split Cholesky factorization of a real\n* symmetric positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with DSBGST.\n*\n* The factorization has the form A = S**T*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**T*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.dpbstf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dpbstf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dpbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbstf", rblapack_dpbstf, -1);
+}
diff --git a/ext/dpbsv.c b/ext/dpbsv.c
new file mode 100644
index 0000000..1773055
--- /dev/null
+++ b/ext/dpbsv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dpbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dpbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, ab, b = NumRu::Lapack.dpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPBSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPBTRF, DPBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.dpbsv( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_dpbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbsv", rblapack_dpbsv, -1);
+}
diff --git a/ext/dpbsvx.c b/ext/dpbsvx.c
new file mode 100644
index 0000000..1945785
--- /dev/null
+++ b/ext/dpbsvx.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID dpbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dpbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_afb_out__;
+ doublereal *afb_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.dpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.dpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublereal*);
+ MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_dpbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbsvx", rblapack_dpbsvx, -1);
+}
diff --git a/ext/dpbtf2.c b/ext/dpbtf2.c
new file mode 100644
index 0000000..05e9a26
--- /dev/null
+++ b/ext/dpbtf2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID dpbtf2_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_dpbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.dpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* DPBTF2 computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the transpose of U, and\n* L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.dpbtf2( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dpbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbtf2", rblapack_dpbtf2, -1);
+}
diff --git a/ext/dpbtrf.c b/ext/dpbtrf.c
new file mode 100644
index 0000000..1758487
--- /dev/null
+++ b/ext/dpbtrf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID dpbtrf_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_dpbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.dpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* DPBTRF computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.dpbtrf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dpbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbtrf", rblapack_dpbtrf, -1);
+}
diff --git a/ext/dpbtrs.c b/ext/dpbtrs.c
new file mode 100644
index 0000000..8cab842
--- /dev/null
+++ b/ext/dpbtrs.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID dpbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dpbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPBTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite band matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by DPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DTBSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpbtrs( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dpbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpbtrs", rblapack_dpbtrs, -1);
+}
diff --git a/ext/dpftrf.c b/ext/dpftrf.c
new file mode 100644
index 0000000..b36faaa
--- /dev/null
+++ b/ext/dpftrf.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dpftrf_(char* transr, char* uplo, integer* n, doublereal* a, integer* info);
+
+
+static VALUE
+rblapack_dpftrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_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, a = NumRu::Lapack.dpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* DPFTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the NT elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**T*U or RFP A = L*L**T.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpftrf( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+
+ dpftrf_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dpftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpftrf", rblapack_dpftrf, -1);
+}
diff --git a/ext/dpftri.c b/ext/dpftri.c
new file mode 100644
index 0000000..db7cd5e
--- /dev/null
+++ b/ext/dpftri.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dpftri_(char* transr, char* uplo, integer* n, doublereal* a, integer* info);
+
+
+static VALUE
+rblapack_dpftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_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, a = NumRu::Lapack.dpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* DPFTRI computes the inverse of a (real) symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by DPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 )\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the symmetric inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpftri( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+
+ dpftri_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dpftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpftri", rblapack_dpftri, -1);
+}
diff --git a/ext/dpftrs.c b/ext/dpftrs.c
new file mode 100644
index 0000000..3016010
--- /dev/null
+++ b/ext/dpftrs.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dpftrs_(char* transr, char* uplo, integer* n, integer* nrhs, doublereal* a, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dpftrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPFTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by DPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ).\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpftrs( transr, uplo, n, a, b, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dpftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpftrs", rblapack_dpftrs, -1);
+}
diff --git a/ext/dpocon.c b/ext/dpocon.c
new file mode 100644
index 0000000..7b1ea53
--- /dev/null
+++ b/ext/dpocon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID dpocon_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dpocon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ 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 rcond, info = NumRu::Lapack.dpocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPOCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dpocon( uplo, a, anorm, [: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_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = NUM2DBL(rblapack_anorm);
+ 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*);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dpocon_(&uplo, &n, a, &lda, &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_dpocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpocon", rblapack_dpocon, -1);
+}
diff --git a/ext/dpoequ.c b/ext/dpoequ.c
new file mode 100644
index 0000000..ad9a647
--- /dev/null
+++ b/ext/dpoequ.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID dpoequ_(integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dpoequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.dpoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dpoequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ dpoequ_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dpoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpoequ", rblapack_dpoequ, -1);
+}
diff --git a/ext/dpoequb.c b/ext/dpoequb.c
new file mode 100644
index 0000000..e449681
--- /dev/null
+++ b/ext/dpoequb.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID dpoequb_(integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dpoequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.dpoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dpoequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ dpoequb_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dpoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpoequb", rblapack_dpoequb, -1);
+}
diff --git a/ext/dporfs.c b/ext/dporfs.c
new file mode 100644
index 0000000..edbc410
--- /dev/null
+++ b/ext/dporfs.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID dporfs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dporfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.dporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPOTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dporfs( uplo, a, af, b, x, [: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_af = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, 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_dporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dporfs", rblapack_dporfs, -1);
+}
diff --git a/ext/dporfsx.c b/ext/dporfsx.c
new file mode 100644
index 0000000..1ca8157
--- /dev/null
+++ b/ext/dporfsx.c
@@ -0,0 +1,206 @@
+#include "rb_lapack.h"
+
+extern VOID dporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dporfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dporfsx( uplo, equed, a, af, s, b, x, params, [: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_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_s = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (5th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_dporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dporfsx", rblapack_dporfsx, -1);
+}
diff --git a/ext/dposv.c b/ext/dposv.c
new file mode 100644
index 0000000..7ea032b
--- /dev/null
+++ b/ext/dposv.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dposv_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dposv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPOSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPOTRF, DPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.dposv( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dposv", rblapack_dposv, -1);
+}
diff --git a/ext/dposvx.c b/ext/dposvx.c
new file mode 100644
index 0000000..d5a04b6
--- /dev/null
+++ b/ext/dposvx.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID dposvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dposvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_af_out__;
+ doublereal *af_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.dposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.dposvx( fact, uplo, a, af, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ 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*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
+ MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_dposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dposvx", rblapack_dposvx, -1);
+}
diff --git a/ext/dposvxx.c b/ext/dposvxx.c
new file mode 100644
index 0000000..49918a0
--- /dev/null
+++ b/ext/dposvxx.c
@@ -0,0 +1,235 @@
+#include "rb_lapack.h"
+
+extern VOID dposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dposvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_af_out__;
+ doublereal *af_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.dposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a double precision system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.dposvxx( fact, uplo, a, af, equed, s, b, params, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ 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*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
+ MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_dposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dposvxx", rblapack_dposvxx, -1);
+}
diff --git a/ext/dpotf2.c b/ext/dpotf2.c
new file mode 100644
index 0000000..130dd5f
--- /dev/null
+++ b/ext/dpotf2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID dpotf2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dpotf2(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.dpotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DPOTF2 computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\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.dpotf2( 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*);
+ {
+ int 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__;
+
+ dpotf2_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dpotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpotf2", rblapack_dpotf2, -1);
+}
diff --git a/ext/dpotrf.c b/ext/dpotrf.c
new file mode 100644
index 0000000..6c91128
--- /dev/null
+++ b/ext/dpotrf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID dpotrf_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dpotrf(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.dpotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DPOTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\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.dpotrf( 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*);
+ {
+ int 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__;
+
+ dpotrf_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dpotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpotrf", rblapack_dpotrf, -1);
+}
diff --git a/ext/dpotri.c b/ext/dpotri.c
new file mode 100644
index 0000000..1374075
--- /dev/null
+++ b/ext/dpotri.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID dpotri_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dpotri(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.dpotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DPOTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, as computed by\n* DPOTRF.\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DLAUUM, DTRTRI, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dpotri( 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*);
+ {
+ int 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__;
+
+ dpotri_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dpotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpotri", rblapack_dpotri, -1);
+}
diff --git a/ext/dpotrs.c b/ext/dpotrs.c
new file mode 100644
index 0000000..76543f0
--- /dev/null
+++ b/ext/dpotrs.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID dpotrs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dpotrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dpotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPOTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.dpotrs( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dpotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpotrs", rblapack_dpotrs, -1);
+}
diff --git a/ext/dppcon.c b/ext/dppcon.c
new file mode 100644
index 0000000..0a1ac06
--- /dev/null
+++ b/ext/dppcon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID dppcon_(char* uplo, integer* n, doublereal* ap, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dppcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *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.dppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite packed matrix using\n* the Cholesky factorization A = U**T*U or A = L*L**T computed by\n* DPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dppcon( uplo, ap, anorm, [: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_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = NUM2DBL(rblapack_anorm);
+ 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*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dppcon_(&uplo, &n, ap, &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_dppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dppcon", rblapack_dppcon, -1);
+}
diff --git a/ext/dppequ.c b/ext/dppequ.c
new file mode 100644
index 0000000..d0a51d2
--- /dev/null
+++ b/ext/dppequ.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID dppequ_(char* uplo, integer* n, doublereal* ap, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_dppequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.dppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* DPPEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dppequ( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ dppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dppequ", rblapack_dppequ, -1);
+}
diff --git a/ext/dpprfs.c b/ext/dpprfs.c
new file mode 100644
index 0000000..f32190f
--- /dev/null
+++ b/ext/dpprfs.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID dpprfs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dpprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_afp;
+ doublereal *afp;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *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, x = NumRu::Lapack.dpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dpprfs( uplo, ap, afp, b, x, [: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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n = ldb;
+ 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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dpprfs_(&uplo, &n, &nrhs, ap, afp, 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_dpprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpprfs", rblapack_dpprfs, -1);
+}
diff --git a/ext/dppsv.c b/ext/dppsv.c
new file mode 100644
index 0000000..04b66c3
--- /dev/null
+++ b/ext/dppsv.c
@@ -0,0 +1,104 @@
+#include "rb_lapack.h"
+
+extern VOID dppsv_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dppsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPPTRF, DPPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.dppsv( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_dppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dppsv", rblapack_dppsv, -1);
+}
diff --git a/ext/dppsvx.c b/ext/dppsvx.c
new file mode 100644
index 0000000..452e4d8
--- /dev/null
+++ b/ext/dppsvx.c
@@ -0,0 +1,191 @@
+#include "rb_lapack.h"
+
+extern VOID dppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dppsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_afp;
+ doublereal *afp;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ VALUE rblapack_afp_out__;
+ doublereal *afp_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ doublereal *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 x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.dppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) DOUBLE PRECISION array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L', in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the original matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.dppsvx( fact, uplo, ap, afp, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th 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*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublereal*);
+ MEMCPY(afp_out__, afp, doublereal, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_dppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dppsvx", rblapack_dppsvx, -1);
+}
diff --git a/ext/dpptrf.c b/ext/dpptrf.c
new file mode 100644
index 0000000..1f7d078
--- /dev/null
+++ b/ext/dpptrf.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID dpptrf_(char* uplo, integer* n, doublereal* ap, integer* info);
+
+
+static VALUE
+rblapack_dpptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *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.dpptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* DPPTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ======= =======\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dpptrf( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dpptrf_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dpptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpptrf", rblapack_dpptrf, -1);
+}
diff --git a/ext/dpptri.c b/ext/dpptri.c
new file mode 100644
index 0000000..757d71e
--- /dev/null
+++ b/ext/dpptri.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID dpptri_(char* uplo, integer* n, doublereal* ap, integer* info);
+
+
+static VALUE
+rblapack_dpptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *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.dpptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* DPPTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by DPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dpptri( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dpptri_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dpptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpptri", rblapack_dpptri, -1);
+}
diff --git a/ext/dpptrs.c b/ext/dpptrs.c
new file mode 100644
index 0000000..e0d5ad4
--- /dev/null
+++ b/ext/dpptrs.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID dpptrs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dpptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPPTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**T*U or A = L*L**T computed by DPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpptrs( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dpptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpptrs", rblapack_dpptrs, -1);
+}
diff --git a/ext/dpstf2.c b/ext/dpstf2.c
new file mode 100644
index 0000000..96a06ed
--- /dev/null
+++ b/ext/dpstf2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID dpstf2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dpstf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.dpstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPSTF2 computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.dpstf2( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = NUM2DBL(rblapack_tol);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ dpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dpstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpstf2", rblapack_dpstf2, -1);
+}
diff --git a/ext/dpstrf.c b/ext/dpstrf.c
new file mode 100644
index 0000000..f639e97
--- /dev/null
+++ b/ext/dpstrf.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID dpstrf_(char* uplo, integer* n, doublereal* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dpstrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.dpstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPSTRF computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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) DOUBLE PRECISION 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.dpstrf( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = NUM2DBL(rblapack_tol);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ dpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dpstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpstrf", rblapack_dpstrf, -1);
+}
diff --git a/ext/dptcon.c b/ext/dptcon.c
new file mode 100644
index 0000000..c62a397
--- /dev/null
+++ b/ext/dptcon.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID dptcon_(integer* n, doublereal* d, doublereal* e, doublereal* anorm, doublereal* rcond, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dptcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ 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 rcond, info = NumRu::Lapack.dptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite tridiagonal matrix\n* using the factorization A = L*D*L**T or A = U**T*D*U computed by\n* DPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by DPTTRF.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by DPTTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal of the condition number of the matrix A,\n* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n* 1-norm of inv(A) computed in this routine.\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.dptcon( d, e, anorm, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ anorm = NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ work = ALLOC_N(doublereal, (n));
+
+ dptcon_(&n, d, e, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_dptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dptcon", rblapack_dptcon, -1);
+}
diff --git a/ext/dpteqr.c b/ext/dpteqr.c
new file mode 100644
index 0000000..f331c5d
--- /dev/null
+++ b/ext/dpteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID dpteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dpteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.dpteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using DPTTRF, and then calling DBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band symmetric positive definite matrix\n* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n* form, however, may preclude the possibility of obtaining high\n* relative accuracy in the small eigenvalues of the original matrix, if\n* these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original symmetric\n* matrix also. Array Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal\n* matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original symmetric matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.dpteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(doublereal, (4*n));
+
+ dpteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_dpteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpteqr", rblapack_dpteqr, -1);
+}
diff --git a/ext/dptrfs.c b/ext/dptrfs.c
new file mode 100644
index 0000000..bb38c9e
--- /dev/null
+++ b/ext/dptrfs.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID dptrfs_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* df, doublereal* ef, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dptrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_df;
+ doublereal *df;
+ VALUE rblapack_ef;
+ doublereal *ef;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *work;
+
+ 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.dptrfs( d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization computed by DPTTRF.\n*\n* EF (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the factorization computed by DPTTRF.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DPTTRS.\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) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (2*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.dptrfs( d, e, df, ef, 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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_df = argv[2];
+ rblapack_ef = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (3th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (3th 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_DFLOAT)
+ rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
+ df = NA_PTR_TYPE(rblapack_df, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_ef))
+ rb_raise(rb_eArgError, "ef (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_DFLOAT)
+ rblapack_ef = na_change_type(rblapack_ef, NA_DFLOAT);
+ ef = NA_PTR_TYPE(rblapack_ef, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ dptrfs_(&n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_dptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dptrfs", rblapack_dptrfs, -1);
+}
diff --git a/ext/dptsv.c b/ext/dptsv.c
new file mode 100644
index 0000000..c1d21c3
--- /dev/null
+++ b/ext/dptsv.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID dptsv_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dptsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.dptsv( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPTSV computes the solution to a real system of linear equations\n* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**T, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**T.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**T factorization of\n* A. (E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**T*D*U factorization of A.)\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL DPTTRF, DPTTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.dptsv( d, e, b, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dptsv_(&n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_dptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dptsv", rblapack_dptsv, -1);
+}
diff --git a/ext/dptsvx.c b/ext/dptsvx.c
new file mode 100644
index 0000000..780bd65
--- /dev/null
+++ b/ext/dptsvx.c
@@ -0,0 +1,168 @@
+#include "rb_lapack.h"
+
+extern VOID dptsvx_(char* fact, integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* df, doublereal* ef, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dptsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_df;
+ doublereal *df;
+ VALUE rblapack_ef;
+ doublereal *ef;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_df_out__;
+ doublereal *df_out__;
+ VALUE rblapack_ef_out__;
+ doublereal *ef_out__;
+ doublereal *work;
+
+ 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 x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.dptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DPTSVX uses the factorization A = L*D*L**T to compute the solution\n* to a real system of linear equations A*X = B, where A is an N-by-N\n* symmetric positive definite tridiagonal matrix and X and B are\n* N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**T*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) DOUBLE PRECISION array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n*\n* EF (input or output) DOUBLE PRECISION array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The componentwise relative backward error of each solution\n* vector X(j) (i.e., the smallest relative change in any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.dptsvx( fact, d, e, df, ef, b, [: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_fact = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_df = argv[3];
+ rblapack_ef = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (4th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_df);
+ if (NA_TYPE(rblapack_df) != NA_DFLOAT)
+ rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
+ df = NA_PTR_TYPE(rblapack_df, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 df");
+ 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_ef))
+ rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_DFLOAT)
+ rblapack_ef = na_change_type(rblapack_ef, NA_DFLOAT);
+ ef = NA_PTR_TYPE(rblapack_ef, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublereal*);
+ MEMCPY(df_out__, df, doublereal, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_ef_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, doublereal*);
+ MEMCPY(ef_out__, ef, doublereal, NA_TOTAL(rblapack_ef));
+ rblapack_ef = rblapack_ef_out__;
+ ef = ef_out__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ dptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
+}
+
+void
+init_lapack_dptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dptsvx", rblapack_dptsvx, -1);
+}
diff --git a/ext/dpttrf.c b/ext/dpttrf.c
new file mode 100644
index 0000000..d128440
--- /dev/null
+++ b/ext/dpttrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID dpttrf_(integer* n, doublereal* d, doublereal* e, integer* info);
+
+
+static VALUE
+rblapack_dpttrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ 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, d, e = NumRu::Lapack.dpttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* DPTTRF computes the L*D*L' factorization of a real symmetric\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.dpttrf( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ dpttrf_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dpttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpttrf", rblapack_dpttrf, -1);
+}
diff --git a/ext/dpttrs.c b/ext/dpttrs.c
new file mode 100644
index 0000000..5435023
--- /dev/null
+++ b/ext/dpttrs.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dpttrs_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dpttrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dpttrs( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by DPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n INTEGER J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DPTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dpttrs( d, e, b, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dpttrs_(&n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dpttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dpttrs", rblapack_dpttrs, -1);
+}
diff --git a/ext/dptts2.c b/ext/dptts2.c
new file mode 100644
index 0000000..d9d6812
--- /dev/null
+++ b/ext/dptts2.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID dptts2_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb);
+
+
+static VALUE
+rblapack_dptts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.dptts2( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* DPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by DPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL DSCAL\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.dptts2( d, e, b, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dptts2_(&n, &nrhs, d, e, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_dptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dptts2", rblapack_dptts2, -1);
+}
diff --git a/ext/drscl.c b/ext/drscl.c
new file mode 100644
index 0000000..a5a3b5b
--- /dev/null
+++ b/ext/drscl.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID drscl_(integer* n, doublereal* sa, doublereal* sx, integer* incx);
+
+
+static VALUE
+rblapack_drscl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_sa;
+ doublereal sa;
+ VALUE rblapack_sx;
+ doublereal *sx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_sx_out__;
+ doublereal *sx_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 sx = NumRu::Lapack.drscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* DRSCL multiplies an n-element real vector x by the real scalar 1/a.\n* This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) DOUBLE PRECISION\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) DOUBLE PRECISION array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sx = NumRu::Lapack.drscl( n, sa, sx, incx, [: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_n = argv[0];
+ rblapack_sa = argv[1];
+ rblapack_sx = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ sa = NUM2DBL(rblapack_sa);
+ if (!NA_IsNArray(rblapack_sx))
+ rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
+ if (NA_RANK(rblapack_sx) != 1)
+ rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
+ if (NA_TYPE(rblapack_sx) != NA_DFLOAT)
+ rblapack_sx = na_change_type(rblapack_sx, NA_DFLOAT);
+ sx = NA_PTR_TYPE(rblapack_sx, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*abs(incx);
+ rblapack_sx_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, doublereal*);
+ MEMCPY(sx_out__, sx, doublereal, NA_TOTAL(rblapack_sx));
+ rblapack_sx = rblapack_sx_out__;
+ sx = sx_out__;
+
+ drscl_(&n, &sa, sx, &incx);
+
+ return rblapack_sx;
+}
+
+void
+init_lapack_drscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "drscl", rblapack_drscl, -1);
+}
diff --git a/ext/dsbev.c b/ext/dsbev.c
new file mode 100644
index 0000000..f5310ac
--- /dev/null
+++ b/ext/dsbev.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dsbev_(char* jobz, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsbev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ab = NumRu::Lapack.dsbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.dsbev( jobz, uplo, kd, ab, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(doublereal, (MAX(1,3*n-2)));
+
+ dsbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dsbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbev", rblapack_dsbev, -1);
+}
diff --git a/ext/dsbevd.c b/ext/dsbevd.c
new file mode 100644
index 0000000..3d95dd6
--- /dev/null
+++ b/ext/dsbevd.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID dsbevd_(char* jobz, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dsbevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ab = NumRu::Lapack.dsbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A. If eigenvectors are desired, it uses\n* a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* IF N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 2, LWORK must be at least\n* ( 1 + 5*N + 2*N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array LIWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab = NumRu::Lapack.dsbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 6) {
+ rblapack_lwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=0 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ dsbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dsbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbevd", rblapack_dsbevd, -1);
+}
diff --git a/ext/dsbevx.c b/ext/dsbevx.c
new file mode 100644
index 0000000..371ea2d
--- /dev/null
+++ b/ext/dsbevx.c
@@ -0,0 +1,157 @@
+#include "rb_lapack.h"
+
+extern VOID dsbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dsbevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, ifail, info, ab = NumRu::Lapack.dsbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric band matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.dsbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vu = argv[6];
+ rblapack_il = argv[7];
+ rblapack_iu = argv[8];
+ rblapack_abstol = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ vu = NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
+ range = StringValueCStr(rblapack_range)[0];
+ vl = NUM2DBL(rblapack_vl);
+ abstol = NUM2DBL(rblapack_abstol);
+ kd = NUM2INT(rblapack_kd);
+ il = NUM2INT(rblapack_il);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(doublereal, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ dsbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dsbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbevx", rblapack_dsbevx, -1);
+}
diff --git a/ext/dsbgst.c b/ext/dsbgst.c
new file mode 100644
index 0000000..cc606ac
--- /dev/null
+++ b/ext/dsbgst.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID dsbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* x, integer* ldx, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsbgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_bb;
+ doublereal *bb;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ 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 x, info, ab = NumRu::Lapack.dsbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBGST reduces a real symmetric-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**T*S by DPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**T*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) DOUBLE PRECISION array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by DPBSTF, stored in the first KB+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*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 x, info, ab = NumRu::Lapack.dsbgst( vect, uplo, ka, kb, ab, bb, [: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_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
+ kb = NUM2INT(rblapack_kb);
+ ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ dsbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_dsbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbgst", rblapack_dsbgst, -1);
+}
diff --git a/ext/dsbgv.c b/ext/dsbgv.c
new file mode 100644
index 0000000..3f684f1
--- /dev/null
+++ b/ext/dsbgv.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID dsbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsbgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_bb;
+ doublereal *bb;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_bb_out__;
+ doublereal *bb_out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, info, ab, bb = NumRu::Lapack.dsbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by DPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.dsbgv( jobz, uplo, ka, kb, ab, bb, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
+ kb = NUM2INT(rblapack_kb);
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublereal*);
+ MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+ work = ALLOC_N(doublereal, (3*n));
+
+ dsbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_dsbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbgv", rblapack_dsbgv, -1);
+}
diff --git a/ext/dsbgvd.c b/ext/dsbgvd.c
new file mode 100644
index 0000000..cf5163d
--- /dev/null
+++ b/ext/dsbgvd.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+extern VOID dsbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dsbgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_bb;
+ doublereal *bb;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_bb_out__;
+ doublereal *bb_out__;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ab, bb = NumRu::Lapack.dsbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of the\n* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and\n* banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by DPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab, bb = NumRu::Lapack.dsbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 8) {
+ rblapack_lwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ kb = NUM2INT(rblapack_kb);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 3*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublereal*);
+ MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+
+ dsbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_dsbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbgvd", rblapack_dsbgvd, -1);
+}
diff --git a/ext/dsbgvx.c b/ext/dsbgvx.c
new file mode 100644
index 0000000..1532334
--- /dev/null
+++ b/ext/dsbgvx.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID dsbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dsbgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_bb;
+ doublereal *bb;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_bb_out__;
+ doublereal *bb_out__;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.dsbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSBGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by DPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvalues that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* < 0 : if INFO = -i, the i-th argument had an illegal value\n* <= N: if INFO = i, then i eigenvectors failed to converge.\n* Their indices are stored in IFAIL.\n* > N : DPBSTF returned an error code; i.e.,\n* if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.dsbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ka = argv[3];
+ rblapack_kb = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_bb = argv[6];
+ rblapack_vl = argv[7];
+ rblapack_vu = argv[8];
+ rblapack_il = argv[9];
+ rblapack_iu = argv[10];
+ rblapack_abstol = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kb = NUM2INT(rblapack_kb);
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ n = NA_SHAPE1(rblapack_bb);
+ if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
+ vu = NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ il = NUM2INT(rblapack_il);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
+ ka = NUM2INT(rblapack_ka);
+ abstol = NUM2DBL(rblapack_abstol);
+ vl = NUM2DBL(rblapack_vl);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 7*n;
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 5*n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublereal*);
+ MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+
+ dsbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_dsbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbgvx", rblapack_dsbgvx, -1);
+}
diff --git a/ext/dsbtrd.c b/ext/dsbtrd.c
new file mode 100644
index 0000000..4528f40
--- /dev/null
+++ b/ext/dsbtrd.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID dsbtrd_(char* vect, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* d, doublereal* e, doublereal* q, integer* ldq, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsbtrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublereal *ab_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.dsbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSBTRD reduces a real symmetric band matrix A to symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.dsbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
+ MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(doublereal, (n));
+
+ dsbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
+}
+
+void
+init_lapack_dsbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsbtrd", rblapack_dsbtrd, -1);
+}
diff --git a/ext/dsfrk.c b/ext/dsfrk.c
new file mode 100644
index 0000000..fe753a4
--- /dev/null
+++ b/ext/dsfrk.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID dsfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, doublereal* alpha, doublereal* a, integer* lda, doublereal* beta, doublereal* c);
+
+
+static VALUE
+rblapack_dsfrk(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ integer lda;
+ integer nt;
+
+ 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.dsfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* DSFRK performs one of the symmetric rank--k operations\n*\n* C := alpha*A*A' + beta*C,\n*\n* or\n*\n* C := alpha*A'*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n symmetric\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.\n*\n* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with TRANS = 'T'\n* or 't', K specifies the number of rows of the matrix A. K\n* must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n*\n* C (input/output) DOUBLE PRECISION array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n* Format. RFP Format is described by TRANSR, UPLO and N.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.dsfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_n = argv[3];
+ rblapack_k = argv[4];
+ rblapack_alpha = argv[5];
+ rblapack_a = argv[6];
+ rblapack_beta = argv[7];
+ rblapack_c = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ k = NUM2INT(rblapack_k);
+ beta = NUM2DBL(rblapack_beta);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ nt = NA_SHAPE0(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*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ if (NA_SHAPE1(rblapack_a) != (lsame_(&trans,"N") ? k : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nt;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+
+ dsfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
+
+ return rblapack_c;
+}
+
+void
+init_lapack_dsfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsfrk", rblapack_dsfrk, -1);
+}
diff --git a/ext/dsgesv.c b/ext/dsgesv.c
new file mode 100644
index 0000000..450b220
--- /dev/null
+++ b/ext/dsgesv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID dsgesv_(integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* work, real* swork, integer* iter, integer* info);
+
+
+static VALUE
+rblapack_dsgesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_iter;
+ integer iter;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+ real *swork;
+
+ integer lda;
+ 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 ipiv, x, iter, info, a = NumRu::Lapack.dsgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* DSGESV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* DSGESV first attempts to factorize the matrix in SINGLE PRECISION\n* and use this factorization within an iterative refinement procedure\n* to produce a solution with DOUBLE PRECISION normwise backward error\n* quality (see below). If the approach fails the method switches to a\n* DOUBLE PRECISION factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n* performance is too small. A reasonable strategy should take the\n* number of right-hand sides and the size of the matrix into account.\n* This might be done with a call to ILAENV in the future. Up to now, we\n* always try iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array,\n* dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n* Corresponds either to the single precision factorization\n* (if INFO.EQ.0 and ITER.GE.0) or the double precision\n* factorization (if INFO.EQ.0 and ITER.LT.0).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) REAL array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, double precision\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of SGETRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, U(i,i) computed in DOUBLE PRECISION is\n* exactly zero. The factorization has been completed,\n* but the factor U is exactly singular, so the solution\n* could not be computed.\n*\n* =========\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, x, iter, info, a = NumRu::Lapack.dsgesv( 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);
+ 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*);
+ ldx = MAX(1,n);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n)*(nrhs));
+ swork = ALLOC_N(real, (n*(n+nrhs)));
+
+ dsgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, x, &ldx, work, swork, &iter, &info);
+
+ free(work);
+ free(swork);
+ rblapack_iter = INT2NUM(iter);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsgesv", rblapack_dsgesv, -1);
+}
diff --git a/ext/dspcon.c b/ext/dspcon.c
new file mode 100644
index 0000000..9dee1d6
--- /dev/null
+++ b/ext/dspcon.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID dspcon_(char* uplo, integer* n, doublereal* ap, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dspcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *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.dspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric packed matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dspcon( uplo, ap, ipiv, anorm, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublereal, (2*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dspcon_(&uplo, &n, ap, 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_dspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspcon", rblapack_dspcon, -1);
+}
diff --git a/ext/dspev.c b/ext/dspev.c
new file mode 100644
index 0000000..178f1ad
--- /dev/null
+++ b/ext/dspev.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID dspev_(char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dspev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ doublereal *work;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap = NumRu::Lapack.dspev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.dspev( jobz, uplo, ap, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(doublereal, (3*n));
+
+ dspev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dspev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspev", rblapack_dspev, -1);
+}
diff --git a/ext/dspevd.c b/ext/dspevd.c
new file mode 100644
index 0000000..3d66802
--- /dev/null
+++ b/ext/dspevd.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID dspevd_(char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dspevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ap = NumRu::Lapack.dspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPEVD computes all the eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least\n* 1 + 6*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap = NumRu::Lapack.dspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 5) {
+ rblapack_lwork = argv[3];
+ rblapack_liwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+n*n : 2;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dspevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dspevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspevd", rblapack_dspevd, -1);
+}
diff --git a/ext/dspevx.c b/ext/dspevx.c
new file mode 100644
index 0000000..83068f1
--- /dev/null
+++ b/ext/dspevx.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID dspevx_(char* jobz, char* range, char* uplo, integer* n, doublereal* ap, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dspevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap = NumRu::Lapack.dspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. Eigenvalues/vectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.dspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(doublereal, (8*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ dspevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dspevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspevx", rblapack_dspevx, -1);
+}
diff --git a/ext/dspgst.c b/ext/dspgst.c
new file mode 100644
index 0000000..0f16ed1
--- /dev/null
+++ b/ext/dspgst.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID dspgst_(integer* itype, char* uplo, integer* n, doublereal* ap, doublereal* bp, integer* info);
+
+
+static VALUE
+rblapack_dspgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_bp;
+ doublereal *bp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *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.dspgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* DSPGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by DPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by DPPTRF.\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, ap = NumRu::Lapack.dspgst( itype, uplo, n, ap, bp, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
+ 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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dspgst_(&itype, &uplo, &n, ap, bp, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dspgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspgst", rblapack_dspgst, -1);
+}
diff --git a/ext/dspgv.c b/ext/dspgv.c
new file mode 100644
index 0000000..432aeba
--- /dev/null
+++ b/ext/dspgv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID dspgv_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* bp, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dspgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_bp;
+ doublereal *bp;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ VALUE rblapack_bp_out__;
+ doublereal *bp_out__;
+ doublereal *work;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap, bp = NumRu::Lapack.dspgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension\n* (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: DPPTRF or DSPEV returned an error code:\n* <= N: if INFO = i, DSPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero.\n* > N: if INFO = n + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.dspgv( itype, jobz, uplo, ap, bp, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublereal*);
+ MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(doublereal, (3*n));
+
+ dspgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_dspgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspgv", rblapack_dspgv, -1);
+}
diff --git a/ext/dspgvd.c b/ext/dspgvd.c
new file mode 100644
index 0000000..a94ce60
--- /dev/null
+++ b/ext/dspgvd.c
@@ -0,0 +1,162 @@
+#include "rb_lapack.h"
+
+extern VOID dspgvd_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* bp, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dspgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_bp;
+ doublereal *bp;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ VALUE rblapack_bp_out__;
+ doublereal *bp_out__;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ap, bp = NumRu::Lapack.dspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: DPPTRF or DSPEVD returned an error code:\n* <= N: if INFO = i, DSPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap, bp = NumRu::Lapack.dspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 7) {
+ rblapack_lwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublereal*);
+ MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+
+ dspgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_dspgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspgvd", rblapack_dspgvd, -1);
+}
diff --git a/ext/dspgvx.c b/ext/dspgvx.c
new file mode 100644
index 0000000..ae49519
--- /dev/null
+++ b/ext/dspgvx.c
@@ -0,0 +1,168 @@
+#include "rb_lapack.h"
+
+extern VOID dspgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublereal* ap, doublereal* bp, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dspgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_bp;
+ doublereal *bp;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ VALUE rblapack_bp_out__;
+ doublereal *bp_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap, bp = NumRu::Lapack.dspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSPGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric, stored in packed storage, and B\n* is also positive definite. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: DPPTRF or DSPEVX returned an error code:\n* <= N: if INFO = i, DSPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.dspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_bp = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vu = argv[7];
+ rblapack_il = argv[8];
+ rblapack_iu = argv[9];
+ rblapack_abstol = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ 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);
+ 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*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ vu = NUM2DBL(rblapack_vu);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublereal*);
+ MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(doublereal, (8*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ dspgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_dspgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspgvx", rblapack_dspgvx, -1);
+}
diff --git a/ext/dsposv.c b/ext/dsposv.c
new file mode 100644
index 0000000..c2c75b1
--- /dev/null
+++ b/ext/dsposv.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID dsposv_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* work, real* swork, integer* iter, integer* info);
+
+
+static VALUE
+rblapack_dsposv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_iter;
+ integer iter;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+ real *swork;
+
+ integer lda;
+ 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 x, iter, info, a = NumRu::Lapack.dsposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* DSPOSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* DSPOSV first attempts to factorize the matrix in SINGLE PRECISION\n* and use this factorization within an iterative refinement procedure\n* to produce a solution with DOUBLE PRECISION normwise backward error\n* quality (see below). If the approach fails the method switches to a\n* DOUBLE PRECISION factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n* performance is too small. A reasonable strategy should take the\n* number of right-hand sides and the size of the matrix into account.\n* This might be done with a call to ILAENV in the future. Up to now, we\n* always try iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array,\n* 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* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) REAL array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, double precision\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of SPOTRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, the leading minor of order i of (DOUBLE\n* PRECISION) A is not positive definite, so the\n* factorization could not be completed, and the solution\n* has not been computed.\n*\n* =========\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iter, info, a = NumRu::Lapack.dsposv( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n)*(nrhs));
+ swork = ALLOC_N(real, (n*(n+nrhs)));
+
+ dsposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, work, swork, &iter, &info);
+
+ free(work);
+ free(swork);
+ rblapack_iter = INT2NUM(iter);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsposv", rblapack_dsposv, -1);
+}
diff --git a/ext/dsprfs.c b/ext/dsprfs.c
new file mode 100644
index 0000000..310f12b
--- /dev/null
+++ b/ext/dsprfs.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID dsprfs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dsprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_afp;
+ doublereal *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *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.dsprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by DSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DSPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dsprfs( uplo, ap, afp, ipiv, 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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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 (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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ 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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ 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);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dsprfs_(&uplo, &n, &nrhs, ap, afp, 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_dsprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsprfs", rblapack_dsprfs, -1);
+}
diff --git a/ext/dspsv.c b/ext/dspsv.c
new file mode 100644
index 0000000..e0526c2
--- /dev/null
+++ b/ext/dspsv.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID dspsv_(char* uplo, integer* n, integer* nrhs, doublereal* ap, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dspsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldb;
+ integer nrhs;
+ 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 ipiv, info, ap, b = NumRu::Lapack.dspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by DSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSPTRF, DSPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.dspsv( uplo, ap, b, [: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_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n = ldb;
+ 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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_dspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspsv", rblapack_dspsv, -1);
+}
diff --git a/ext/dspsvx.c b/ext/dspsvx.c
new file mode 100644
index 0000000..636ac4b
--- /dev/null
+++ b/ext/dspsvx.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID dspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dspsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_afp;
+ doublereal *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_afp_out__;
+ doublereal *afp_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ doublereal *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 x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.dspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a real system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) DOUBLE PRECISION array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by DSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by DSPTRF.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.dspsvx( fact, uplo, ap, afp, ipiv, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ ldx = MAX(1,n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublereal*);
+ MEMCPY(afp_out__, afp, doublereal, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
+}
+
+void
+init_lapack_dspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dspsvx", rblapack_dspsvx, -1);
+}
diff --git a/ext/dsptrd.c b/ext/dsptrd.c
new file mode 100644
index 0000000..76f9b68
--- /dev/null
+++ b/ext/dsptrd.c
@@ -0,0 +1,100 @@
+#include "rb_lapack.h"
+
+extern VOID dsptrd_(char* uplo, integer* n, doublereal* ap, doublereal* d, doublereal* e, doublereal* tau, integer* info);
+
+
+static VALUE
+rblapack_dsptrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+
+ 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 d, e, tau, info, ap = NumRu::Lapack.dsptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRD reduces a real symmetric matrix A stored in packed form to\n* symmetric tridiagonal form T by an orthogonal similarity\n* transformation: Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.dsptrd( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dsptrd_(&uplo, &n, ap, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dsptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsptrd", rblapack_dsptrd, -1);
+}
diff --git a/ext/dsptrf.c b/ext/dsptrf.c
new file mode 100644
index 0000000..d62bf4b
--- /dev/null
+++ b/ext/dsptrf.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID dsptrf_(char* uplo, integer* n, doublereal* ap, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_dsptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_out__;
+
+ 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 ipiv, info, ap = NumRu::Lapack.dsptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRF computes the factorization of a real symmetric matrix A stored\n* in packed format using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.dsptrf( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dsptrf_(&uplo, &n, ap, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dsptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsptrf", rblapack_dsptrf, -1);
+}
diff --git a/ext/dsptri.c b/ext/dsptri.c
new file mode 100644
index 0000000..beffe20
--- /dev/null
+++ b/ext/dsptri.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID dsptri_(char* uplo, integer* n, doublereal* ap, integer* ipiv, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *ap_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 info, ap = NumRu::Lapack.dsptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRI computes the inverse of a real symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by DSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* WORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.dsptri( uplo, ap, ipiv, [: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_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(doublereal, (n));
+
+ dsptri_(&uplo, &n, ap, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dsptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsptri", rblapack_dsptri, -1);
+}
diff --git a/ext/dsptrs.c b/ext/dsptrs.c
new file mode 100644
index 0000000..eed6cfa
--- /dev/null
+++ b/ext/dsptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dsptrs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dsptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dsptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSPTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSPTRF.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.dsptrs( uplo, ap, ipiv, b, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dsptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dsptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsptrs", rblapack_dsptrs, -1);
+}
diff --git a/ext/dstebz.c b/ext/dstebz.c
new file mode 100644
index 0000000..3967e4c
--- /dev/null
+++ b/ext/dstebz.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID dstebz_(char* range, char* order, integer* n, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, doublereal* d, doublereal* e, integer* m, integer* nsplit, doublereal* w, integer* iblock, integer* isplit, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dstebz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_order;
+ char order;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *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 m, nsplit, w, iblock, isplit, info = NumRu::Lapack.dstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEBZ computes the eigenvalues of a symmetric tridiagonal\n* matrix T. The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute tolerance for the eigenvalues. An eigenvalue\n* (or cluster) is considered to be located if it has been\n* determined to lie in an interval whose width is ABSTOL or\n* less. If ABSTOL is less than or equal to zero, then ULP*|T|\n* will be used, where |T| means the 1-norm of T.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* NSPLIT (output) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalues. (DSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (DSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* RELFAC DOUBLE PRECISION, default = 2.0e0\n* The relative tolerance. An interval (a,b] lies within\n* \"relative tolerance\" if b-a < RELFAC*ulp*max(|a|,|b|),\n* where \"ulp\" is the machine precision (distance from 1 to\n* the next larger floating point number.)\n*\n* FUDGE DOUBLE PRECISION, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, nsplit, w, iblock, isplit, info = NumRu::Lapack.dstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_range = argv[0];
+ rblapack_order = argv[1];
+ rblapack_vl = argv[2];
+ rblapack_vu = argv[3];
+ rblapack_il = argv[4];
+ rblapack_iu = argv[5];
+ rblapack_abstol = argv[6];
+ rblapack_d = argv[7];
+ rblapack_e = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ range = StringValueCStr(rblapack_range)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ order = StringValueCStr(rblapack_order)[0];
+ iu = NUM2INT(rblapack_iu);
+ vu = NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (8th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (9th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (3*n));
+
+ dstebz_(&range, &order, &n, &vl, &vu, &il, &iu, &abstol, d, e, &m, &nsplit, w, iblock, isplit, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_nsplit = INT2NUM(nsplit);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_m, rblapack_nsplit, rblapack_w, rblapack_iblock, rblapack_isplit, rblapack_info);
+}
+
+void
+init_lapack_dstebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstebz", rblapack_dstebz, -1);
+}
diff --git a/ext/dstedc.c b/ext/dstedc.c
new file mode 100644
index 0000000..765e56e
--- /dev/null
+++ b/ext/dstedc.c
@@ -0,0 +1,159 @@
+#include "rb_lapack.h"
+
+extern VOID dstedc_(char* compz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dstedc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 work, iwork, info, d, e, z = NumRu::Lapack.dstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band real symmetric matrix can also be\n* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See DLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original dense symmetric\n* matrix also. On entry, Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be max(1,2*(N-1)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LIWORK must be at least\n* ( 6 + 6*N + 5*N*lg N ).\n* If COMPZ = 'I' and N > 1 then LIWORK must be at least\n* ( 3 + 5*N ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, iwork, info, d, e, z = NumRu::Lapack.dstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 6) {
+ rblapack_lwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 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 (rblapack_lwork == Qnil)
+ lwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_dstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstedc", rblapack_dstedc, -1);
+}
diff --git a/ext/dstegr.c b/ext/dstegr.c
new file mode 100644
index 0000000..087dee3
--- /dev/null
+++ b/ext/dstegr.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID dstegr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dstegr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* DSTEGR is a compatability wrapper around the improved DSTEMR routine.\n* See DSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : DSTEGR and DSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in DLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* DLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL DSTEMR\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ dstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstegr", rblapack_dstegr, -1);
+}
diff --git a/ext/dstein.c b/ext/dstein.c
new file mode 100644
index 0000000..8d8431e
--- /dev/null
+++ b/ext/dstein.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID dstein_(integer* n, doublereal* d, doublereal* e, integer* m, doublereal* w, integer* iblock, integer* isplit, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dstein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.dstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from DSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from DSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from DSTEBZ is expected here. )\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.dstein( d, e, w, iblock, isplit, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_w = argv[2];
+ rblapack_iblock = argv[3];
+ rblapack_isplit = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ m = n;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ ldz = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = m;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ work = ALLOC_N(doublereal, (5*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
+}
+
+void
+init_lapack_dstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstein", rblapack_dstein, -1);
+}
diff --git a/ext/dstemr.c b/ext/dstemr.c
new file mode 100644
index 0000000..7d7782c
--- /dev/null
+++ b/ext/dstemr.c
@@ -0,0 +1,193 @@
+#include "rb_lapack.h"
+
+extern VOID dstemr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dstemr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_nzc;
+ integer nzc;
+ VALUE rblapack_tryrac;
+ logical tryrac;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.dstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.DSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in DLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* DLARRV, respectively.\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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.dstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_nzc = argv[8];
+ rblapack_tryrac = argv[9];
+ if (argc == 12) {
+ rblapack_lwork = argv[10];
+ rblapack_liwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ nzc = NUM2INT(rblapack_nzc);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ tryrac = (rblapack_tryrac == Qtrue);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ dstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ rblapack_tryrac = tryrac ? Qtrue : Qfalse;
+ return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
+}
+
+void
+init_lapack_dstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstemr", rblapack_dstemr, -1);
+}
diff --git a/ext/dsteqr.c b/ext/dsteqr.c
new file mode 100644
index 0000000..a1c6c2c
--- /dev/null
+++ b/ext/dsteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID dsteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.dsteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band symmetric matrix can also be found\n* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to\n* tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* symmetric matrix. On entry, Z must contain the\n* orthogonal matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is orthogonally similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.dsteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(doublereal, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
+
+ dsteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_dsteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsteqr", rblapack_dsteqr, -1);
+}
diff --git a/ext/dsterf.c b/ext/dsterf.c
new file mode 100644
index 0000000..50046d9
--- /dev/null
+++ b/ext/dsterf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID dsterf_(integer* n, doublereal* d, doublereal* e, integer* info);
+
+
+static VALUE
+rblapack_dsterf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ 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, d, e = NumRu::Lapack.dsterf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTERF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n* using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed to find all of the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.dsterf( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ dsterf_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dsterf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsterf", rblapack_dsterf, -1);
+}
diff --git a/ext/dstev.c b/ext/dstev.c
new file mode 100644
index 0000000..fb3b147
--- /dev/null
+++ b/ext/dstev.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID dstev_(char* jobz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dstev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldz;
+
+ 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 z, info, d, e = NumRu::Lapack.dstev( jobz, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n* If JOBZ = 'N', WORK is not referenced.\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, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, info, d, e = NumRu::Lapack.dstev( jobz, d, e, [: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_jobz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(doublereal, (lsame_(&jobz,"N") ? 0 : MAX(1,2*n-2)));
+
+ dstev_(&jobz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_z, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dstev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstev", rblapack_dstev, -1);
+}
diff --git a/ext/dstevd.c b/ext/dstevd.c
new file mode 100644
index 0000000..5b22fe0
--- /dev/null
+++ b/ext/dstevd.c
@@ -0,0 +1,144 @@
+#include "rb_lapack.h"
+
+extern VOID dstevd_(char* jobz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dstevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 z, work, iwork, info, d, e = NumRu::Lapack.dstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, work, iwork, info, d, e = NumRu::Lapack.dstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 5) {
+ rblapack_lwork = argv[3];
+ rblapack_liwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&jobz,"N")||n<=1) ? 1 : (lsame_(&jobz,"V")&&n>1) ? 1+4*n+n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : (lsame_(&jobz,"V")&&n>1) ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ dstevd_(&jobz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dstevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstevd", rblapack_dstevd, -1);
+}
diff --git a/ext/dstevr.c b/ext/dstevr.c
new file mode 100644
index 0000000..a4f1ca5
--- /dev/null
+++ b/ext/dstevr.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID dstevr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dstevr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSTEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n* Whenever possible, DSTEVR calls DSTEMR to compute the\n* eigenspectrum using Relatively Robust Representations. DSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows. For the i-th\n* unreduced block of T,\n* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n* is a relatively robust representation,\n* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n* relative accuracy by the dqds algorithm,\n* (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n* close to the cluster, and go to step (a),\n* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n* compute the corresponding eigenvector by forming a\n* rank-revealing twisted factorization.\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n* Computer Science Division Technical Report No. UCB//CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of DSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** DSTEIN are called\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal (and\n* minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,20*N).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal (and\n* minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ if (rblapack_liwork == Qnil)
+ liwork = 10*n;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ if (rblapack_lwork == Qnil)
+ lwork = 20*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"I") ? iu-il+1 : n;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = MAX(1,n-1);
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ dstevr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dstevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstevr", rblapack_dstevr, -1);
+}
diff --git a/ext/dstevx.c b/ext/dstevx.c
new file mode 100644
index 0000000..ac72c75
--- /dev/null
+++ b/ext/dstevx.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID dstevx_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dstevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, d, e = NumRu::Lapack.dstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSTEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix A. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less\n* than or equal to zero, then EPS*|T| will be used in\n* its place, where |T| is the 1-norm of the tridiagonal\n* matrix.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge (INFO > 0), then that\n* column of Z contains the latest approximation to the\n* eigenvector, and the index of the eigenvector is returned\n* in IFAIL. If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, d, e = NumRu::Lapack.dstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ m = n;
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ iu = NUM2INT(rblapack_iu);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = MAX(1,n-1);
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(doublereal, (5*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ dstevx_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_dstevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dstevx", rblapack_dstevx, -1);
+}
diff --git a/ext/dsycon.c b/ext/dsycon.c
new file mode 100644
index 0000000..b4336b0
--- /dev/null
+++ b/ext/dsycon.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID dsycon_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dsycon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ 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 rcond, info = NumRu::Lapack.dsycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by DSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dsycon( uplo, a, ipiv, anorm, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublereal, (2*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dsycon_(&uplo, &n, a, &lda, 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_dsycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsycon", rblapack_dsycon, -1);
+}
diff --git a/ext/dsyconv.c b/ext/dsyconv.c
new file mode 100644
index 0000000..8bcafa6
--- /dev/null
+++ b/ext/dsyconv.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID dsyconv_(char* uplo, char* way, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsyconv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_way;
+ char way;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+
+ 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 = NumRu::Lapack.dsyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYCONV convert A given by TRF into L and D and vice-versa.\n* Get Non-diag elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 = NumRu::Lapack.dsyconv( uplo, way, a, ipiv, [: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_way = argv[1];
+ rblapack_a = argv[2];
+ rblapack_ipiv = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ way = StringValueCStr(rblapack_way)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ work = ALLOC_N(doublereal, (MAX(1,n)));
+
+ dsyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rblapack_info;
+}
+
+void
+init_lapack_dsyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyconv", rblapack_dsyconv, -1);
+}
diff --git a/ext/dsyequb.c b/ext/dsyequb.c
new file mode 100644
index 0000000..d51dac8
--- /dev/null
+++ b/ext/dsyequb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dsyequb_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsyequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+
+ 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 s, scond, amax, info = NumRu::Lapack.dsyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.dsyequb( 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ work = ALLOC_N(doublereal, (3*n));
+
+ dsyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
+
+ free(work);
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_dsyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyequb", rblapack_dsyequb, -1);
+}
diff --git a/ext/dsyev.c b/ext/dsyev.c
new file mode 100644
index 0000000..8e989b7
--- /dev/null
+++ b/ext/dsyev.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID dsyev_(char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* w, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dsyev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 w, work, info, a = NumRu::Lapack.dsyev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for DSYTRD returned by ILAENV.\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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.dsyev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsyev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyev", rblapack_dsyev, -1);
+}
diff --git a/ext/dsyevd.c b/ext/dsyevd.c
new file mode 100644
index 0000000..2561e3b
--- /dev/null
+++ b/ext/dsyevd.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID dsyevd_(char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* w, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dsyevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ 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 w, work, iwork, info, a = NumRu::Lapack.dsyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* Because of large use of BLAS of level 3, DSYEVD needs N**2 more\n* workspace than DSYEVX.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* dimension (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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least\n* 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, iwork, info, a = NumRu::Lapack.dsyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 5) {
+ rblapack_lwork = argv[3];
+ rblapack_liwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ 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*);
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+
+ dsyevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsyevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyevd", rblapack_dsyevd, -1);
+}
diff --git a/ext/dsyevr.c b/ext/dsyevr.c
new file mode 100644
index 0000000..aa623b6
--- /dev/null
+++ b/ext/dsyevr.c
@@ -0,0 +1,172 @@
+#include "rb_lapack.h"
+
+extern VOID dsyevr_(char* jobz, char* range, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dsyevr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* DSYEVR first reduces the matrix A to tridiagonal form T with a call\n* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute\n* the eigenspectrum using Relatively Robust Representations. DSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see DSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of DSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** DSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,26*N).\n* For optimal efficiency, LWORK >= (NB+6)*N,\n* where NB is the max of the blocksize for DSYTRD and DORMTR\n* returned by ILAENV.\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ 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);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = 26*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"I") ? iu-il+1 : n;
+ if (rblapack_liwork == Qnil)
+ liwork = 10*n;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+
+ dsyevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsyevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyevr", rblapack_dsyevr, -1);
+}
diff --git a/ext/dsyevx.c b/ext/dsyevx.c
new file mode 100644
index 0000000..1965d27
--- /dev/null
+++ b/ext/dsyevx.c
@@ -0,0 +1,157 @@
+#include "rb_lapack.h"
+
+extern VOID dsyevx_(char* jobz, char* range, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dsyevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a = NumRu::Lapack.dsyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSYEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 8*N.\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the max of the blocksize for DSYTRD and DORMTR\n* returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.dsyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ 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);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : 8*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"I") ? iu-il+1 : n;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int 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__;
+ iwork = ALLOC_N(integer, (5*n));
+
+ dsyevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsyevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyevx", rblapack_dsyevx, -1);
+}
diff --git a/ext/dsygs2.c b/ext/dsygs2.c
new file mode 100644
index 0000000..70b4ebb
--- /dev/null
+++ b/ext/dsygs2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID dsygs2_(integer* itype, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dsygs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.dsygs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSYGS2 reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by DPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.dsygs2( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int 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__;
+
+ dsygs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsygs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsygs2", rblapack_dsygs2, -1);
+}
diff --git a/ext/dsygst.c b/ext/dsygst.c
new file mode 100644
index 0000000..1bf79a3
--- /dev/null
+++ b/ext/dsygst.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID dsygst_(integer* itype, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dsygst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.dsygst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSYGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by DPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by DPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.dsygst( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int 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__;
+
+ dsygst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsygst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsygst", rblapack_dsygst, -1);
+}
diff --git a/ext/dsygv.c b/ext/dsygv.c
new file mode 100644
index 0000000..c86ea4d
--- /dev/null
+++ b/ext/dsygv.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID dsygv_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* w, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dsygv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, info, a, b = NumRu::Lapack.dsygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the symmetric positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for DSYTRD returned by ILAENV.\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* > 0: DPOTRF or DSYEV returned an error code:\n* <= N: if INFO = i, DSYEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.dsygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dsygv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dsygv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsygv", rblapack_dsygv, -1);
+}
diff --git a/ext/dsygvd.c b/ext/dsygvd.c
new file mode 100644
index 0000000..06d02fd
--- /dev/null
+++ b/ext/dsygvd.c
@@ -0,0 +1,155 @@
+#include "rb_lapack.h"
+
+extern VOID dsygvd_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* w, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dsygvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, iwork, info, a, b = NumRu::Lapack.dsygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: DPOTRF or DSYEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if DSYEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, iwork, info, a, b = NumRu::Lapack.dsygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 7) {
+ rblapack_lwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dsygvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dsygvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsygvd", rblapack_dsygvd, -1);
+}
diff --git a/ext/dsygvx.c b/ext/dsygvx.c
new file mode 100644
index 0000000..588a0d0
--- /dev/null
+++ b/ext/dsygvx.c
@@ -0,0 +1,187 @@
+#include "rb_lapack.h"
+
+extern VOID dsygvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_dsygvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a, b = NumRu::Lapack.dsygvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* DSYGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,8*N).\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the blocksize for DSYTRD returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: DPOTRF or DSYEVX returned an error code:\n* <= N: if INFO = i, DSYEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.dsygvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vu = argv[7];
+ rblapack_il = argv[8];
+ rblapack_iu = argv[9];
+ rblapack_abstol = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 8*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ vu = NUM2DBL(rblapack_vu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
+ rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (5*n));
+
+ dsygvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dsygvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsygvx", rblapack_dsygvx, -1);
+}
diff --git a/ext/dsyrfs.c b/ext/dsyrfs.c
new file mode 100644
index 0000000..853a013
--- /dev/null
+++ b/ext/dsyrfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID dsyrfs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dsyrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.dsyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DSYTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dsyrfs( uplo, a, af, ipiv, 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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dsyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, 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_dsyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyrfs", rblapack_dsyrfs, -1);
+}
diff --git a/ext/dsyrfsx.c b/ext/dsyrfsx.c
new file mode 100644
index 0000000..4a4d042
--- /dev/null
+++ b/ext/dsyrfsx.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID dsyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dsyrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ n_err_bnds = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dsyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_dsyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyrfsx", rblapack_dsyrfsx, -1);
+}
diff --git a/ext/dsysv.c b/ext/dsysv.c
new file mode 100644
index 0000000..50f3288
--- /dev/null
+++ b/ext/dsysv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID dsysv_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dsysv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, work, info, a, b = NumRu::Lapack.dsysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by DSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* DSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DSYTRF, DSYTRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.dsysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dsysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_dsysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsysv", rblapack_dsysv, -1);
+}
diff --git a/ext/dsysvx.c b/ext/dsysvx.c
new file mode 100644
index 0000000..0fbde05
--- /dev/null
+++ b/ext/dsysvx.c
@@ -0,0 +1,183 @@
+#include "rb_lapack.h"
+
+extern VOID dsysvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dsysvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_af_out__;
+ doublereal *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.dsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a real system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form of\n* A. AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by DSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by DSYTRF.\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,3*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n* NB is the optimal blocksize for DSYTRF.\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 (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.dsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ ldx = MAX(1,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
+ MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ iwork = ALLOC_N(integer, (n));
+
+ dsysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
+}
+
+void
+init_lapack_dsysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsysvx", rblapack_dsysvx, -1);
+}
diff --git a/ext/dsysvxx.c b/ext/dsysvxx.c
new file mode 100644
index 0000000..63cad6d
--- /dev/null
+++ b/ext/dsysvxx.c
@@ -0,0 +1,258 @@
+#include "rb_lapack.h"
+
+extern VOID dsysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dsysvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_af_out__;
+ doublereal *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.dsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a double precision system of linear equations A * X = B, where A\n* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. DSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* DSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* DSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what DSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.dsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ 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*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
+ MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublereal, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dsysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_dsysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsysvxx", rblapack_dsysvxx, -1);
+}
diff --git a/ext/dsyswapr.c b/ext/dsyswapr.c
new file mode 100644
index 0000000..64d9848
--- /dev/null
+++ b/ext/dsyswapr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dsyswapr_(char* uplo, integer* n, doublereal* a, integer* i1, integer* i2);
+
+
+static VALUE
+rblapack_dsyswapr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_i1;
+ integer i1;
+ VALUE rblapack_i2;
+ integer i2;
+ 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 a = NumRu::Lapack.dsyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* DSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n DOUBLE PRECISION TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSWAP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.dsyswapr( uplo, a, i1, i2, [: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_a = argv[1];
+ rblapack_i1 = argv[2];
+ rblapack_i2 = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ i1 = NUM2INT(rblapack_i1);
+ 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*);
+ i2 = NUM2INT(rblapack_i2);
+ {
+ int 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__;
+
+ dsyswapr_(&uplo, &n, a, &i1, &i2);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_dsyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsyswapr", rblapack_dsyswapr, -1);
+}
diff --git a/ext/dsytd2.c b/ext/dsytd2.c
new file mode 100644
index 0000000..ebe6f48
--- /dev/null
+++ b/ext/dsytd2.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dsytd2_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tau, integer* info);
+
+
+static VALUE
+rblapack_dsytd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ 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 d, e, tau, info, a = NumRu::Lapack.dsytd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n* form T by an orthogonal similarity transformation: Q' * A * Q = T.\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) DOUBLE PRECISION 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.dsytd2( 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+
+ dsytd2_(&uplo, &n, a, &lda, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsytd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytd2", rblapack_dsytd2, -1);
+}
diff --git a/ext/dsytf2.c b/ext/dsytf2.c
new file mode 100644
index 0000000..87834da
--- /dev/null
+++ b/ext/dsytf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID dsytf2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_dsytf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ 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 ipiv, info, a = NumRu::Lapack.dsytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* DSYTF2 computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) DOUBLE PRECISION 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.204 and l.372\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.dsytf2( 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ dsytf2_(&uplo, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytf2", rblapack_dsytf2, -1);
+}
diff --git a/ext/dsytrd.c b/ext/dsytrd.c
new file mode 100644
index 0000000..28cf8e1
--- /dev/null
+++ b/ext/dsytrd.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID dsytrd_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dsytrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 d, e, tau, work, info, a = NumRu::Lapack.dsytrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRD reduces a real symmetric matrix A to real symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) DOUBLE PRECISION array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) DOUBLE PRECISION 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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.dsytrd( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dsytrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsytrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytrd", rblapack_dsytrd, -1);
+}
diff --git a/ext/dsytrf.c b/ext/dsytrf.c
new file mode 100644
index 0000000..de6fe44
--- /dev/null
+++ b/ext/dsytrf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID dsytrf_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dsytrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublereal *work;
+ 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 ipiv, work, info, a = NumRu::Lapack.dsytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRF computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DLASYF, DSYTF2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.dsytrf( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dsytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytrf", rblapack_dsytrf, -1);
+}
diff --git a/ext/dsytri.c b/ext/dsytri.c
new file mode 100644
index 0000000..f09f41b
--- /dev/null
+++ b/ext/dsytri.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID dsytri_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dsytri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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.dsytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRI computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* DSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.dsytri( uplo, a, ipiv, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n));
+
+ dsytri_(&uplo, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytri", rblapack_dsytri, -1);
+}
diff --git a/ext/dsytri2.c b/ext/dsytri2.c
new file mode 100644
index 0000000..526fdce
--- /dev/null
+++ b/ext/dsytri2.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID dsytri2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dsytri2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ integer c__1;
+ integer c__m1;
+ integer nb;
+ doublereal *work;
+
+ 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.dsytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRI2 computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling DSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL DSYTRI2X\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dsytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ c__1 = 1;
+ 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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ c__m1 = -1;
+ nb = ilaenv_(&c__1, "DSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
+ if (rblapack_lwork == Qnil)
+ lwork = (n+nb+1)*(nb+3);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (lwork));
+
+ dsytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytri2", rblapack_dsytri2, -1);
+}
diff --git a/ext/dsytri2x.c b/ext/dsytri2x.c
new file mode 100644
index 0000000..dd9e89f
--- /dev/null
+++ b/ext/dsytri2x.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID dsytri2x_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* nb, integer* info);
+
+
+static VALUE
+rblapack_dsytri2x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ doublereal *work;
+
+ 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.dsytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRI2X computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* DSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by DSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by DSYTRF.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.dsytri2x( uplo, a, ipiv, nb, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_nb = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ nb = NUM2INT(rblapack_nb);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (n+nb+1)*(nb+3));
+
+ dsytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dsytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytri2x", rblapack_dsytri2x, -1);
+}
diff --git a/ext/dsytrs.c b/ext/dsytrs.c
new file mode 100644
index 0000000..c63c166
--- /dev/null
+++ b/ext/dsytrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dsytrs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dsytrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dsytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by DSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.dsytrs( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dsytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dsytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytrs", rblapack_dsytrs, -1);
+}
diff --git a/ext/dsytrs2.c b/ext/dsytrs2.c
new file mode 100644
index 0000000..6a7393e
--- /dev/null
+++ b/ext/dsytrs2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID dsytrs2_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, real* work, integer* info);
+
+
+static VALUE
+rblapack_dsytrs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dsytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DSYTRS2 solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by DSYTRF and converted by DSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by DSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 info, b = NumRu::Lapack.dsytrs2( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (n));
+
+ dsytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dsytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dsytrs2", rblapack_dsytrs2, -1);
+}
diff --git a/ext/dtbcon.c b/ext/dtbcon.c
new file mode 100644
index 0000000..9e939c8
--- /dev/null
+++ b/ext/dtbcon.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID dtbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ 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.dtbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dtbcon( norm, uplo, diag, kd, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kd = NUM2INT(rblapack_kd);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dtbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &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_dtbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtbcon", rblapack_dtbcon, -1);
+}
diff --git a/ext/dtbrfs.c b/ext/dtbrfs.c
new file mode 100644
index 0000000..b6b3b7d
--- /dev/null
+++ b/ext/dtbrfs.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID dtbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer ldab;
+ 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 = NumRu::Lapack.dtbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by DTBTRS or some other\n* means before entering this routine. DTBRFS 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dtbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dtbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, 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_dtbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtbrfs", rblapack_dtbrfs, -1);
+}
diff --git a/ext/dtbtrs.c b/ext/dtbtrs.c
new file mode 100644
index 0000000..69e1aed
--- /dev/null
+++ b/ext/dtbtrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID dtbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dtbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dtbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DTBTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by NRHS matrix. A check is made to verify that A is nonsingular.\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 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dtbtrs( uplo, trans, diag, kd, ab, b, [: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_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = 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_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dtbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dtbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtbtrs", rblapack_dtbtrs, -1);
+}
diff --git a/ext/dtfsm.c b/ext/dtfsm.c
new file mode 100644
index 0000000..beb2e57
--- /dev/null
+++ b/ext/dtfsm.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID dtfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, doublereal* alpha, doublereal* a, doublereal* b, integer* ldb);
+
+
+static VALUE
+rblapack_dtfsm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer nt;
+ integer ldb;
+ 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 b = NumRu::Lapack.dtfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* DTFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = A'.\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'T' or 't' op( A ) = A'.\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) DOUBLE PRECISION array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'T' then RFP is the transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.dtfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_transr = argv[0];
+ rblapack_side = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_trans = argv[3];
+ rblapack_diag = argv[4];
+ rblapack_m = argv[5];
+ rblapack_alpha = argv[6];
+ rblapack_a = argv[7];
+ rblapack_b = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (8th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
+ nt = NA_SHAPE0(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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dtfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_dtfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtfsm", rblapack_dtfsm, -1);
+}
diff --git a/ext/dtftri.c b/ext/dtftri.c
new file mode 100644
index 0000000..0911b8d
--- /dev/null
+++ b/ext/dtftri.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID dtftri_(char* transr, char* uplo, char* diag, integer* n, doublereal* a, integer* info);
+
+
+static VALUE
+rblapack_dtftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_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, a = NumRu::Lapack.dtftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* DTFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\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* A (input/output) DOUBLE PRECISION array, dimension (0:nt-1);\n* nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n* Positive Definite matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dtftri( transr, uplo, diag, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+
+ dtftri_(&transr, &uplo, &diag, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dtftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtftri", rblapack_dtftri, -1);
+}
diff --git a/ext/dtfttp.c b/ext/dtfttp.c
new file mode 100644
index 0000000..b703342
--- /dev/null
+++ b/ext/dtfttp.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID dtfttp_(char* transr, char* uplo, integer* n, doublereal* arf, doublereal* ap, integer* info);
+
+
+static VALUE
+rblapack_dtfttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_arf;
+ doublereal *arf;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 ap, info = NumRu::Lapack.dtfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* DTFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.dtfttp( transr, uplo, n, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_arf = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
+ rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
+ if (NA_TYPE(rblapack_arf) != NA_DFLOAT)
+ rblapack_arf = na_change_type(rblapack_arf, NA_DFLOAT);
+ arf = NA_PTR_TYPE(rblapack_arf, doublereal*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_ap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+
+ dtfttp_(&transr, &uplo, &n, arf, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_dtfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtfttp", rblapack_dtfttp, -1);
+}
diff --git a/ext/dtfttr.c b/ext/dtfttr.c
new file mode 100644
index 0000000..9d35a4e
--- /dev/null
+++ b/ext/dtfttr.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID dtfttr_(char* transr, char* uplo, integer* n, doublereal* arf, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dtfttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_arf;
+ doublereal *arf;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_info;
+ integer info;
+ integer ldarf;
+
+ 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 a, info = NumRu::Lapack.dtfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrices ARF and A. N >= 0.\n*\n* ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2).\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* matrix A in RFP format. See the \"Notes\" below for more\n* details.\n*\n* A (output) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER N1, N2, K, NT, NX2, NP1X2\n INTEGER I, J, L, IJ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.dtfttr( transr, uplo, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_arf = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
+ ldarf = NA_SHAPE0(rblapack_arf);
+ if (NA_TYPE(rblapack_arf) != NA_DFLOAT)
+ rblapack_arf = na_change_type(rblapack_arf, NA_DFLOAT);
+ arf = NA_PTR_TYPE(rblapack_arf, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = ((int)sqrtf(8*ldarf+1.0f)-1)/2;
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+
+ dtfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_dtfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtfttr", rblapack_dtfttr, -1);
+}
diff --git a/ext/dtgevc.c b/ext/dtgevc.c
new file mode 100644
index 0000000..c5a5854
--- /dev/null
+++ b/ext/dtgevc.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID dtgevc_(char* side, char* howmny, logical* select, integer* n, doublereal* s, integer* lds, doublereal* p, integer* ldp, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* mm, integer* m, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dtgevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_p;
+ doublereal *p;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_vl_out__;
+ doublereal *vl_out__;
+ VALUE rblapack_vr_out__;
+ doublereal *vr_out__;
+ doublereal *work;
+
+ integer n;
+ integer lds;
+ integer ldp;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of real matrices (S,P), where S is a quasi-triangular matrix\n* and P is upper triangular. Matrix pairs of this type are produced by\n* the generalized Schur factorization of a matrix pair (A,B):\n*\n* A = Q*S*Z**T, B = Q*P*Z**T\n*\n* as computed by DGGHRD + DHGEQZ.\n*\n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal blocks of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the orthogonal factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n* \n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. If w(j) is a real eigenvalue, the corresponding\n* real eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector\n* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n* set to .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) DOUBLE PRECISION array, dimension (LDS,N)\n* The upper quasi-triangular matrix S from a generalized Schur\n* factorization, as computed by DHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) DOUBLE PRECISION array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by DHGEQZ.\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n* of S must be in positive diagonal form.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of left Schur vectors returned by DHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n*\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Z (usually the orthogonal matrix Z\n* of right Schur vectors returned by DHGEQZ).\n*\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B' or 'b', the matrix Z*X;\n* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n* specified by SELECT, stored consecutively in the\n* columns of VR, in the same order as their\n* eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* \n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected real eigenvector occupies one\n* column and each selected complex eigenvector occupies two\n* columns.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Allocation of workspace:\n* ---------- -- ---------\n*\n* WORK( j ) = 1-norm of j-th column of A, above the diagonal\n* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n* WORK( 2*N+1:3*N ) = real part of eigenvector\n* WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n*\n* Rowwise vs. columnwise solution methods:\n* ------- -- ---------- -------- -------\n*\n* Finding a generalized eigenvector consists basically of solving the\n* singular triangular system\n*\n* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)\n*\n* Consider finding the i-th right eigenvector (assume all eigenvalues\n* are real). The equation to be solved is:\n* n i\n* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1\n* k=j k=j\n*\n* where C = (A - w B) (The components v(i+1:n) are 0.)\n*\n* The \"rowwise\" method is:\n*\n* (1) v(i) := 1\n* for j = i-1,. . .,1:\n* i\n* (2) compute s = - sum C(j,k) v(k) and\n* k=j+1\n*\n* (3) v(j) := s / C(j,j)\n*\n* Step 2 is sometimes called the \"dot product\" step, since it is an\n* inner product between the j-th row and the portion of the eigenvector\n* that has been computed so far.\n*\n* The \"columnwise\" method consists basically in doing the sums\n* for all the rows in parallel. As each v(j) is computed, the\n* contribution of v(j) times the j-th column of C is added to the\n* partial sums. Since FORTRAN arrays are stored columnwise, this has\n* the advantage that at each step, the elements of C that are accessed\n* are adjacent to one another, whereas with the rowwise method, the\n* elements accessed at a step are spaced LDS (and LDP) words apart.\n*\n* When finding left eigenvectors, the matrix in question is the\n* transpose of the one in storage, so the rowwise method then\n* actually accesses columns of A and B at each step, and so is the\n* preferred method.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr, [: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_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_s = argv[3];
+ rblapack_p = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_p))
+ rb_raise(rb_eArgError, "p (5th argument) must be NArray");
+ if (NA_RANK(rblapack_p) != 2)
+ rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
+ ldp = NA_SHAPE0(rblapack_p);
+ if (NA_SHAPE1(rblapack_p) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_p) != NA_DFLOAT)
+ rblapack_p = na_change_type(rblapack_p, NA_DFLOAT);
+ p = NA_PTR_TYPE(rblapack_p, doublereal*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ mm = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 2)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
+ lds = NA_SHAPE0(rblapack_s);
+ if (NA_SHAPE1(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
+ MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
+ MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(doublereal, (6*n));
+
+ dtgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
+
+ free(work);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_dtgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgevc", rblapack_dtgevc, -1);
+}
diff --git a/ext/dtgex2.c b/ext/dtgex2.c
new file mode 100644
index 0000000..553bb6e
--- /dev/null
+++ b/ext/dtgex2.c
@@ -0,0 +1,180 @@
+#include "rb_lapack.h"
+
+extern VOID dtgex2_(logical* wantq, logical* wantz, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* j1, integer* n1, integer* n2, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dtgex2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_j1;
+ integer j1;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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, b, q, z = NumRu::Lapack.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n* (A, B) by an orthogonal equivalence transformation.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11). 1 <= J1 <= N.\n*\n* N1 (input) INTEGER\n* The order of the first block (A11, B11). N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block (A22, B22). N2 = 0, 1 or 2.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n*\n* INFO (output) INTEGER\n* =0: Successful exit\n* >0: If INFO = 1, the transformed matrix (A, B) would be\n* too far from generalized Schur form; the blocks are\n* not swapped and (A, B) and (Q, Z) are unchanged.\n* The problem of swapping is too ill-conditioned.\n* <0: If INFO = -16: LWORK is too small. Appropriate value\n* for LWORK is returned in WORK(1).\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* =====================================================================\n* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO\n* loops. Sven Hammarling, 1/5/02.\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_z = argv[5];
+ rblapack_j1 = argv[6];
+ rblapack_n1 = argv[7];
+ rblapack_n2 = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ j1 = NUM2INT(rblapack_j1);
+ n2 = NUM2INT(rblapack_n2);
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ n1 = NUM2INT(rblapack_n1);
+ lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(doublereal, (lwork));
+
+ dtgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &n1, &n2, work, &lwork, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_dtgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgex2", rblapack_dtgex2, -1);
+}
diff --git a/ext/dtgexc.c b/ext/dtgexc.c
new file mode 100644
index 0000000..4ac5756
--- /dev/null
+++ b/ext/dtgexc.c
@@ -0,0 +1,187 @@
+#include "rb_lapack.h"
+
+extern VOID dtgexc_(logical* wantq, logical* wantz, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* ifst, integer* ilst, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dtgexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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 work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGEXC reorders the generalized real Schur decomposition of a real\n* matrix pair (A,B) using an orthogonal equivalence transformation\n*\n* (A, B) = Q * (A, B) * Z',\n*\n* so that the diagonal block of (A, B) with row index IFST is moved\n* to row ILST.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the matrix A in generalized real Schur canonical\n* form.\n* On exit, the updated matrix A, again in generalized\n* real Schur canonical form.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the matrix B in generalized real Schur canonical\n* form (A,B).\n* On exit, the updated matrix B, again in generalized\n* real Schur canonical form (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of\n* a 2-by-2 block, it is changed to point to the first row;\n* ILST always points to the first row of the block in its\n* final position (which may differ from its input value by\n* +1 or -1). 1 <= IFST, ILST <= N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, [: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_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_z = argv[5];
+ rblapack_ifst = argv[6];
+ rblapack_ilst = 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;
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ ifst = NUM2INT(rblapack_ifst);
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : 4*n+16;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ilst = NUM2INT(rblapack_ilst);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dtgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ rblapack_ifst = INT2NUM(ifst);
+ rblapack_ilst = INT2NUM(ilst);
+ return rb_ary_new3(8, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ifst, rblapack_ilst);
+}
+
+void
+init_lapack_dtgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgexc", rblapack_dtgexc, -1);
+}
diff --git a/ext/dtgsen.c b/ext/dtgsen.c
new file mode 100644
index 0000000..f853781
--- /dev/null
+++ b/ext/dtgsen.c
@@ -0,0 +1,252 @@
+#include "rb_lapack.h"
+
+extern VOID dtgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* m, doublereal* pl, doublereal* pr, doublereal* dif, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dtgsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_alphar;
+ doublereal *alphar;
+ VALUE rblapack_alphai;
+ doublereal *alphai;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_pl;
+ doublereal pl;
+ VALUE rblapack_pr;
+ doublereal pr;
+ VALUE rblapack_dif;
+ doublereal *dif;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ VALUE rblapack_z_out__;
+ doublereal *z_out__;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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 alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.dtgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGSEN reorders the generalized real Schur decomposition of a real\n* matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the upper quasi-triangular\n* matrix A and the upper triangular B. The leading columns of Q and\n* Z form orthonormal bases of the corresponding left and right eigen-\n* spaces (deflating subspaces). (A, B) must be in generalized real\n* Schur canonical form (as returned by DGGES), i.e. A is block upper\n* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n* triangular.\n*\n* DTGSEN also computes the generalized eigenvalues\n*\n* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, DTGSEN computes the estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster.\n* To select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension(LDA,N)\n* On entry, the upper quasi-triangular matrix A, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n* ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real generalized Schur form of (A,B) were further reduced\n* to triangular form using complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* and if WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right eigen-\n* spaces (deflating subspaces). 0 <= M <= N.\n*\n* PL (output) DOUBLE PRECISION\n* PR (output) DOUBLE PRECISION\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspaces with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3, PL and PR are not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\n*\n* WORK (workspace/output) DOUBLE PRECISION array,\n* 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 >= 4*N+16.\n* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+6.\n* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n\n* Further Details\n* ===============\n*\n* DTGSEN first collects the selected eigenvalues by computing\n* orthogonal U and W that move them to the top left corner of (A, B).\n* In other words, the selected eigenvalues are the eigenvalues of\n* (A11, B11) in:\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the transpose of U. The first n1 columns\n* of U and W span the specified pair of left and right eigenspaces\n* (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized real Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see DLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF\n* (IJOB = 2 will be used)). See DTGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.dtgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 8 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+ rblapack_ijob = argv[0];
+ rblapack_wantq = argv[1];
+ rblapack_wantz = argv[2];
+ rblapack_select = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 10) {
+ rblapack_lwork = argv[8];
+ rblapack_liwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ wantq = (rblapack_wantq == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (rblapack_liwork == Qnil)
+ liwork = (ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = (ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
+ MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ dtgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alphar, alphai, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_pl = rb_float_new((double)pl);
+ rblapack_pr = rb_float_new((double)pr);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(14, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_dtgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgsen", rblapack_dtgsen, -1);
+}
diff --git a/ext/dtgsja.c b/ext/dtgsja.c
new file mode 100644
index 0000000..adb8019
--- /dev/null
+++ b/ext/dtgsja.c
@@ -0,0 +1,227 @@
+#include "rb_lapack.h"
+
+extern VOID dtgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* tola, doublereal* tolb, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* q, integer* ldq, doublereal* work, integer* ncycle, integer* info);
+
+
+static VALUE
+rblapack_dtgsja(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_tola;
+ doublereal tola;
+ VALUE rblapack_tolb;
+ doublereal tolb;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_v;
+ doublereal *v;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_alpha;
+ doublereal *alpha;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_ncycle;
+ integer ncycle;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+ VALUE rblapack_u_out__;
+ doublereal *u_out__;
+ VALUE rblapack_v_out__;
+ doublereal *v_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.dtgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* DTGSJA computes the generalized singular value decomposition (GSVD)\n* of two real upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine DGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are orthogonal matrices, Z' denotes the transpose\n* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n* ``diagonal'' matrices, which are of the following structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the orthogonal transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain an orthogonal matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* orthogonal matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain an orthogonal matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* orthogonal matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by DTGSJA.\n* See Further Details.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = max(M,N)*norm(A)*MAZHEPS,\n* TOLB = max(P,N)*norm(B)*MAZHEPS.\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0 and\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) DOUBLE PRECISION array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the orthogonal matrix returned by DGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the orthogonal matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) DOUBLE PRECISION array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the orthogonal matrix returned by DGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the orthogonal matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the orthogonal matrix returned by DGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the orthogonal matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n* of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.dtgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_k = argv[3];
+ rblapack_l = argv[4];
+ rblapack_a = argv[5];
+ rblapack_b = argv[6];
+ rblapack_tola = argv[7];
+ rblapack_tolb = argv[8];
+ rblapack_u = argv[9];
+ rblapack_v = argv[10];
+ rblapack_q = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ tolb = NUM2DBL(rblapack_tolb);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ p = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, doublereal*);
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ m = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (12th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ tola = NUM2DBL(rblapack_tola);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
+ MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
+ MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ dtgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
+
+ free(work);
+ rblapack_ncycle = INT2NUM(ncycle);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
+}
+
+void
+init_lapack_dtgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgsja", rblapack_dtgsja, -1);
+}
diff --git a/ext/dtgsna.c b/ext/dtgsna.c
new file mode 100644
index 0000000..4a9433e
--- /dev/null
+++ b/ext/dtgsna.c
@@ -0,0 +1,164 @@
+#include "rb_lapack.h"
+
+extern VOID dtgsna_(char* job, char* howmny, logical* select, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* s, doublereal* dif, integer* mm, integer* m, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtgsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_dif;
+ doublereal *dif;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ integer *iwork;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+
+ 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 s, dif, m, work, info = NumRu::Lapack.dtgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n* generalized real Schur canonical form (or of any matrix pair\n* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n* Z' denotes the transpose of Z.\n*\n* (A, B) must be in generalized real Schur form (as returned by DGGES),\n* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n* blocks. B is upper triangular.\n*\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The upper quasi-triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by DTGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1.\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns ov VR, as returned by DTGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1.\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), DIF(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of DIF are set to the same value. If\n* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected real\n* eigenvalue one element is used, and for each selected complex\n* conjugate pair of eigenvalues, two elements are used.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,N).\n* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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 (N + 6)\n* If JOB = 'E', IWORK is not referenced.\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* Further Details\n* ===============\n*\n* The reciprocal of the condition number of a generalized eigenvalue\n* w = (a, b) is defined as\n*\n* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the left and right eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u.\n* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n* of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number DIF(i) of right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows:\n*\n* a) If the i-th eigenvalue w = (a,b) is real\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1\n* ( 0 S22 ),( 0 T22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(i) is\n*\n* Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n*\n* where sigma-min(Zl) denotes the smallest singular value of the\n* 2(n-1)-by-2(n-1) matrix\n*\n* Zl = [ kron(a, In-1) -kron(1, S22) ]\n* [ kron(b, In-1) -kron(1, T22) ] .\n*\n* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n* Kronecker product between the matrices X and Y.\n*\n* Note that if the default method for computing DIF(i) is wanted\n* (see DLATDF), then the parameter DIFDRI (see below) should be\n* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).\n* See DTGSYL for more details.\n*\n* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2\n* ( 0 S22 ),( 0 T22) n-2\n* 2 n-2 2 n-2\n*\n* and (S11, T11) corresponds to the complex conjugate eigenvalue\n* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n* that\n*\n* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )\n* ( 0 s22 ) ( 0 t22 )\n*\n* where the generalized eigenvalues w = s11/t11 and\n* conjg(w) = s22/t22.\n*\n* Then the reciprocal condition number DIF(i) is bounded by\n*\n* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n*\n* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n* Z1 is the complex 2-by-2 matrix\n*\n* Z1 = [ s11 -s22 ]\n* [ t11 -t22 ],\n*\n* This is done by computing (using real arithmetic) the\n* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n* the determinant of X.\n*\n* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n*\n* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]\n* [ kron(T11', In-2) -kron(I2, T22) ]\n*\n* Note that if the default method for computing DIF is wanted (see\n* DLATDF), then the parameter DIFDRI (see below) should be changed\n* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL\n* for more details.\n*\n* For each eigenvalue/vector specified by SELECT, DIF stores a\n* Frobenius norm-based estimate of Difl.\n*\n* An approximate error bound for the i-th computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.dtgsna( job, howmny, select, a, b, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ m = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ mm = 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 select");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n + 6));
+
+ dtgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
+}
+
+void
+init_lapack_dtgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgsna", rblapack_dtgsna, -1);
+}
diff --git a/ext/dtgsy2.c b/ext/dtgsy2.c
new file mode 100644
index 0000000..e0ca45b
--- /dev/null
+++ b/ext/dtgsy2.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID dtgsy2_(char* trans, integer* ijob, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, integer* ldc, doublereal* d, integer* ldd, doublereal* e, integer* lde, doublereal* f, integer* ldf, doublereal* scale, doublereal* rdsum, doublereal* rdscal, integer* iwork, integer* pq, integer* info);
+
+
+static VALUE
+rblapack_dtgsy2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_f;
+ doublereal *f;
+ VALUE rblapack_rdsum;
+ doublereal rdsum;
+ VALUE rblapack_rdscal;
+ doublereal rdscal;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_pq;
+ integer pq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_f_out__;
+ doublereal *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, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.dtgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n* Purpose\n* =======\n*\n* DTGSY2 solves the generalized Sylvester equation:\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F,\n*\n* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n* must be in generalized Schur canonical form, i.e. A, B are upper\n* quasi triangular and D, E are upper triangular. The solution (R, L)\n* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n* chosen to avoid overflow.\n*\n* In matrix notation solving equation (1) corresponds to solve\n* Z*x = scale*b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n* In the process of solving (1), we solve a number of such systems\n* where Dim(In), Dim(In) = 1 or 2.\n*\n* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* sigma_min(Z) using reverse communicaton with DLACON.\n*\n* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of the matrix pair in\n* DTGSYL. See DTGSYL for details.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* = 2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (DGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA, M)\n* On entry, A contains an upper quasi triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) DOUBLE PRECISION array, dimension (LDB, N)\n* On entry, B contains an upper quasi triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1, N).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)\n* On entry, C contains the right-hand-side of the first matrix\n* equation in (1).\n* On exit, if IJOB = 0, C has been overwritten by the\n* solution R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) DOUBLE PRECISION array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) DOUBLE PRECISION array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix E. LDE >= max(1, N).\n*\n* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)\n* On entry, F contains the right-hand-side of the second matrix\n* equation in (1).\n* On exit, if IJOB = 0, F has been overwritten by the\n* solution L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0. Normally,\n* SCALE = 1.\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by DTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when DTGSY2 is called by\n* DTGSYL.\n*\n* IWORK (workspace) INTEGER array, dimension (M+N+2)\n*\n* PQ (output) INTEGER\n* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n* 8-by-8) solved by this routine.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, the i-th argument had an illegal value.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n* Replaced various illegal calls to DCOPY by calls to DLASET.\n* Sven Hammarling, 27/5/02.\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.dtgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", 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];
+ rblapack_rdsum = argv[8];
+ rblapack_rdscal = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ 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_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ rdsum = NUM2DBL(rblapack_rdsum);
+ 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ rdscal = NUM2DBL(rblapack_rdscal);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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_DFLOAT)
+ rblapack_f = na_change_type(rblapack_f, NA_DFLOAT);
+ f = NA_PTR_TYPE(rblapack_f, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = n;
+ rblapack_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublereal*);
+ MEMCPY(f_out__, f, doublereal, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+ iwork = ALLOC_N(integer, (m+n+2));
+
+ dtgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, iwork, &pq, &info);
+
+ free(iwork);
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_pq = INT2NUM(pq);
+ rblapack_info = INT2NUM(info);
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(7, rblapack_scale, rblapack_pq, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_dtgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgsy2", rblapack_dtgsy2, -1);
+}
diff --git a/ext/dtgsyl.c b/ext/dtgsyl.c
new file mode 100644
index 0000000..4e70aff
--- /dev/null
+++ b/ext/dtgsyl.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID dtgsyl_(char* trans, integer* ijob, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, integer* ldc, doublereal* d, integer* ldd, doublereal* e, integer* lde, doublereal* f, integer* ldf, doublereal* scale, doublereal* dif, doublereal* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtgsyl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_f;
+ doublereal *f;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_dif;
+ doublereal dif;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_f_out__;
+ doublereal *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.dtgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTGSYL( 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* DTGSYL 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', DTGSYL 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 DLACON.\n*\n* If IJOB >= 1, DTGSYL 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* ( DGECON 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION\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) DOUBLE PRECISION\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) DOUBLE PRECISION 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 DCOPY by calls to DLASET.\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.dtgsyl( 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_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+ 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_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ 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_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ 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_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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_DFLOAT)
+ rblapack_f = na_change_type(rblapack_f, NA_DFLOAT);
+ f = NA_PTR_TYPE(rblapack_f, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = n;
+ rblapack_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublereal*);
+ MEMCPY(f_out__, f, doublereal, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+ iwork = ALLOC_N(integer, (m+n+6));
+
+ dtgsyl_(&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_dtgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtgsyl", rblapack_dtgsyl, -1);
+}
diff --git a/ext/dtpcon.c b/ext/dtpcon.c
new file mode 100644
index 0000000..0e745fc
--- /dev/null
+++ b/ext/dtpcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dtpcon_(char* norm, char* uplo, char* diag, integer* n, doublereal* ap, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtpcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *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.dtpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTPCON 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) DOUBLE PRECISION 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) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dtpcon( 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dtpcon_(&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_dtpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtpcon", rblapack_dtpcon, -1);
+}
diff --git a/ext/dtprfs.c b/ext/dtprfs.c
new file mode 100644
index 0000000..00dd0ad
--- /dev/null
+++ b/ext/dtprfs.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID dtprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *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.dtprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTPRFS 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 DTPTRS or some other\n* means before entering this routine. DTPRFS 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dtprfs( 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dtprfs_(&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_dtprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtprfs", rblapack_dtprfs, -1);
+}
diff --git a/ext/dtptri.c b/ext/dtptri.c
new file mode 100644
index 0000000..8540dc2
--- /dev/null
+++ b/ext/dtptri.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dtptri_(char* uplo, char* diag, integer* n, doublereal* ap, integer* info);
+
+
+static VALUE
+rblapack_dtptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublereal *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.dtptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* DTPTRI 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) DOUBLE PRECISION 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.dtptri( 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
+ MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ dtptri_(&uplo, &diag, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_dtptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtptri", rblapack_dtptri, -1);
+}
diff --git a/ext/dtptrs.c b/ext/dtptrs.c
new file mode 100644
index 0000000..0ed2254
--- /dev/null
+++ b/ext/dtptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dtptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dtptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dtptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DTPTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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 matrix B. NRHS >= 0.\n*\n* AP (input) DOUBLE PRECISION 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*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dtptrs( uplo, trans, diag, n, ap, b, [: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_n = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_b = 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 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ n = NUM2INT(rblapack_n);
+ 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) != (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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dtptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dtptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtptrs", rblapack_dtptrs, -1);
+}
diff --git a/ext/dtpttf.c b/ext/dtpttf.c
new file mode 100644
index 0000000..7965afa
--- /dev/null
+++ b/ext/dtpttf.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID dtpttf_(char* transr, char* uplo, integer* n, doublereal* ap, doublereal* arf, integer* info);
+
+
+static VALUE
+rblapack_dtpttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_arf;
+ doublereal *arf;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 arf, info = NumRu::Lapack.dtpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* DTPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'T': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.dtpttf( transr, uplo, 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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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);
+ 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_DFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_arf = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, doublereal*);
+
+ dtpttf_(&transr, &uplo, &n, ap, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_dtpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtpttf", rblapack_dtpttf, -1);
+}
diff --git a/ext/dtpttr.c b/ext/dtpttr.c
new file mode 100644
index 0000000..498790a
--- /dev/null
+++ b/ext/dtpttr.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID dtpttr_(char* uplo, integer* n, doublereal* ap, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dtpttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldap;
+ 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 a, info = NumRu::Lapack.dtpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) DOUBLE PRECISION array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -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 a, info = NumRu::Lapack.dtpttr( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+
+ dtpttr_(&uplo, &n, ap, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_dtpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtpttr", rblapack_dtpttr, -1);
+}
diff --git a/ext/dtrcon.c b/ext/dtrcon.c
new file mode 100644
index 0000000..c5f4f03
--- /dev/null
+++ b/ext/dtrcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID dtrcon_(char* norm, char* uplo, char* diag, integer* n, doublereal* a, integer* lda, doublereal* rcond, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtrcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ 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 rcond, info = NumRu::Lapack.dtrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRCON estimates the reciprocal of the condition number of a\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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\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) DOUBLE PRECISION 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.dtrcon( norm, uplo, diag, a, [: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_a = 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_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);
+ 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*);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dtrcon_(&norm, &uplo, &diag, &n, a, &lda, &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_dtrcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrcon", rblapack_dtrcon, -1);
+}
diff --git a/ext/dtrevc.c b/ext/dtrevc.c
new file mode 100644
index 0000000..2d6f34b
--- /dev/null
+++ b/ext/dtrevc.c
@@ -0,0 +1,150 @@
+#include "rb_lapack.h"
+
+extern VOID dtrevc_(char* side, char* howmny, logical* select, integer* n, doublereal* t, integer* ldt, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* mm, integer* m, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dtrevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_select_out__;
+ logical *select_out__;
+ VALUE rblapack_vl_out__;
+ doublereal *vl_out__;
+ VALUE rblapack_vr_out__;
+ doublereal *vr_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, select, vl, vr = NumRu::Lapack.dtrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DTREVC computes some or all of the right and/or left eigenvectors of\n* a real upper quasi-triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal blocks of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the orthogonal factor that reduces a matrix\n* A to Schur form T, then Q*X and Q*Y are the matrices of right and\n* left eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* If w(j) is a real eigenvalue, the corresponding real\n* eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector is\n* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n* .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,N)\n* The upper quasi-triangular matrix T in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by DHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by DHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors.\n* If HOWMNY = 'A' or 'B', M is set to N.\n* Each selected real eigenvector occupies one column and each\n* selected complex eigenvector occupies two columns.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (3*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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, info, select, vl, vr = NumRu::Lapack.dtrevc( side, howmny, select, t, vl, vr, [: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_side = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ mm = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
+ MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
+ rblapack_select = rblapack_select_out__;
+ select = select_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
+ MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
+ MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(doublereal, (3*n));
+
+ dtrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
+
+ free(work);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_select, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_dtrevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrevc", rblapack_dtrevc, -1);
+}
diff --git a/ext/dtrexc.c b/ext/dtrexc.c
new file mode 100644
index 0000000..9a4ca07
--- /dev/null
+++ b/ext/dtrexc.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID dtrexc_(char* compq, integer* n, doublereal* t, integer* ldt, doublereal* q, integer* ldq, integer* ifst, integer* ilst, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_dtrexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ doublereal *t_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ doublereal *work;
+
+ integer ldt;
+ integer n;
+ integer ldq;
+
+ 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, t, q, ifst, ilst = NumRu::Lapack.dtrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n* Purpose\n* =======\n*\n* DTREXC reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n* moved to row ILST.\n*\n* The real Schur form T is reordered by an orthogonal similarity\n* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n* is updated by postmultiplying it with Z.\n*\n* T must be in Schur canonical form (as returned by DHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* Schur canonical form.\n* On exit, the reordered upper quasi-triangular matrix, again\n* in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of T.\n* The block with row index IFST is moved to row ILST, by a\n* sequence of transpositions between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of a\n* 2-by-2 block, it is changed to point to the first row; ILST\n* always points to the first row of the block in its final\n* position (which may differ from its input value by +1 or -1).\n* 1 <= IFST <= N; 1 <= ILST <= N.\n*\n* WORK (workspace) DOUBLE PRECISION 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* = 1: two adjacent blocks were too close to swap (the problem\n* is very ill-conditioned); T may have been partially\n* reordered, and ILST points to the first row of the\n* current position of the block being moved.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, t, q, ifst, ilst = NumRu::Lapack.dtrexc( compq, t, q, ifst, ilst, [: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_compq = argv[0];
+ rblapack_t = argv[1];
+ rblapack_q = argv[2];
+ rblapack_ifst = argv[3];
+ rblapack_ilst = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ ilst = NUM2INT(rblapack_ilst);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (2th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ ifst = NUM2INT(rblapack_ifst);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
+ MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(doublereal, (n));
+
+ dtrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ rblapack_ifst = INT2NUM(ifst);
+ rblapack_ilst = INT2NUM(ilst);
+ return rb_ary_new3(5, rblapack_info, rblapack_t, rblapack_q, rblapack_ifst, rblapack_ilst);
+}
+
+void
+init_lapack_dtrexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrexc", rblapack_dtrexc, -1);
+}
diff --git a/ext/dtrrfs.c b/ext/dtrrfs.c
new file mode 100644
index 0000000..b9c2788
--- /dev/null
+++ b/ext/dtrrfs.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID dtrrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtrrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer lda;
+ 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 = NumRu::Lapack.dtrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by DTRTRS or some other\n* means before entering this routine. DTRRFS 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* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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.dtrrfs( uplo, trans, diag, a, 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_a = 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ 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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ work = ALLOC_N(doublereal, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ dtrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, 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_dtrrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrrfs", rblapack_dtrrfs, -1);
+}
diff --git a/ext/dtrsen.c b/ext/dtrsen.c
new file mode 100644
index 0000000..4453e28
--- /dev/null
+++ b/ext/dtrsen.c
@@ -0,0 +1,169 @@
+#include "rb_lapack.h"
+
+extern VOID dtrsen_(char* job, char* compq, logical* select, integer* n, doublereal* t, integer* ldt, doublereal* q, integer* ldq, doublereal* wr, doublereal* wi, integer* m, doublereal* s, doublereal* sep, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_dtrsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_q;
+ doublereal *q;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ doublereal *wr;
+ VALUE rblapack_wi;
+ doublereal *wi;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_s;
+ doublereal s;
+ VALUE rblapack_sep;
+ doublereal sep;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ doublereal *t_out__;
+ VALUE rblapack_q_out__;
+ doublereal *q_out__;
+ integer *iwork;
+
+ integer n;
+ integer ldt;
+ integer ldq;
+
+ 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 wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.dtrsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRSEN reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n* the leading diagonal blocks of the upper quasi-triangular matrix T,\n* and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n* T must be in Schur canonical form (as returned by DHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elemnts equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, T is overwritten by the reordered matrix T, again in\n* Schur canonical form, with the selected eigenvalues in the\n* leading diagonal blocks.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix which reorders T; the\n* leading M columns of Q form an orthonormal basis for the\n* specified invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* WR (output) DOUBLE PRECISION array, dimension (N)\n* WI (output) DOUBLE PRECISION array, dimension (N)\n* The real and imaginary parts, respectively, of the reordered\n* eigenvalues of T. The eigenvalues are stored in the same\n* order as on the diagonal of T, with WR(i) = T(i,i) and, if\n* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n* WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n* sufficiently ill-conditioned, then its value may differ\n* significantly from its value before reordering.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 < = M <= N.\n*\n* S (output) DOUBLE PRECISION\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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.\n* If JOB = 'N', LWORK >= max(1,N);\n* if JOB = 'E', LWORK >= max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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 (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOB = 'N' or 'E', LIWORK >= 1;\n* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* = 1: reordering of T failed because some eigenvalues are too\n* close to separate (the problem is very ill-conditioned);\n* T may have been partially reordered, and WR and WI\n* contain the eigenvalues in the same order as in T; S and\n* SEP (if requested) are set to zero.\n*\n\n* Further Details\n* ===============\n*\n* DTRSEN first collects the selected eigenvalues by computing an\n* orthogonal transformation Z to move them to the top left corner of T.\n* In other words, the selected eigenvalues are the eigenvalues of T11\n* in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n* of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the real Schur factorization of a matrix\n* A = Q*T*Q', then the reordered real Schur factorization of A is given\n* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n* the corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.dtrsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_q = argv[4];
+ rblapack_liwork = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_q) != NA_DFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, doublereal*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ liwork = NUM2INT(rblapack_liwork);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
+ MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
+ MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+
+ dtrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, wr, wi, &m, &s, &sep, work, &lwork, iwork, &liwork, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_sep = rb_float_new((double)sep);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_wr, rblapack_wi, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_dtrsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrsen", rblapack_dtrsen, -1);
+}
diff --git a/ext/dtrsna.c b/ext/dtrsna.c
new file mode 100644
index 0000000..7153674
--- /dev/null
+++ b/ext/dtrsna.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID dtrsna_(char* job, char* howmny, logical* select, integer* n, doublereal* t, integer* ldt, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* s, doublereal* sep, integer* mm, integer* m, doublereal* work, integer* ldwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_dtrsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ doublereal *t;
+ VALUE rblapack_vl;
+ doublereal *vl;
+ VALUE rblapack_vr;
+ doublereal *vr;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_sep;
+ doublereal *sep;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+ integer ldwork;
+
+ 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 s, sep, m, info = NumRu::Lapack.dtrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a real upper\n* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n* orthogonal).\n*\n* T must be in Schur canonical form (as returned by DHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) DOUBLE PRECISION array, dimension (LDT,N)\n* The upper quasi-triangular matrix T, in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* DHSEIN or DTREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* DHSEIN or DTREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), SEP(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of SEP are set to the same value. If\n* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* IWORK (workspace) INTEGER array, dimension (2*(N-1))\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.dtrsna( job, howmny, select, t, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ m = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
+ mm = m;
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_DFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, doublereal*);
+ ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sep = NA_PTR_TYPE(rblapack_sep, doublereal*);
+ work = ALLOC_N(doublereal, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
+ iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : 2*(n-1)));
+
+ dtrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
+}
+
+void
+init_lapack_dtrsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrsna", rblapack_dtrsna, -1);
+}
diff --git a/ext/dtrsyl.c b/ext/dtrsyl.c
new file mode 100644
index 0000000..01ea4c8
--- /dev/null
+++ b/ext/dtrsyl.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID dtrsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, integer* ldc, doublereal* scale, integer* info);
+
+
+static VALUE
+rblapack_dtrsyl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trana;
+ char trana;
+ VALUE rblapack_tranb;
+ char tranb;
+ VALUE rblapack_isgn;
+ integer isgn;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+
+ 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 scale, info, c = NumRu::Lapack.dtrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* DTRSYL solves the real Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**T, and A and B are both upper quasi-\n* triangular. A is M-by-M and B is N-by-N; the right hand side C and\n* the solution X are M-by-N; and scale is an output scale factor, set\n* <= 1 to avoid overflow in X.\n*\n* A and B must be in Schur canonical form (as returned by DHSEQR), that\n* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n* each 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'T': op(A) = A**T (Transpose)\n* = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'T': op(B) = B**T (Transpose)\n* = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,M)\n* The upper quasi-triangular matrix A, in Schur canonical form.\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* The upper quasi-triangular matrix B, in Schur canonical form.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n* On entry, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) DOUBLE PRECISION\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.dtrsyl( trana, tranb, isgn, a, b, c, [: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_trana = argv[0];
+ rblapack_tranb = argv[1];
+ rblapack_isgn = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trana = StringValueCStr(rblapack_trana)[0];
+ isgn = NUM2INT(rblapack_isgn);
+ 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);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ tranb = StringValueCStr(rblapack_tranb)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ if (NA_SHAPE1(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ 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);
+ 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*);
+ {
+ int 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__;
+
+ dtrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_dtrsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrsyl", rblapack_dtrsyl, -1);
+}
diff --git a/ext/dtrti2.c b/ext/dtrti2.c
new file mode 100644
index 0000000..a748dab
--- /dev/null
+++ b/ext/dtrti2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID dtrti2_(char* uplo, char* diag, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dtrti2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ 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.dtrti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTRTI2 computes the inverse of a real upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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.dtrti2( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ int 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__;
+
+ dtrti2_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dtrti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrti2", rblapack_dtrti2, -1);
+}
diff --git a/ext/dtrtri.c b/ext/dtrtri.c
new file mode 100644
index 0000000..bbc94e4
--- /dev/null
+++ b/ext/dtrtri.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID dtrtri_(char* uplo, char* diag, integer* n, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_dtrtri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ 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.dtrtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* DTRTRI computes the inverse of a real upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.dtrtri( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ int 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__;
+
+ dtrtri_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dtrtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrtri", rblapack_dtrtri, -1);
+}
diff --git a/ext/dtrtrs.c b/ext/dtrtrs.c
new file mode 100644
index 0000000..e082cf2
--- /dev/null
+++ b/ext/dtrtrs.c
@@ -0,0 +1,99 @@
+#include "rb_lapack.h"
+
+extern VOID dtrtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_dtrtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublereal *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.dtrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* DTRTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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 matrix B. NRHS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.dtrtrs( uplo, trans, diag, a, b, [: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_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
+ MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ dtrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_dtrtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrtrs", rblapack_dtrtrs, -1);
+}
diff --git a/ext/dtrttf.c b/ext/dtrttf.c
new file mode 100644
index 0000000..cfbc21f
--- /dev/null
+++ b/ext/dtrttf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID dtrttf_(char* transr, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* arf, integer* info);
+
+
+static VALUE
+rblapack_dtrttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_arf;
+ doublereal *arf;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 arf, info = NumRu::Lapack.dtrttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* DTRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal form is wanted;\n* = 'T': ARF in Transpose form is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N).\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) DOUBLE PRECISION array, dimension (NT).\n* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.dtrttf( transr, uplo, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[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);
+ 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_arf = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, doublereal*);
+
+ dtrttf_(&transr, &uplo, &n, a, &lda, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_dtrttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrttf", rblapack_dtrttf, -1);
+}
diff --git a/ext/dtrttp.c b/ext/dtrttp.c
new file mode 100644
index 0000000..88d93ae
--- /dev/null
+++ b/ext/dtrttp.c
@@ -0,0 +1,73 @@
+#include "rb_lapack.h"
+
+extern VOID dtrttp_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* ap, integer* info);
+
+
+static VALUE
+rblapack_dtrttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_ap;
+ doublereal *ap;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 ap, info = NumRu::Lapack.dtrttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* DTRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 ap, info = NumRu::Lapack.dtrttp( 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*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
+
+ dtrttp_(&uplo, &n, a, &lda, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_dtrttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtrttp", rblapack_dtrttp, -1);
+}
diff --git a/ext/dtzrqf.c b/ext/dtzrqf.c
new file mode 100644
index 0000000..f3033fa
--- /dev/null
+++ b/ext/dtzrqf.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID dtzrqf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, integer* info);
+
+
+static VALUE
+rblapack_dtzrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dtzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine DTZRZF.\n*\n* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.dtzrqf( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int 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__;
+
+ dtzrqf_(&m, &n, a, &lda, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dtzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtzrqf", rblapack_dtzrqf, -1);
+}
diff --git a/ext/dtzrzf.c b/ext/dtzrzf.c
new file mode 100644
index 0000000..d81d781
--- /dev/null
+++ b/ext/dtzrzf.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID dtzrzf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_dtzrzf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublereal *tau;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublereal *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dtzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) DOUBLE PRECISION array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) DOUBLE PRECISION 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.dtzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 2)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 2) {
+ rblapack_lwork = argv[1];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ 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*);
+ m = lda;
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int 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__;
+
+ dtzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_dtzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dtzrzf", rblapack_dtzrzf, -1);
+}
diff --git a/ext/dzsum1.c b/ext/dzsum1.c
new file mode 100644
index 0000000..ab94b60
--- /dev/null
+++ b/ext/dzsum1.c
@@ -0,0 +1,63 @@
+#include "rb_lapack.h"
+
+extern doublereal dzsum1_(integer* n, doublecomplex* cx, integer* incx);
+
+
+static VALUE
+rblapack_dzsum1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ doublecomplex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ 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 __out__ = NumRu::Lapack.dzsum1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* DZSUM1 takes the sum of the absolute values of a complex\n* vector and returns a double precision result.\n*\n* Based on DZASUM from the Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with ZLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX*16 array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX > 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, NINCX\n DOUBLE PRECISION STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.dzsum1( cx, incx, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
+ incx = NUM2INT(rblapack_incx);
+
+ __out__ = dzsum1_(&n, cx, &incx);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_dzsum1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "dzsum1", rblapack_dzsum1, -1);
+}
diff --git a/ext/extconf.rb b/ext/extconf.rb
new file mode 100644
index 0000000..e7cbb43
--- /dev/null
+++ b/ext/extconf.rb
@@ -0,0 +1,78 @@
+require "mkmf"
+
+
+def header_not_found(name)
+ warn <<EOF
+ #{name}.h was not found.
+ If you have #{name}.h, try the following:
+ % ruby extconf.rb --with-#{name}-include=path
+EOF
+ exit 1
+end
+
+def library_not_found(lname, fname=nil)
+ if fname
+ warn <<EOF
+ #{fname} was not found.
+ If you have #{lname} library, try the following:
+ % ruby extconf.rb --with-#{lname}-lib=path --with-#{lname}-name=name
+ e.g.
+ If you have /usr/local/#{lname}/#{fname},
+ % ruby extconf.rb --with-#{lname}-lib=/usr/local/#{lname} --with-#{lname}-name=#{fname}
+EOF
+ exit 1
+ else
+ warn <<EOF
+ lib#{lname}.{a|so} was not found.
+ If you have lib#{lname}.{a|so}, try the following:
+ % ruby extconf.rb --with-#{lname}-lib=path
+EOF
+ exit 1
+ end
+end
+
+
+
+dir_config("lapack")
+unless find_library("lapack", nil)
+ library_not_found("lapack",nil)
+
+ warn "LAPACK will be tried to find"
+
+ name = with_config("blas-name","blas_LINUX.a")
+ unless have_library(name)
+ lib_path = with_config("blas-lib","/usr/local/lib")
+ _libarg = LIBARG
+ LIBARG.replace "#{lib_path}/%s"
+ unless have_library(name)
+ library_not_found("blas",name)
+ end
+ LIBARG.replace _libarg
+ end
+ name = with_config("lapack-name","lapack_LINUX.a")
+ unless have_library(name)
+ lib_path = with_config("lapack-lib","/usr/local/lib")
+ _libarg = LIBARG
+ LIBARG.replace "#{lib_path}/%s"
+ unless have_library(name)
+ library_not_found("lapack",name)
+ end
+ LIBARG.replace _libarg
+ end
+end
+
+sitearchdir = Config::CONFIG["sitearchdir"]
+dir_config("narray", sitearchdir, sitearchdir)
+gem_path = nil
+begin
+ require "rubygems"
+ if (spec = Gem.source_index.find_name("narray")).any?
+ gem_path = spec.last.full_gem_path
+ end
+rescue LoadError
+end
+unless find_header("narray.h",gem_path) && have_header("narray_config.h")
+ header_not_found("narray")
+end
+
+create_makefile("numru/lapack")
diff --git a/f2c_minimal.h b/ext/f2c_minimal.h
similarity index 100%
rename from f2c_minimal.h
rename to ext/f2c_minimal.h
diff --git a/ext/icmax1.c b/ext/icmax1.c
new file mode 100644
index 0000000..b9c4386
--- /dev/null
+++ b/ext/icmax1.c
@@ -0,0 +1,63 @@
+#include "rb_lapack.h"
+
+extern integer icmax1_(integer* n, complex* cx, integer* incx);
+
+
+static VALUE
+rblapack_icmax1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ complex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack___out__;
+ integer __out__;
+
+ 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 __out__ = NumRu::Lapack.icmax1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ICMAX1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* ICMAX1 finds the index of the element whose real part has maximum\n* absolute value.\n*\n* Based on ICAMAX from Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with CLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX >= 1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX\n REAL SMAX\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function definitions ..\n*\n* NEXT LINE IS THE ONLY MODIFICATION.\n CABS1( ZDUM ) = ABS( ZDUM )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.icmax1( cx, incx, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, complex*);
+ incx = NUM2INT(rblapack_incx);
+
+ __out__ = icmax1_(&n, cx, &incx);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_icmax1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "icmax1", rblapack_icmax1, -1);
+}
diff --git a/ext/ieeeck.c b/ext/ieeeck.c
new file mode 100644
index 0000000..d9fa64d
--- /dev/null
+++ b/ext/ieeeck.c
@@ -0,0 +1,59 @@
+#include "rb_lapack.h"
+
+extern integer ieeeck_(integer* ispec, real* zero, real* one);
+
+
+static VALUE
+rblapack_ieeeck(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ispec;
+ integer ispec;
+ VALUE rblapack_zero;
+ real zero;
+ VALUE rblapack_one;
+ real one;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ieeeck( ispec, zero, one, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )\n\n* Purpose\n* =======\n*\n* IEEECK is called from the ILAENV to verify that Infinity and\n* possibly NaN arithmetic is safe (i.e. will not trap).\n*\n\n* Arguments\n* =========\n*\n* ISPEC (input) INTEGER\n* Specifies whether to test just for inifinity arithmetic\n* or whether to test for infinity and NaN arithmetic.\n* = 0: Verify infinity arithmetic only.\n* = 1: Verify infinity and NaN arithmetic.\n*\n* ZERO (input) REAL\n* Must contain the value 0.0\n* This is passed to prevent the compiler from optimizing\n* away this code.\n*\n* ONE (input) REAL\n* Must contain the value 1.0\n* This is passed to prevent the compiler from optimizing\n* away this code.\n*\n* RETURN VALUE: INTEGER\n* = 0: Arithmetic failed to produce the correct answers\n* = 1: Arithmetic produced the correct answers\n*\n* .. Local Scalars ..\n REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,\n $ NEGZRO, NEWZRO, POSINF\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ieeeck( ispec, zero, one, [: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_ispec = argv[0];
+ rblapack_zero = argv[1];
+ rblapack_one = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ispec = NUM2INT(rblapack_ispec);
+ one = (real)NUM2DBL(rblapack_one);
+ zero = (real)NUM2DBL(rblapack_zero);
+
+ __out__ = ieeeck_(&ispec, &zero, &one);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ieeeck(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ieeeck", rblapack_ieeeck, -1);
+}
diff --git a/ext/ilaclc.c b/ext/ilaclc.c
new file mode 100644
index 0000000..7d6a618
--- /dev/null
+++ b/ext/ilaclc.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer ilaclc_(integer* m, integer* n, complex* a, integer* lda);
+
+
+static VALUE
+rblapack_ilaclc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilaclc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILACLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILACLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaclc( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+
+ __out__ = ilaclc_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilaclc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilaclc", rblapack_ilaclc, -1);
+}
diff --git a/ext/ilaclr.c b/ext/ilaclr.c
new file mode 100644
index 0000000..ee92c8c
--- /dev/null
+++ b/ext/ilaclr.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer ilaclr_(integer* m, integer* n, complex* a, integer* lda);
+
+
+static VALUE
+rblapack_ilaclr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilaclr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILACLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILACLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaclr( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+
+ __out__ = ilaclr_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilaclr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilaclr", rblapack_ilaclr, -1);
+}
diff --git a/ext/iladiag.c b/ext/iladiag.c
new file mode 100644
index 0000000..0b0f547
--- /dev/null
+++ b/ext/iladiag.c
@@ -0,0 +1,51 @@
+#include "rb_lapack.h"
+
+extern integer iladiag_(char* diag);
+
+
+static VALUE
+rblapack_iladiag(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.iladiag( diag, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILADIAG( DIAG )\n\n* Purpose\n* =======\n*\n* This subroutine translated from a character string specifying if a\n* matrix has unit diagonal or not to the relevant BLAST-specified\n* integer constant.\n*\n* ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a\n* character indicating a unit or non-unit diagonal. Otherwise ILADIAG\n* returns the constant value corresponding to DIAG.\n*\n\n* Arguments\n* =========\n* DIAG (input) CHARACTER*1\n* = 'N': A is non-unit triangular;\n* = 'U': A is unit triangular.\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iladiag( diag, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_diag = argv[0];
+ if (argc == 1) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ diag = StringValueCStr(rblapack_diag)[0];
+
+ __out__ = iladiag_(&diag);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_iladiag(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "iladiag", rblapack_iladiag, -1);
+}
diff --git a/ext/iladlc.c b/ext/iladlc.c
new file mode 100644
index 0000000..80d6dab
--- /dev/null
+++ b/ext/iladlc.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer iladlc_(integer* m, integer* n, doublereal* a, integer* lda);
+
+
+static VALUE
+rblapack_iladlc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.iladlc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILADLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILADLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iladlc( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+
+ __out__ = iladlc_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_iladlc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "iladlc", rblapack_iladlc, -1);
+}
diff --git a/ext/iladlr.c b/ext/iladlr.c
new file mode 100644
index 0000000..76c3fb6
--- /dev/null
+++ b/ext/iladlr.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer iladlr_(integer* m, integer* n, doublereal* a, integer* lda);
+
+
+static VALUE
+rblapack_iladlr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.iladlr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILADLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILADLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iladlr( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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*);
+
+ __out__ = iladlr_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_iladlr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "iladlr", rblapack_iladlr, -1);
+}
diff --git a/ext/ilaenv.c b/ext/ilaenv.c
new file mode 100644
index 0000000..915e8a1
--- /dev/null
+++ b/ext/ilaenv.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern integer ilaenv_(integer* ispec, char* name, char* opts, integer* n1, integer* n2, integer* n3, integer* n4);
+
+
+static VALUE
+rblapack_ilaenv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ispec;
+ integer ispec;
+ VALUE rblapack_name;
+ char *name;
+ VALUE rblapack_opts;
+ char *opts;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_n3;
+ integer n3;
+ VALUE rblapack_n4;
+ integer n4;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilaenv( ispec, name, opts, n1, n2, n3, n4, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )\n\n* Purpose\n* =======\n*\n* ILAENV is called from the LAPACK routines to choose problem-dependent\n* parameters for the local environment. See ISPEC for a description of\n* the parameters.\n*\n* ILAENV returns an INTEGER\n* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC\n* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.\n*\n* This version provides a set of parameters which should give good,\n* but not optimal, performance on many of the currently available\n* computers. Users are encouraged to modify this subroutine to set\n* the tuning parameters for their particular machine using the option\n* and problem size information in the arguments.\n*\n* This routine will not function correctly if it is converted to all\n* lower case. Converting it to all upper case is allowed.\n*\n\n* Arguments\n* =========\n*\n* ISPEC (input) INTEGER\n* Specifies the parameter to be returned as the value of\n* ILAENV.\n* = 1: the optimal blocksize; if this value is 1, an unblocked\n* algorithm will give the best performance.\n* = 2: the minimum block size for which the block routine\n* should be used; if the usable block size is less than\n* this value, an unblocked routine should be used.\n* = 3: the crossover point (in a block routine, for N less\n* than this value, an unblocked routine should be used)\n* = 4: the number of shifts, used in the nonsymmetric\n* eigenvalue routines (DEPRECATED)\n* = 5: the minimum column dimension for blocking to be used;\n* rectangular blocks must have dimension at least k by m,\n* where k is given by ILAENV(2,...) and m by ILAENV(5,...)\n* = 6: the crossover point for the SVD (when reducing an m by n\n* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds\n* this value, a QR factorization is used first to reduce\n* the matrix to a triangular form.)\n* = 7: the number of processors\n* = 8: the crossover point for the multishift QR method\n* for nonsymmetric eigenvalue problems (DEPRECATED)\n* = 9: maximum size of the subproblems at the bottom of the\n* computation tree in the divide-and-conquer algorithm\n* (used by xGELSD and xGESDD)\n* =10: ieee NaN arithmetic can be trusted not to trap\n* =11: infinity arithmetic can be trusted not to trap\n* 12 <= ISPEC <= 16:\n* xHSEQR or one of its subroutines,\n* see IPARMQ for detailed explanation\n*\n* NAME (input) CHARACTER*(*)\n* The name of the calling subroutine, in either upper case or\n* lower case.\n*\n* OPTS (input) CHARACTER*(*)\n* The character options to the subroutine NAME, concatenated\n* into a single character string. For example, UPLO = 'U',\n* TRANS = 'T', and DIAG = 'N' for a triangular routine would\n* be specified as OPTS = 'UTN'.\n*\n* N1 (input) INTEGER\n* N2 (input) INTEGER\n* N3 (input) INTEGER\n* N4 (input) INTEGER\n* Problem dimensions for the subroutine NAME; these may not all\n* be required.\n*\n\n* Further Details\n* ===============\n*\n* The following conventions have been used when calling ILAENV from the\n* LAPACK routines:\n* 1) OPTS is a concatenation of all of the character options to\n* subroutine NAME, in the same order that they appear in the\n* argument list for NAME, even if they are not used in determining\n* the value of the parameter specified by ISPEC.\n* 2) The problem dimensions N1, N2, N3, N4 are specified in the order\n* that they appear in the argument list for NAME. N1 is used\n* first, N2 second, and so on, and unused problem dimensions are\n* passed a value of -1.\n* 3) The parameter value returned by ILAENV is checked for validity in\n* the calling subroutine. For example, ILAENV is used to retrieve\n* the optimal blocksize for STRTRI as follows:\n*\n* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )\n* IF( NB.LE.1 ) NB = MAX( 1, N )\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IC, IZ, NB, NBMIN, NX\n LOGICAL CNAME, SNAME\n CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CHAR, ICHAR, INT, MIN, REAL\n* ..\n* .. External Functions ..\n INTEGER IEEECK, IPARMQ\n EXTERNAL IEEECK, IPARMQ\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaenv( ispec, name, opts, n1, n2, n3, n4, [: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_ispec = argv[0];
+ rblapack_name = argv[1];
+ rblapack_opts = argv[2];
+ rblapack_n1 = argv[3];
+ rblapack_n2 = argv[4];
+ rblapack_n3 = argv[5];
+ rblapack_n4 = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ispec = NUM2INT(rblapack_ispec);
+ opts = StringValueCStr(rblapack_opts);
+ n2 = NUM2INT(rblapack_n2);
+ n4 = NUM2INT(rblapack_n4);
+ name = StringValueCStr(rblapack_name);
+ n3 = NUM2INT(rblapack_n3);
+ n1 = NUM2INT(rblapack_n1);
+
+ __out__ = ilaenv_(&ispec, name, opts, &n1, &n2, &n3, &n4);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilaenv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilaenv", rblapack_ilaenv, -1);
+}
diff --git a/ext/ilaprec.c b/ext/ilaprec.c
new file mode 100644
index 0000000..2719e2b
--- /dev/null
+++ b/ext/ilaprec.c
@@ -0,0 +1,51 @@
+#include "rb_lapack.h"
+
+extern integer ilaprec_(char* prec);
+
+
+static VALUE
+rblapack_ilaprec(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec;
+ char prec;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilaprec( prec, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAPREC( PREC )\n\n* Purpose\n* =======\n*\n* This subroutine translated from a character string specifying an\n* intermediate precision to the relevant BLAST-specified integer\n* constant.\n*\n* ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a\n* character indicating a supported intermediate precision. Otherwise\n* ILAPREC returns the constant value corresponding to PREC.\n*\n\n* Arguments\n* =========\n* PREC (input) CHARACTER\n* Specifies the form of the system of equations:\n* = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaprec( prec, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_prec = argv[0];
+ if (argc == 1) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec = StringValueCStr(rblapack_prec)[0];
+
+ __out__ = ilaprec_(&prec);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilaprec(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilaprec", rblapack_ilaprec, -1);
+}
diff --git a/ext/ilaslc.c b/ext/ilaslc.c
new file mode 100644
index 0000000..ddf9b5e
--- /dev/null
+++ b/ext/ilaslc.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer ilaslc_(integer* m, integer* n, real* a, integer* lda);
+
+
+static VALUE
+rblapack_ilaslc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilaslc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILASLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILASLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaslc( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+
+ __out__ = ilaslc_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilaslc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilaslc", rblapack_ilaslc, -1);
+}
diff --git a/ext/ilaslr.c b/ext/ilaslr.c
new file mode 100644
index 0000000..8dbc061
--- /dev/null
+++ b/ext/ilaslr.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer ilaslr_(integer* m, integer* n, real* a, integer* lda);
+
+
+static VALUE
+rblapack_ilaslr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilaslr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILASLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILASLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaslr( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+
+ __out__ = ilaslr_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilaslr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilaslr", rblapack_ilaslr, -1);
+}
diff --git a/ext/ilatrans.c b/ext/ilatrans.c
new file mode 100644
index 0000000..9a038cc
--- /dev/null
+++ b/ext/ilatrans.c
@@ -0,0 +1,51 @@
+#include "rb_lapack.h"
+
+extern integer ilatrans_(char* trans);
+
+
+static VALUE
+rblapack_ilatrans(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilatrans( trans, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILATRANS( TRANS )\n\n* Purpose\n* =======\n*\n* This subroutine translates from a character string specifying a\n* transposition operation to the relevant BLAST-specified integer\n* constant.\n*\n* ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not\n* a character indicating a transposition operator. Otherwise ILATRANS\n* returns the constant value corresponding to TRANS.\n*\n\n* Arguments\n* =========\n* TRANS (input) CHARACTER*1\n* Specifies the form of the system of equations:\n* = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilatrans( trans, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_trans = argv[0];
+ if (argc == 1) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+
+ __out__ = ilatrans_(&trans);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilatrans(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilatrans", rblapack_ilatrans, -1);
+}
diff --git a/ext/ilauplo.c b/ext/ilauplo.c
new file mode 100644
index 0000000..21eea16
--- /dev/null
+++ b/ext/ilauplo.c
@@ -0,0 +1,51 @@
+#include "rb_lapack.h"
+
+extern integer ilauplo_(char* uplo);
+
+
+static VALUE
+rblapack_ilauplo(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilauplo( uplo, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAUPLO( UPLO )\n\n* Purpose\n* =======\n*\n* This subroutine translated from a character string specifying a\n* upper- or lower-triangular matrix to the relevant BLAST-specified\n* integer constant.\n*\n* ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not\n* a character indicating an upper- or lower-triangular matrix.\n* Otherwise ILAUPLO returns the constant value corresponding to UPLO.\n*\n\n* Arguments\n* =========\n* UPLO (input) CHARACTER\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilauplo( uplo, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_uplo = argv[0];
+ if (argc == 1) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+
+ __out__ = ilauplo_(&uplo);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilauplo(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilauplo", rblapack_ilauplo, -1);
+}
diff --git a/ext/ilaver.c b/ext/ilaver.c
new file mode 100644
index 0000000..5bdf3bb
--- /dev/null
+++ b/ext/ilaver.c
@@ -0,0 +1,53 @@
+#include "rb_lapack.h"
+
+extern VOID ilaver_(integer* vers_major, integer* vers_minor, integer* vers_patch);
+
+
+static VALUE
+rblapack_ilaver(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vers_major;
+ integer vers_major;
+ VALUE rblapack_vers_minor;
+ integer vers_minor;
+ VALUE rblapack_vers_patch;
+ integer vers_patch;
+
+
+ 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 vers_major, vers_minor, vers_patch = NumRu::Lapack.ilaver( , [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )\n\n* Purpose\n* =======\n*\n* This subroutine return the Lapack version.\n*\n\n* Arguments\n* =========\n* VERS_MAJOR (output) INTEGER\n* return the lapack major version\n* VERS_MINOR (output) INTEGER\n* return the lapack minor version from the major version\n* VERS_PATCH (output) INTEGER\n* return the lapack patch version from the minor version\n\n* =====================================================================\n*\n INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH\n* =====================================================================\n VERS_MAJOR = 3\n VERS_MINOR = 3\n VERS_PATCH = 0\n* =====================================================================\n*\n RETURN\n END\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n vers_major, vers_minor, vers_patch = NumRu::Lapack.ilaver( , [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 0 && argc != 0)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 0)", argc);
+ if (argc == 0) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+
+ ilaver_(&vers_major, &vers_minor, &vers_patch);
+
+ rblapack_vers_major = INT2NUM(vers_major);
+ rblapack_vers_minor = INT2NUM(vers_minor);
+ rblapack_vers_patch = INT2NUM(vers_patch);
+ return rb_ary_new3(3, rblapack_vers_major, rblapack_vers_minor, rblapack_vers_patch);
+}
+
+void
+init_lapack_ilaver(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilaver", rblapack_ilaver, -1);
+}
diff --git a/ext/ilazlc.c b/ext/ilazlc.c
new file mode 100644
index 0000000..b2a5b34
--- /dev/null
+++ b/ext/ilazlc.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer ilazlc_(integer* m, integer* n, doublecomplex* a, integer* lda);
+
+
+static VALUE
+rblapack_ilazlc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilazlc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAZLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILAZLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilazlc( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+
+ __out__ = ilazlc_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilazlc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilazlc", rblapack_ilazlc, -1);
+}
diff --git a/ext/ilazlr.c b/ext/ilazlr.c
new file mode 100644
index 0000000..5212d60
--- /dev/null
+++ b/ext/ilazlr.c
@@ -0,0 +1,65 @@
+#include "rb_lapack.h"
+
+extern integer ilazlr_(integer* m, integer* n, doublecomplex* a, integer* lda);
+
+
+static VALUE
+rblapack_ilazlr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.ilazlr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAZLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILAZLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilazlr( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+
+ __out__ = ilazlr_(&m, &n, a, &lda);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_ilazlr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ilazlr", rblapack_ilazlr, -1);
+}
diff --git a/ext/iparmq.c b/ext/iparmq.c
new file mode 100644
index 0000000..bc8fa0d
--- /dev/null
+++ b/ext/iparmq.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern integer iparmq_(integer* ispec, char* name, char* opts, integer* n, integer* ilo, integer* ihi, integer* lwork);
+
+
+static VALUE
+rblapack_iparmq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ispec;
+ integer ispec;
+ VALUE rblapack_name;
+ char name;
+ VALUE rblapack_opts;
+ char opts;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack___out__;
+ integer __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 __out__ = NumRu::Lapack.iparmq( ispec, name, opts, n, ilo, ihi, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )\n\n* Purpose\n* =======\n*\n* This program sets problem and machine dependent parameters\n* useful for xHSEQR and its subroutines. It is called whenever \n* ILAENV is called with 12 <= ISPEC <= 16\n*\n\n* Arguments\n* =========\n*\n* ISPEC (input) integer scalar\n* ISPEC specifies which tunable parameter IPARMQ should\n* return.\n*\n* ISPEC=12: (INMIN) Matrices of order nmin or less\n* are sent directly to xLAHQR, the implicit\n* double shift QR algorithm. NMIN must be\n* at least 11.\n*\n* ISPEC=13: (INWIN) Size of the deflation window.\n* This is best set greater than or equal to\n* the number of simultaneous shifts NS.\n* Larger matrices benefit from larger deflation\n* windows.\n*\n* ISPEC=14: (INIBL) Determines when to stop nibbling and\n* invest in an (expensive) multi-shift QR sweep.\n* If the aggressive early deflation subroutine\n* finds LD converged eigenvalues from an order\n* NW deflation window and LD.GT.(NW*NIBBLE)/100,\n* then the next QR sweep is skipped and early\n* deflation is applied immediately to the\n* remaining active diagonal block. Setting\n* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a\n* multi-shift QR sweep whenever early deflation\n* finds a converged eigenvalue. Setting\n* IPARMQ(ISPEC=14) greater than or equal to 100\n* prevents TTQRE from skipping a multi-shift\n* QR sweep.\n*\n* ISPEC=15: (NSHFTS) The number of simultaneous shifts in\n* a multi-shift QR iteration.\n*\n* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the\n* following meanings.\n* 0: During the multi-shift QR sweep,\n* xLAQR5 does not accumulate reflections and\n* does not use matrix-matrix multiply to\n* update the far-from-diagonal matrix\n* entries.\n* 1: During the multi-shift QR sweep,\n* xLAQR5 and/or xLAQRaccumulates reflections and uses\n* matrix-matrix multiply to update the\n* far-from-diagonal matrix entries.\n* 2: During the multi-shift QR sweep.\n* xLAQR5 accumulates reflections and takes\n* advantage of 2-by-2 block structure during\n* matrix-matrix multiplies.\n* (If xTRMM is slower than xGEMM, then\n* IPARMQ(ISPEC=16)=1 may be more efficient than\n* IPARMQ(ISPEC=16)=2 despite the greater level of\n* arithmetic work implied by the latter choice.)\n*\n* NAME (input) character string\n* Name of the calling subroutine\n*\n* OPTS (input) character string\n* This is a concatenation of the string arguments to\n* TTQRE.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N.\n*\n* LWORK (input) integer scalar\n* The amount of workspace available.\n*\n\n* Further Details\n* ===============\n*\n* Little is known about how best to choose these parameters.\n* It is possible to use different values of the parameters\n* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.\n*\n* It is probably best to choose different parameters for\n* different matrices and different parameters at different\n* times during the iteration, but this has not been\n* implemented --- yet.\n*\n*\n* The best choices of most of the parameters depend\n* in an ill-understood way on the relative execution\n* rate of xLAQR3 and xLAQR5 and on the nature of each\n* particular eigenvalue problem. Experiment may be the\n* only practical way to determine which choices are most\n* effective.\n*\n* Following is a list of default values supplied by IPARMQ.\n* These defaults may be adjusted in order to attain better\n* performance in any particular computational environment.\n*\n* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* IPARMQ(ISPEC=13) Recommended deflation window size.\n* This depends on ILO, IHI and NS, the\n* number of simultaneous shifts returned\n* by IPARMQ(ISPEC=15). The default for\n* (IHI-ILO+1).LE.500 is NS. The default\n* for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.\n*\n* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.\n* a multi-shift QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 0 30 NS = 2+\n* 30 60 NS = 4+\n* 60 150 NS = 10\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default matrices of this order are\n* passed to the implicit double shift routine\n* xLAHQR. See IPARMQ(ISPEC=12) above. These\n* values of NS are used only in case of a rare\n* xLAHQR failure.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function increasing from 10 to 64.\n*\n* IPARMQ(ISPEC=16) Select structured matrix multiply.\n* (See ISPEC=16 above for details.)\n* Default: 3.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iparmq( ispec, name, opts, n, ilo, ihi, lwork, [: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_ispec = argv[0];
+ rblapack_name = argv[1];
+ rblapack_opts = argv[2];
+ rblapack_n = argv[3];
+ rblapack_ilo = argv[4];
+ rblapack_ihi = argv[5];
+ rblapack_lwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ispec = NUM2INT(rblapack_ispec);
+ opts = StringValueCStr(rblapack_opts)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ lwork = NUM2INT(rblapack_lwork);
+ name = StringValueCStr(rblapack_name)[0];
+ ihi = NUM2INT(rblapack_ihi);
+ n = NUM2INT(rblapack_n);
+
+ __out__ = iparmq_(&ispec, &name, &opts, &n, &ilo, &ihi, &lwork);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_iparmq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "iparmq", rblapack_iparmq, -1);
+}
diff --git a/ext/izmax1.c b/ext/izmax1.c
new file mode 100644
index 0000000..a1651c3
--- /dev/null
+++ b/ext/izmax1.c
@@ -0,0 +1,63 @@
+#include "rb_lapack.h"
+
+extern integer izmax1_(integer* n, doublecomplex* cx, integer* incx);
+
+
+static VALUE
+rblapack_izmax1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ doublecomplex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack___out__;
+ integer __out__;
+
+ 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 __out__ = NumRu::Lapack.izmax1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION IZMAX1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* IZMAX1 finds the index of the element whose real part has maximum\n* absolute value.\n*\n* Based on IZAMAX from Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with ZLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX*16 array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX >= 1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX\n DOUBLE PRECISION SMAX\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function definitions ..\n*\n* NEXT LINE IS THE ONLY MODIFICATION.\n CABS1( ZDUM ) = ABS( ZDUM )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.izmax1( cx, incx, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
+ incx = NUM2INT(rblapack_incx);
+
+ __out__ = izmax1_(&n, cx, &incx);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_izmax1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "izmax1", rblapack_izmax1, -1);
+}
diff --git a/ext/lsamen.c b/ext/lsamen.c
new file mode 100644
index 0000000..8fbcd04
--- /dev/null
+++ b/ext/lsamen.c
@@ -0,0 +1,59 @@
+#include "rb_lapack.h"
+
+extern logical lsamen_(integer* n, char* ca, char* cb);
+
+
+static VALUE
+rblapack_lsamen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ca;
+ char *ca;
+ VALUE rblapack_cb;
+ char *cb;
+ VALUE rblapack___out__;
+ logical __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 __out__ = NumRu::Lapack.lsamen( n, ca, cb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n LOGICAL FUNCTION LSAMEN( N, CA, CB )\n\n* Purpose\n* =======\n*\n* LSAMEN tests if the first N letters of CA are the same as the\n* first N letters of CB, regardless of case.\n* LSAMEN returns .TRUE. if CA and CB are equivalent except for case\n* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )\n* or LEN( CB ) is less than N.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of characters in CA and CB to be compared.\n*\n* CA (input) CHARACTER*(*)\n* CB (input) CHARACTER*(*)\n* CA and CB specify two character strings of length at least N.\n* Only the first N characters of each string will be accessed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC LEN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.lsamen( n, ca, cb, [: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_n = argv[0];
+ rblapack_ca = argv[1];
+ rblapack_cb = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ cb = StringValueCStr(rblapack_cb);
+ ca = StringValueCStr(rblapack_ca);
+
+ __out__ = lsamen_(&n, ca, cb);
+
+ rblapack___out__ = __out__ ? Qtrue : Qfalse;
+ return rblapack___out__;
+}
+
+void
+init_lapack_lsamen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "lsamen", rblapack_lsamen, -1);
+}
diff --git a/ext/rb_lapack.c b/ext/rb_lapack.c
new file mode 100644
index 0000000..02d5e18
--- /dev/null
+++ b/ext/rb_lapack.c
@@ -0,0 +1,3279 @@
+#include "ruby.h"
+#include "rb_lapack.h"
+
+extern void init_lapack_cbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_checon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cheequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cheev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cheevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cheevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cheevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chegs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chegst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chegvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chegvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cherfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cherfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chetd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chetrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chetrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chla_transtype(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chpsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_chseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gbrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gbrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_heamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_hercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_hercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_herfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_herpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_porcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_porcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_syrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_syrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clacgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clacp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clacrm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clacrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claesy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clag2z(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clahef(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clanhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clanhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clanhf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clanhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clanht(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarcm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_classq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_claswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_clauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cpttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_crot(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cspmv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cspr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csrscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csymv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csyr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_csytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctrttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ctzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cuncsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cung2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cung2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cungbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cungl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cungql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cungqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cungr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cungrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cungtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cunmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cupgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_cupmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dbdsdc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ddisna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgejsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgesvj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgsvj0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgsvj1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dhgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dhsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dhseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_disnan(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_gbrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_gercond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_porcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_syrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlabad(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlae2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaed9(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaeda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlag2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlag2s(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlagtf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlagts(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlagv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaln2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlamrg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaneg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlansf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlanst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlanv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlapy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlapy3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaqtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarra(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarre(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlartgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlartgs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaruv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlas2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasd8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasdq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasdt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasq1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasq3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasq4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasq5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasq6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlassq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlaswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlat2s(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dlauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dopgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dopmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorg2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorg2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorgbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorgl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorgql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorgqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorgr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorgrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dorml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dormtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dpttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_drscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsterf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dstevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsygs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsygst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsygv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsygvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsygvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dsytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtrttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dtzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_dzsum1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_icmax1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ieeeck(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilaclc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilaclr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_iladiag(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_iladlc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_iladlr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilaenv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilaprec(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilaslc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilaslr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilatrans(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilauplo(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilaver(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilazlc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ilazlr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_iparmq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_izmax1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_lsamen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sbdsdc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_scsum1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sdisna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgejsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgesvj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgsvj0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgsvj1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_shgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_shsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_shseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sisnan(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_gbrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_gercond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_porcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_syrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slabad(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slae2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaed9(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaeda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slag2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slag2d(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slagtf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slagts(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slagv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaln2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slamrg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaneg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slansf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slanst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slanv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slapy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slapy3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaqtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarra(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarre(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slartgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slartgs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaruv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slas2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasd8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasdq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasdt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasq1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasq3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasq4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasq5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasq6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slassq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slaswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_slauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sopgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sopmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorg2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorg2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorgbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorgl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorgql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorgqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorgr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorgrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sorml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sormtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_spttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_srscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssterf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_sstevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssygs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssygst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssygv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssygvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssygvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ssytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_strttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_stzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_xerbla(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_xerbla_array(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zcgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zcposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zdrscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zheequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zheev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zheevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zheevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zheevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhegs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhegst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhegvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhegvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zherfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zherfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhetd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhetrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhetrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhpsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zhseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gbrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gbrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_heamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_hercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_hercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_herfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_herpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_porcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_porcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_syrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_syrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlacgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlacp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlacrm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlacrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaesy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlag2c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlahef(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlanhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlanhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlanhf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlanhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlanht(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarcm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlassq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlaswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlat2c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zlauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zpttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zrot(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zspmv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zspr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsymv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsyr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zsytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztrttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_ztzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zuncsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zung2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zung2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zungbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zungl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zungql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zungqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zungr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zungrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zungtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zunmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zupgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+extern void init_lapack_zupmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
+
+void Init_lapack(){
+ VALUE mNumRu;
+ VALUE mLapack;
+
+ rb_require("narray");
+
+ mNumRu = rb_define_module("NumRu");
+ mLapack = rb_define_module_under(mNumRu, "Lapack");
+
+ sHelp = ID2SYM(rb_intern("help"));
+ sUsage = ID2SYM(rb_intern("usage"));
+
+ rblapack_ZERO = INT2NUM(0);
+
+ init_lapack_cbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgees(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgels(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgges(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_checon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cheequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cheev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cheevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cheevr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cheevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chegs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chegst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chegv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chegvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chegvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cherfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cherfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chetd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chetrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chetri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chetrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chla_transtype(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chpsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chsein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_chseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gbrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gbrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_heamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_hercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_hercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_herfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_herpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_porcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_porcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_syrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_syrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clacgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clacon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clacp2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clacrm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clacrt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claed0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claed7(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claed8(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claesy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claev2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clag2z(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clags2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clahef(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claic1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clals0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clangb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clange(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clangt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clanhb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clanhe(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clanhf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clanhp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clanht(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clansb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clansp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clansy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clantb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clantp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clantr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clapll(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqge(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqhb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqhe(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqhp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarcm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarft(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clargv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clartg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clartv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clascl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claset(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clasr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_classq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_claswp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clatps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_clauum(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpocon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cposv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpotri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cpttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_crot(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cspmv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cspr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csrscl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cstein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csycon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csymv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csyr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csysv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csytri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_csytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrti2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrtri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctrttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ctzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cuncsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cung2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cung2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cungbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunghr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cungl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunglq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cungql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cungqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cungr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cungrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cungtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmhr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunml2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmlq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cunmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cupgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_cupmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dbdsdc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ddisna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgees(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgejsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgels(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgesvj(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgges(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgsvj0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgsvj1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dhgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dhsein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dhseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_disnan(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_gbrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_gercond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_porcond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_syrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlabad(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlacon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlae2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaebz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed6(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed7(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed8(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaed9(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaeda(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaev2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlag2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlag2s(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlags2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlagtf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlagts(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlagv2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaic1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaln2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlals0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlamrg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaneg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlangb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlange(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlangt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlansb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlansf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlansp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlanst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlansy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlantb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlantp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlantr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlanv2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlapll(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlapy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlapy3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqge(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaqtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarft(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlargv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarra(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarre(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrj(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrk(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlartg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlartgp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlartgs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlartv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaruv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlas2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlascl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd6(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd7(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasd8(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasda(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasdq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasdt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaset(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasq1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasq3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasq4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasq5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasq6(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasrt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlassq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasv2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlaswp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlat2s(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlatps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dlauum(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dopgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dopmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorg2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorg2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorgbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorghr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorgl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorglq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorgql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorgqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorgr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorgrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormhr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dorml2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormlq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dormtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpocon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dposv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpotri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dpttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_drscl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsposv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstebz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsterf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstevr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dstevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsycon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyevr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsygs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsygst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsygv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsygvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsygvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsysv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dsytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrti2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrtri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtrttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dtzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_dzsum1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_icmax1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ieeeck(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilaclc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilaclr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_iladiag(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_iladlc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_iladlr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilaenv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilaprec(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilaslc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilaslr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilatrans(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilauplo(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilaver(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilazlc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ilazlr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_iparmq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_izmax1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_lsamen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sbdsdc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_scsum1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sdisna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgees(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgejsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgels(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgesvj(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgges(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgsvj0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgsvj1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_shgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_shsein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_shseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sisnan(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_gbrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_gercond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_porcond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_syrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slabad(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slacon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slae2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaebz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed6(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed7(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed8(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaed9(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaeda(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaev2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slag2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slag2d(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slags2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slagtf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slagts(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slagv2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaic1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaln2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slals0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slamrg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaneg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slangb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slange(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slangt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slansb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slansf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slansp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slanst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slansy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slantb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slantp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slantr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slanv2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slapll(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slapy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slapy3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqge(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaqtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarft(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slargv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarra(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarre(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrj(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrk(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slartg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slartgp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slartgs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slartv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaruv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slas2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slascl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd6(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd7(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasd8(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasda(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasdq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasdt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaset(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasq1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasq3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasq4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasq5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasq6(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasrt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slassq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasv2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slaswp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slatps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_slauum(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sopgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sopmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorg2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorg2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorgbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorghr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorgl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorglq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorgql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorgqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorgr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorgrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormhr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sorml2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormlq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sormtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spocon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sposv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spotri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_spttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_srscl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstebz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssterf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstevr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_sstevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssycon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyevr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssygs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssygst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssygv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssygvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssygvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssysv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ssytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strti2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strtri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_strttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_stzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_xerbla(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_xerbla_array(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zcgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zcposv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zdrscl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgees(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgels(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgges(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhecon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zheequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zheev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zheevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zheevr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zheevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhegs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhegst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhegv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhegvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhegvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zherfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zherfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhesv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhetd2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhetrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhetri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhetrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpev(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpevd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpevx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpgst(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhpsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhsein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zhseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gbrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gbrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_heamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_hercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_hercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_herfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_herpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_porcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_porcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_syrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_syrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlacgv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlacon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlacp2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlacrm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlacrt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaed0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaed7(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaed8(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaesy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaev2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlag2c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlags2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlahef(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaic1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlals0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlangb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlange(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlangt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlanhb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlanhe(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlanhf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlanhp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlanht(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlansb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlansp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlansy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlantb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlantp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlantr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlapll(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqge(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqhb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqhe(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqhp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarcm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarft(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlargv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlartg(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlartv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlascl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaset(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlasr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlassq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlaswp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlat2c(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlatps(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zlauum(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpocon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zposv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpotri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zpttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zrot(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zspmv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zspr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zstein(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsycon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsymv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsyr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsysv(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsytri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zsytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztftri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztptri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrcon(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrevc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrexc(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrsen(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrsna(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrti2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrtri(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrttf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztrttp(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_ztzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zuncsd(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zung2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zung2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zungbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunghr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zungl2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunglq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zungql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zungqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zungr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zungrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zungtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmbr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmhr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunml2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmlq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmql(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmqr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmr2(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmr3(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmrq(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmrz(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zunmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zupgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+ init_lapack_zupmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
+}
diff --git a/ext/rb_lapack.h b/ext/rb_lapack.h
new file mode 100644
index 0000000..e6f2b77
--- /dev/null
+++ b/ext/rb_lapack.h
@@ -0,0 +1,18 @@
+#include <string.h>
+#include <math.h>
+#include "ruby.h"
+#include "narray.h"
+#include "f2c_minimal.h"
+
+#define MAX(a,b) ((a) > (b) ? (a) : (b))
+#define MIN(a,b) ((a) < (b) ? (a) : (b))
+#define LG(n) ((int)ceil(log((double)(n))/log(2.0)))
+
+extern logical lsame_(char *ca, const char *cb);
+extern integer ilatrans_(char* trans);
+extern integer ilaenv_(integer* ispec, char* name, char* opts, integer* n1, integer* n2, integer* n3, integer* n4);
+
+
+static VALUE sHelp, sUsage;
+static VALUE rblapack_ZERO;
+
diff --git a/ext/sbbcsd.c b/ext/sbbcsd.c
new file mode 100644
index 0000000..486770b
--- /dev/null
+++ b/ext/sbbcsd.c
@@ -0,0 +1,287 @@
+#include "rb_lapack.h"
+
+extern VOID sbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, real* theta, real* phi, real* u1, integer* ldu1, real* u2, integer* ldu2, real* v1t, integer* ldv1t, real* v2t, integer* ldv2t, real* b11d, real* b11e, real* b12d, real* b12e, real* b21d, real* b21e, real* b22d, real* b22e, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sbbcsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_theta;
+ real *theta;
+ VALUE rblapack_phi;
+ real *phi;
+ VALUE rblapack_u1;
+ real *u1;
+ VALUE rblapack_u2;
+ real *u2;
+ VALUE rblapack_v1t;
+ real *v1t;
+ VALUE rblapack_v2t;
+ real *v2t;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_b11d;
+ real *b11d;
+ VALUE rblapack_b11e;
+ real *b11e;
+ VALUE rblapack_b12d;
+ real *b12d;
+ VALUE rblapack_b12e;
+ real *b12e;
+ VALUE rblapack_b21d;
+ real *b21d;
+ VALUE rblapack_b21e;
+ real *b21e;
+ VALUE rblapack_b22d;
+ real *b22d;
+ VALUE rblapack_b22e;
+ real *b22e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_theta_out__;
+ real *theta_out__;
+ VALUE rblapack_u1_out__;
+ real *u1_out__;
+ VALUE rblapack_u2_out__;
+ real *u2_out__;
+ VALUE rblapack_v1t_out__;
+ real *v1t_out__;
+ VALUE rblapack_v2t_out__;
+ real *v2t_out__;
+ real *work;
+
+ integer q;
+ integer ldu1;
+ integer p;
+ integer ldu2;
+ integer ldv1t;
+ integer ldv2t;
+
+ 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 b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.sbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SBBCSD computes the CS decomposition of an orthogonal matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See SORCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the orthogonal matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) REAL array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) REAL array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) REAL array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) REAL array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) REAL array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) REAL array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) REAL array, dimension (Q)\n* When SBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If SBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) REAL array, dimension (Q-1)\n* When SBBCSD converges, B11E contains zeros. If SBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) REAL array, dimension (Q)\n* When SBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If SBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) REAL array, dimension (Q-1)\n* When SBBCSD converges, B12E contains zeros. If SBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* WORK (workspace) 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 >= MAX(1,8*Q).\n*\n* If LWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the WORK array,\n* returns this value as the first entry of the work array, and\n* no error 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* > 0: if SBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.sbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [: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_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_m = argv[5];
+ rblapack_theta = argv[6];
+ rblapack_phi = argv[7];
+ rblapack_u1 = argv[8];
+ rblapack_u2 = argv[9];
+ rblapack_v1t = argv[10];
+ rblapack_v2t = 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;
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_theta))
+ rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
+ if (NA_RANK(rblapack_theta) != 1)
+ rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
+ q = NA_SHAPE0(rblapack_theta);
+ if (NA_TYPE(rblapack_theta) != NA_SFLOAT)
+ rblapack_theta = na_change_type(rblapack_theta, NA_SFLOAT);
+ theta = NA_PTR_TYPE(rblapack_theta, real*);
+ if (!NA_IsNArray(rblapack_u1))
+ rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_u1) != 2)
+ rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
+ ldu1 = NA_SHAPE0(rblapack_u1);
+ p = NA_SHAPE1(rblapack_u1);
+ if (NA_TYPE(rblapack_u1) != NA_SFLOAT)
+ rblapack_u1 = na_change_type(rblapack_u1, NA_SFLOAT);
+ u1 = NA_PTR_TYPE(rblapack_u1, real*);
+ if (!NA_IsNArray(rblapack_v1t))
+ rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v1t) != 2)
+ rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
+ ldv1t = NA_SHAPE0(rblapack_v1t);
+ if (NA_SHAPE1(rblapack_v1t) != q)
+ rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
+ if (NA_TYPE(rblapack_v1t) != NA_SFLOAT)
+ rblapack_v1t = na_change_type(rblapack_v1t, NA_SFLOAT);
+ v1t = NA_PTR_TYPE(rblapack_v1t, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = 8*q;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_u2))
+ rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u2) != 2)
+ rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
+ ldu2 = NA_SHAPE0(rblapack_u2);
+ if (NA_SHAPE1(rblapack_u2) != (m-p))
+ rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
+ if (NA_TYPE(rblapack_u2) != NA_SFLOAT)
+ rblapack_u2 = na_change_type(rblapack_u2, NA_SFLOAT);
+ u2 = NA_PTR_TYPE(rblapack_u2, real*);
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_v2t))
+ rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
+ if (NA_RANK(rblapack_v2t) != 2)
+ rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
+ ldv2t = NA_SHAPE0(rblapack_v2t);
+ if (NA_SHAPE1(rblapack_v2t) != (m-q))
+ rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
+ if (NA_TYPE(rblapack_v2t) != NA_SFLOAT)
+ rblapack_v2t = na_change_type(rblapack_v2t, NA_SFLOAT);
+ v2t = NA_PTR_TYPE(rblapack_v2t, real*);
+ if (!NA_IsNArray(rblapack_phi))
+ rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
+ if (NA_RANK(rblapack_phi) != 1)
+ rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_phi) != (q-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
+ if (NA_TYPE(rblapack_phi) != NA_SFLOAT)
+ rblapack_phi = na_change_type(rblapack_phi, NA_SFLOAT);
+ phi = NA_PTR_TYPE(rblapack_phi, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b11d = NA_PTR_TYPE(rblapack_b11d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b11e = NA_PTR_TYPE(rblapack_b11e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b12d = NA_PTR_TYPE(rblapack_b12d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b12e = NA_PTR_TYPE(rblapack_b12e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b21d = NA_PTR_TYPE(rblapack_b21d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b21e = NA_PTR_TYPE(rblapack_b21e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b22d = NA_PTR_TYPE(rblapack_b22d, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b22e = NA_PTR_TYPE(rblapack_b22e, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, real*);
+ MEMCPY(theta_out__, theta, real, NA_TOTAL(rblapack_theta));
+ rblapack_theta = rblapack_theta_out__;
+ theta = theta_out__;
+ {
+ int shape[2];
+ shape[0] = ldu1;
+ shape[1] = p;
+ rblapack_u1_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, real*);
+ MEMCPY(u1_out__, u1, real, NA_TOTAL(rblapack_u1));
+ rblapack_u1 = rblapack_u1_out__;
+ u1 = u1_out__;
+ {
+ int shape[2];
+ shape[0] = ldu2;
+ shape[1] = m-p;
+ rblapack_u2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, real*);
+ MEMCPY(u2_out__, u2, real, NA_TOTAL(rblapack_u2));
+ rblapack_u2 = rblapack_u2_out__;
+ u2 = u2_out__;
+ {
+ int shape[2];
+ shape[0] = ldv1t;
+ shape[1] = q;
+ rblapack_v1t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, real*);
+ MEMCPY(v1t_out__, v1t, real, NA_TOTAL(rblapack_v1t));
+ rblapack_v1t = rblapack_v1t_out__;
+ v1t = v1t_out__;
+ {
+ int shape[2];
+ shape[0] = ldv2t;
+ shape[1] = m-q;
+ rblapack_v2t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, real*);
+ MEMCPY(v2t_out__, v2t, real, NA_TOTAL(rblapack_v2t));
+ rblapack_v2t = rblapack_v2t_out__;
+ v2t = v2t_out__;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ sbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, work, &lwork, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
+}
+
+void
+init_lapack_sbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sbbcsd", rblapack_sbbcsd, -1);
+}
diff --git a/ext/sbdsdc.c b/ext/sbdsdc.c
new file mode 100644
index 0000000..1154430
--- /dev/null
+++ b/ext/sbdsdc.c
@@ -0,0 +1,157 @@
+#include "rb_lapack.h"
+
+extern VOID sbdsdc_(char* uplo, char* compq, integer* n, real* d, real* e, real* u, integer* ldu, real* vt, integer* ldvt, real* q, integer* iq, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sbdsdc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_iq;
+ integer *iq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer c__9;
+ integer c__0;
+ integer ldq;
+ integer ldvt;
+ integer ldiq;
+ integer lwork;
+ integer ldu;
+ integer smlsiz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, q, iq, info, d, e = NumRu::Lapack.sbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SBDSDC computes the singular value decomposition (SVD) of a real\n* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,\n* using a divide and conquer method, where S is a diagonal matrix\n* with non-negative diagonal elements (the singular values of B), and\n* U and VT are orthogonal matrices of left and right singular vectors,\n* respectively. SBDSDC can be used to compute all singular values,\n* and optionally, singular vectors or singular vectors in compact form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See SLASD3 for details.\n*\n* The code currently calls SLASDQ if singular values only are desired.\n* However, it can be slightly modified to compute singular values\n* using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal.\n* = 'L': B is lower bidiagonal.\n*\n* COMPQ (input) CHARACTER*1\n* Specifies whether singular vectors are to be computed\n* as follows:\n* = 'N': Compute singular values only;\n* = 'P': Compute singular values and compute singular\n* vectors in compact form;\n* = 'I': Compute singular values and singular vectors.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the elements of E contain the offdiagonal\n* elements of the bidiagonal matrix whose SVD is desired.\n* On exit, E has been destroyed.\n*\n* U (output) REAL array, dimension (LDU,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, U contains the left singular vectors\n* of the bidiagonal matrix.\n* For other values of COMPQ, U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1.\n* If singular vectors are desired, then LDU >= max( 1, N ).\n*\n* VT (output) REAL array, dimension (LDVT,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, VT' contains the right singular\n* vectors of the bidiagonal matrix.\n* For other values of COMPQ, VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1.\n* If singular vectors are desired, then LDVT >= max( 1, N ).\n*\n* Q (output) REAL array, dimension (LDQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, Q contains all the REAL data in\n* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, Q is not referenced.\n*\n* IQ (output) INTEGER array, dimension (LDIQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, IQ contains all INTEGER data in\n* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, IQ is not referenced.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK))\n* If COMPQ = 'N' then LWORK >= (4 * N).\n* If COMPQ = 'P' then LWORK >= (6 * N).\n* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n*\n* IWORK (workspace) INTEGER array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value.\n* The update process of divide and conquer failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n* =====================================================================\n* Changed dimension statement in comment describing E from (N) to\n* (N-1). Sven, 17 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, q, iq, info, d, e = NumRu::Lapack.sbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ c__9 = 9;
+ compq = StringValueCStr(rblapack_compq)[0];
+ c__0 = 0;
+ ldvt = lsame_(&compq,"I") ? MAX(1,n) : 0;
+ lwork = lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0;
+ smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ ldiq = lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0;
+ ldq = lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0;
+ ldu = lsame_(&compq,"I") ? MAX(1,n) : 0;
+ {
+ int shape[2];
+ shape[0] = lsame_(&compq,"I") ? ldu : 0;
+ shape[1] = lsame_(&compq,"I") ? n : 0;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&compq,"I") ? ldvt : 0;
+ shape[1] = lsame_(&compq,"I") ? n : 0;
+ rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ {
+ int shape[1];
+ shape[0] = lsame_(&compq,"I") ? ldq : 0;
+ rblapack_q = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ {
+ int shape[1];
+ shape[0] = lsame_(&compq,"I") ? ldiq : 0;
+ rblapack_iq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iq = NA_PTR_TYPE(rblapack_iq, integer*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+ iwork = ALLOC_N(integer, (8*n));
+
+ sbdsdc_(&uplo, &compq, &n, d, e, u, &ldu, vt, &ldvt, q, iq, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_u, rblapack_vt, rblapack_q, rblapack_iq, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_sbdsdc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sbdsdc", rblapack_sbdsdc, -1);
+}
diff --git a/ext/sbdsqr.c b/ext/sbdsqr.c
new file mode 100644
index 0000000..c662ac6
--- /dev/null
+++ b/ext/sbdsqr.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID sbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, real* d, real* e, real* vt, integer* ldvt, real* u, integer* ldu, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sbdsqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nru;
+ integer nru;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_vt_out__;
+ real *vt_out__;
+ VALUE rblapack_u_out__;
+ real *u_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer n;
+ integer ldvt;
+ integer ncvt;
+ integer ldu;
+ integer ldc;
+ integer ncc;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.sbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**T\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**T*VT instead of\n* P**T, for given real input matrices U and VT. When U and VT are the\n* orthogonal matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by SGEBRD, then\n* \n* A = (U*Q) * S * (P**T*VT)\n* \n* is the SVD of A. Optionally, the subroutine may also compute Q**T*C\n* for a given real input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B.\n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) REAL array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**T * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) REAL array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) REAL array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**T * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0:\n* if NCVT = NRU = NCC = 0,\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n* else NCVT = NRU = NCC = 0,\n* the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.sbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_nru = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vt = argv[4];
+ rblapack_u = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ ncvt = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ nru = NUM2INT(rblapack_nru);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (6th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ if (NA_SHAPE1(rblapack_u) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = ncvt;
+ rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
+ MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
+ MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ 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__;
+ work = ALLOC_N(real, (4*n));
+
+ sbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
+}
+
+void
+init_lapack_sbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sbdsqr", rblapack_sbdsqr, -1);
+}
diff --git a/ext/scsum1.c b/ext/scsum1.c
new file mode 100644
index 0000000..867b75d
--- /dev/null
+++ b/ext/scsum1.c
@@ -0,0 +1,63 @@
+#include "rb_lapack.h"
+
+extern real scsum1_(integer* n, complex* cx, integer* incx);
+
+
+static VALUE
+rblapack_scsum1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ complex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack___out__;
+ real __out__;
+
+ 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 __out__ = NumRu::Lapack.scsum1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SCSUM1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* SCSUM1 takes the sum of the absolute values of a complex\n* vector and returns a single precision result.\n*\n* Based on SCASUM from the Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with CLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX > 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, NINCX\n REAL STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.scsum1( cx, incx, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, complex*);
+ incx = NUM2INT(rblapack_incx);
+
+ __out__ = scsum1_(&n, cx, &incx);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_scsum1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "scsum1", rblapack_scsum1, -1);
+}
diff --git a/ext/sdisna.c b/ext/sdisna.c
new file mode 100644
index 0000000..bdf43d5
--- /dev/null
+++ b/ext/sdisna.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID sdisna_(char* job, integer* m, integer* n, real* d, real* sep, integer* info);
+
+
+static VALUE
+rblapack_sdisna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_sep;
+ real *sep;
+ VALUE rblapack_info;
+ integer info;
+
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n sep, info = NumRu::Lapack.sdisna( job, n, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )\n\n* Purpose\n* =======\n*\n* SDISNA computes the reciprocal condition numbers for the eigenvectors\n* of a real symmetric or complex Hermitian matrix or for the left or\n* right singular vectors of a general m-by-n matrix. The reciprocal\n* condition number is the 'gap' between the corresponding eigenvalue or\n* singular value and the nearest other one.\n*\n* The bound on the error, measured by angle in radians, in the I-th\n* computed vector is given by\n*\n* SLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n*\n* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed\n* to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of\n* the error bound.\n*\n* SDISNA may also be used to compute error bounds for eigenvectors of\n* the generalized symmetric definite eigenproblem.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies for which problem the reciprocal condition numbers\n* should be computed:\n* = 'E': the eigenvectors of a symmetric/Hermitian matrix;\n* = 'L': the left singular vectors of a general matrix;\n* = 'R': the right singular vectors of a general matrix.\n*\n* M (input) INTEGER\n* The number of rows of the matrix. M >= 0.\n*\n* N (input) INTEGER\n* If JOB = 'L' or 'R', the number of columns of the matrix,\n* in which case N >= 0. Ignored if JOB = 'E'.\n*\n* D (input) REAL array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The eigenvalues (if JOB = 'E') or singular values (if JOB =\n* 'L' or 'R') of the matrix, in either increasing or decreasing\n* order. If singular values, they must be non-negative.\n*\n* SEP (output) REAL array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The reciprocal condition numbers of the vectors.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sep, info = NumRu::Lapack.sdisna( job, n, d, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_job = argv[0];
+ rblapack_n = argv[1];
+ rblapack_d = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ n = NUM2INT(rblapack_n);
+ {
+ int shape[1];
+ shape[0] = lsame_(&job,"E") ? m : ((lsame_(&job,"L")) || (lsame_(&job,"R"))) ? MIN(m,n) : 0;
+ rblapack_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sep = NA_PTR_TYPE(rblapack_sep, real*);
+
+ sdisna_(&job, &m, &n, d, sep, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_sep, rblapack_info);
+}
+
+void
+init_lapack_sdisna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sdisna", rblapack_sdisna, -1);
+}
diff --git a/ext/sgbbrd.c b/ext/sgbbrd.c
new file mode 100644
index 0000000..c9f7731
--- /dev/null
+++ b/ext/sgbbrd.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID sgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, real* ab, integer* ldab, real* d, real* e, real* q, integer* ldq, real* pt, integer* ldpt, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgbbrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_pt;
+ real *pt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer ldc;
+ integer ncc;
+ integer ldq;
+ integer m;
+ integer ldpt;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.sgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBBRD reduces a real general m-by-n band matrix A to upper\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) REAL array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) REAL array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) REAL array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) REAL array, dimension (2*max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.sgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
+ m = ldab;
+ ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = m;
+ rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ {
+ int shape[2];
+ shape[0] = ldpt;
+ shape[1] = n;
+ rblapack_pt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ pt = NA_PTR_TYPE(rblapack_pt, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ 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__;
+ work = ALLOC_N(real, (2*MAX(m,n)));
+
+ sgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
+}
+
+void
+init_lapack_sgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbbrd", rblapack_sgbbrd, -1);
+}
diff --git a/ext/sgbcon.c b/ext/sgbcon.c
new file mode 100644
index 0000000..854c30f
--- /dev/null
+++ b/ext/sgbcon.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID sgbcon_(char* norm, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ 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 ldab;
+ 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.sgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBCON estimates the reciprocal of the condition number of a real\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by SGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\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/(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.sgbcon( norm, kl, ku, ab, ipiv, anorm, [: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_norm = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_anorm = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sgbcon_(&norm, &n, &kl, &ku, ab, &ldab, 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_sgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbcon", rblapack_sgbcon, -1);
+}
diff --git a/ext/sgbequ.c b/ext/sgbequ.c
new file mode 100644
index 0000000..362430d
--- /dev/null
+++ b/ext/sgbequ.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID sgbequ_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_sgbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequ( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,m);
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ sgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_sgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbequ", rblapack_sgbequ, -1);
+}
diff --git a/ext/sgbequb.c b/ext/sgbequb.c
new file mode 100644
index 0000000..daa637c
--- /dev/null
+++ b/ext/sgbequb.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID sgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_sgbequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from SGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequb( kl, ku, ab, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ m = ldab;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ sgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_sgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbequb", rblapack_sgbequb, -1);
+}
diff --git a/ext/sgbrfs.c b/ext/sgbrfs.c
new file mode 100644
index 0000000..8133073
--- /dev/null
+++ b/ext/sgbrfs.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID sgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ 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 ldab;
+ integer n;
+ integer ldafb;
+ 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.sgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\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 SGBTRS.\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.sgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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*);
+ {
+ 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));
+
+ sgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, 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_sgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbrfs", rblapack_sgbrfs, -1);
+}
diff --git a/ext/sgbrfsx.c b/ext/sgbrfsx.c
new file mode 100644
index 0000000..f7b3f4d
--- /dev/null
+++ b/ext/sgbrfsx.c
@@ -0,0 +1,249 @@
+#include "rb_lapack.h"
+
+extern VOID sgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgbrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.sgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.sgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [: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_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_x = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ 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_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*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ 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*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (8th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_sgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbrfsx", rblapack_sgbrfsx, -1);
+}
diff --git a/ext/sgbsv.c b/ext/sgbsv.c
new file mode 100644
index 0000000..def3fe1
--- /dev/null
+++ b/ext/sgbsv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID sgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sgbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, ab, b = NumRu::Lapack.sgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGBSV computes the solution to a real system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL SGBTRF, SGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.sgbsv( kl, ku, ab, b, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ ku = NUM2INT(rblapack_ku);
+ 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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_sgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbsv", rblapack_sgbsv, -1);
+}
diff --git a/ext/sgbsvx.c b/ext/sgbsvx.c
new file mode 100644
index 0000000..9b99bc9
--- /dev/null
+++ b/ext/sgbsvx.c
@@ -0,0 +1,286 @@
+#include "rb_lapack.h"
+
+extern VOID sgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_afb;
+ real *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_afb_out__;
+ real *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.sgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by SGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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/output) REAL array, dimension (3*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n*\n* value of RCOND would suggest.\n\n* =====================================================================\n* Moved setting of INFO = N+1 so INFO does not subsequently get\n* overwritten. Sven, 17 Mar 05. \n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.sgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 11) {
+ rblapack_afb = argv[6];
+ rblapack_ipiv = argv[7];
+ rblapack_equed = argv[8];
+ rblapack_r = argv[9];
+ rblapack_c = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_afb = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ku = NUM2INT(rblapack_ku);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ }
+ ldafb = 2*kl+ku+1;
+ if (rblapack_afb != Qnil) {
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (option) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_afb) != ldafb)
+ rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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[1];
+ shape[0] = 3*n;
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
+ if (rblapack_afb != Qnil) {
+ MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
+ }
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+
+ sgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_sgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbsvx", rblapack_sgbsvx, -1);
+}
diff --git a/ext/sgbsvxx.c b/ext/sgbsvxx.c
new file mode 100644
index 0000000..4ea36b1
--- /dev/null
+++ b/ext/sgbsvxx.c
@@ -0,0 +1,289 @@
+#include "rb_lapack.h"
+
+extern VOID sgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgbsvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_afb_out__;
+ real *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.sgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBSVXX uses the LU factorization to compute the solution to a\n* real system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In SGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.sgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_equed = argv[7];
+ rblapack_r = argv[8];
+ rblapack_c = argv[9];
+ rblapack_b = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_r))
+ rb_raise(rb_eArgError, "r (9th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th 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_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (10th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ ldx = MAX(1,n);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
+ MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_sgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbsvxx", rblapack_sgbsvxx, -1);
+}
diff --git a/ext/sgbtf2.c b/ext/sgbtf2.c
new file mode 100644
index 0000000..b282307
--- /dev/null
+++ b/ext/sgbtf2.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID sgbtf2_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_sgbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.sgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGBTF2 computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.sgbtf2( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ sgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_sgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbtf2", rblapack_sgbtf2, -1);
+}
diff --git a/ext/sgbtrf.c b/ext/sgbtrf.c
new file mode 100644
index 0000000..623eba3
--- /dev/null
+++ b/ext/sgbtrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID sgbtrf_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_sgbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.sgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGBTRF computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.sgbtrf( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ sgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_sgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbtrf", rblapack_sgbtrf, -1);
+}
diff --git a/ext/sgbtrs.c b/ext/sgbtrs.c
new file mode 100644
index 0000000..cce1eca
--- /dev/null
+++ b/ext/sgbtrs.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID sgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sgbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.sgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGBTRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general band matrix A using the LU factorization computed\n* by SGBTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) REAL array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.sgbtrs( trans, kl, ku, ab, ipiv, b, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_sgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgbtrs", rblapack_sgbtrs, -1);
+}
diff --git a/ext/sgebak.c b/ext/sgebak.c
new file mode 100644
index 0000000..0c1a3f0
--- /dev/null
+++ b/ext/sgebak.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID sgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* scale, integer* m, real* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_sgebak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ real *scale;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ real *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.sgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* SGEBAK forms the right or left eigenvectors of a real general matrix\n* by backward transformation on the computed eigenvectors of the\n* balanced matrix output by SGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to SGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by SGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) REAL array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by SGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) REAL array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by SHSEIN or STREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 info, v = NumRu::Lapack.sgebak( job, side, ilo, ihi, scale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_scale = argv[4];
+ rblapack_v = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_scale))
+ rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_scale) != 1)
+ rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_scale);
+ if (NA_TYPE(rblapack_scale) != NA_SFLOAT)
+ rblapack_scale = na_change_type(rblapack_scale, NA_SFLOAT);
+ scale = NA_PTR_TYPE(rblapack_scale, real*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ 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__;
+
+ sgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_sgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgebak", rblapack_sgebak, -1);
+}
diff --git a/ext/sgebal.c b/ext/sgebal.c
new file mode 100644
index 0000000..a9be59c
--- /dev/null
+++ b/ext/sgebal.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID sgebal_(char* job, integer* n, real* a, integer* lda, integer* ilo, integer* ihi, real* scale, integer* info);
+
+
+static VALUE
+rblapack_sgebal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ real *scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 ilo, ihi, scale, info, a = NumRu::Lapack.sgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* SGEBAL balances a general real matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine BALANC.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.sgebal( job, 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_job = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, 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__;
+
+ sgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
+
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgebal", rblapack_sgebal, -1);
+}
diff --git a/ext/sgebd2.c b/ext/sgebd2.c
new file mode 100644
index 0000000..3eb75f1
--- /dev/null
+++ b/ext/sgebd2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID sgebd2_(integer* m, integer* n, real* a, integer* lda, real* d, real* e, real* tauq, real* taup, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgebd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tauq;
+ real *tauq;
+ VALUE rblapack_taup;
+ real *taup;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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 d, e, tauq, taup, info, a = NumRu::Lapack.sgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEBD2 reduces a real general m by n matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) REAL array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* WORK (workspace) REAL array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.sgebd2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, 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__;
+ work = ALLOC_N(real, (MAX(m,n)));
+
+ sgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgebd2", rblapack_sgebd2, -1);
+}
diff --git a/ext/sgebrd.c b/ext/sgebrd.c
new file mode 100644
index 0000000..57ccc86
--- /dev/null
+++ b/ext/sgebrd.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID sgebrd_(integer* m, integer* n, real* a, integer* lda, real* d, real* e, real* tauq, real* taup, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgebrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tauq;
+ real *tauq;
+ VALUE rblapack_taup;
+ real *taup;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 d, e, tauq, taup, work, info, a = NumRu::Lapack.sgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEBRD reduces a general real M-by-N matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) REAL array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\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 length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.sgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgebrd", rblapack_sgebrd, -1);
+}
diff --git a/ext/sgecon.c b/ext/sgecon.c
new file mode 100644
index 0000000..0de0d18
--- /dev/null
+++ b/ext/sgecon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID sgecon_(char* norm, integer* n, real* a, integer* lda, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgecon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ 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 rcond, info = NumRu::Lapack.sgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGECON estimates the reciprocal of the condition number of a general\n* real matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by SGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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/(norm(A) * norm(inv(A))).\n*\n* WORK (workspace) REAL array, dimension (4*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.sgecon( norm, a, anorm, [: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_norm = argv[0];
+ rblapack_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sgecon_(&norm, &n, a, &lda, &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_sgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgecon", rblapack_sgecon, -1);
+}
diff --git a/ext/sgeequ.c b/ext/sgeequ.c
new file mode 100644
index 0000000..1271bc9
--- /dev/null
+++ b/ext/sgeequ.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID sgeequ_(integer* m, integer* n, real* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_sgeequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ sgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_sgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeequ", rblapack_sgeequ, -1);
+}
diff --git a/ext/sgeequb.c b/ext/sgeequb.c
new file mode 100644
index 0000000..a05fca0
--- /dev/null
+++ b/ext/sgeequb.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID sgeequb_(integer* m, integer* n, real* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);
+
+
+static VALUE
+rblapack_sgeequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from SGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+
+ sgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_sgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeequb", rblapack_sgeequb, -1);
+}
diff --git a/ext/sgees.c b/ext/sgees.c
new file mode 100644
index 0000000..00734fd
--- /dev/null
+++ b/ext/sgees.c
@@ -0,0 +1,148 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(real *arg0, real *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID sgees_(char* jobvs, char* sort, L_fp select, integer* n, real* a, integer* lda, integer* sdim, real* wr, real* wi, real* vs, integer* ldvs, real* work, integer* lwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_sgees(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_vs;
+ real *vs;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, wr, wi, vs, work, info, a = NumRu::Lapack.sgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEES computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n*\n* A matrix is in real Schur form if it is upper quasi-triangular with\n* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n* form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n* conjugate pair of eigenvalues is selected, then both complex\n* eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO is set to N+2 (see INFO below).\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues in the same order\n* that they appear on the diagonal of the output Schur form T.\n* Complex conjugate pairs of eigenvalues will appear\n* consecutively with the eigenvalue having the positive\n* imaginary part first.\n*\n* VS (output) REAL array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,3*N).\n* For good performance, LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the matrix which reduces A\n* to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, wr, wi, vs, work, info, a = NumRu::Lapack.sgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[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);
+ n = 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*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ sgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, work, &lwork, bwork, &info);
+
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgees", rblapack_sgees, -1);
+}
diff --git a/ext/sgeesx.c b/ext/sgeesx.c
new file mode 100644
index 0000000..c538d95
--- /dev/null
+++ b/ext/sgeesx.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(real *arg0, real *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID sgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, real* a, integer* lda, integer* sdim, real* wr, real* wi, real* vs, integer* ldvs, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_sgeesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_vs;
+ real *vs;
+ VALUE rblapack_rconde;
+ real rconde;
+ VALUE rblapack_rcondv;
+ real rcondv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.sgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEESX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A real matrix is in real Schur form if it is upper quasi-triangular\n* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n* the form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n* complex conjugate pair of eigenvalues is selected, then both\n* are. Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO may be set to N+3 (see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the N-by-N matrix A.\n* On exit, A is overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts, respectively,\n* of the computed eigenvalues, in the same order that they\n* appear on the diagonal of the output Schur form T. Complex\n* conjugate pairs of eigenvalues appear consecutively with the\n* eigenvalue having the positive imaginary part first.\n*\n* VS (output) REAL array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) REAL\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\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 >= max(1,3*N).\n* Also, if SENSE = 'E' or 'V' or 'B',\n* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n* selected eigenvalues computed by this routine. Note that\n* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n* 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bounds on the optimal sizes of the\n* arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n* may not be large enough.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates upper bounds on the optimal sizes of\n* the arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.sgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_sense = argv[2];
+ rblapack_a = argv[3];
+ rblapack_liwork = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[0];
+ sense = StringValueCStr(rblapack_sense)[0];
+ liwork = NUM2INT(rblapack_liwork);
+ sort = StringValueCStr(rblapack_sort)[0];
+ 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);
+ n = 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*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n+n*n/2 : 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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__;
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ sgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, &rconde, &rcondv, work, &lwork, iwork, &liwork, bwork, &info);
+
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_rconde = rb_float_new((double)rconde);
+ rblapack_rcondv = rb_float_new((double)rcondv);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeesx", rblapack_sgeesx, -1);
+}
diff --git a/ext/sgeev.c b/ext/sgeev.c
new file mode 100644
index 0000000..8137ae2
--- /dev/null
+++ b/ext/sgeev.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID sgeev_(char* jobvl, char* jobvr, integer* n, real* a, integer* lda, real* wr, real* wi, real* vl, integer* ldvl, real* vr, integer* ldvr, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgeev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 wr, wi, vl, vr, work, info, a = NumRu::Lapack.sgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEEV computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\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 >= max(1,3*N), and\n* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good\n* performance, LWORK must generally be larger.\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* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements i+1:N of WR and WI contain eigenvalues which\n* have converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, vl, vr, work, info, a = NumRu::Lapack.sgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = 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*);
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 4*n : 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeev", rblapack_sgeev, -1);
+}
diff --git a/ext/sgeevx.c b/ext/sgeevx.c
new file mode 100644
index 0000000..85493f0
--- /dev/null
+++ b/ext/sgeevx.c
@@ -0,0 +1,181 @@
+#include "rb_lapack.h"
+
+extern VOID sgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, real* a, integer* lda, real* wr, real* wi, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* ilo, integer* ihi, real* scale, real* abnrm, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgeevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ real *scale;
+ VALUE rblapack_abnrm;
+ real abnrm;
+ VALUE rblapack_rconde;
+ real *rconde;
+ VALUE rblapack_rcondv;
+ real *rcondv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.sgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, i.e. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the real Schur form of the balanced\n* version of the input matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues will appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and \n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) REAL array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) REAL array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n* For good performance, LWORK must generally be larger.\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 (2*N-2)\n* If SENSE = 'N' or 'E', not referenced.\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, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of WR\n* and WI contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.sgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 3*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*(n+6) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+ iwork = ALLOC_N(integer, ((lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2));
+
+ sgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(13, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeevx", rblapack_sgeevx, -1);
+}
diff --git a/ext/sgegs.c b/ext/sgegs.c
new file mode 100644
index 0000000..7565878
--- /dev/null
+++ b/ext/sgegs.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID sgegs_(char* jobvsl, char* jobvsr, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vsl, integer* ldvsl, real* vsr, integer* ldvsr, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgegs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_vsl;
+ real *vsl;
+ VALUE rblapack_vsr;
+ real *vsr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGGES.\n*\n* SGEGS computes the eigenvalues, real Schur form, and, optionally,\n* left and or/right Schur vectors of a real matrix pair (A,B).\n* Given two square matrices A and B, the generalized real Schur\n* factorization has the form\n* \n* A = Q*S*Z**T, B = Q*T*Z**T\n*\n* where Q and Z are orthogonal matrices, T is upper triangular, and S\n* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n* of eigenvalues of (A,B). The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n* \n* If only the eigenvalues of (A,B) are needed, the driver routine\n* SGEGV should be used instead. See SGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper quasi-triangular matrix S from the\n* generalized real Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* real Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) REAL array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and (j+1)-st\n* eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) REAL array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VSL (output) REAL array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) REAL array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\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 >= max(1,4*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:\n* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR\n* The optimal LWORK is 2*N + N*(NB+1).\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* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from SGGBAL\n* =N+2: error return from SGEQRF\n* =N+3: error return from SORMQR\n* =N+4: error return from SORGQR\n* =N+5: error return from SGGHRD\n* =N+6: error return from SHGEQZ (other than failed\n* iteration)\n* =N+7: error return from SGGBAK (computing VSL)\n* =N+8: error return from SGGBAK (computing VSR)\n* =N+9: error return from SLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[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);
+ n = 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*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 4*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgegs", rblapack_sgegs, -1);
+}
diff --git a/ext/sgegv.c b/ext/sgegv.c
new file mode 100644
index 0000000..3e863a9
--- /dev/null
+++ b/ext/sgegv.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID sgegv_(char* jobvl, char* jobvr, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vl, integer* ldvl, real* vr, integer* ldvr, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgegv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGGEV.\n*\n* SGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a real matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n*\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n*\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n*\n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n*\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n*\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the real Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* blocks from the Schur form will be correct. See SGGHRD and\n* SHGEQZ for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only those elements of\n* B corresponding to the diagonal blocks from the Schur form of\n* A will be correct. See SGGHRD and SHGEQZ for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue of\n* GNEP.\n*\n* ALPHAI (output) REAL array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) REAL array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* u(j) = VL(:,j) + i*VL(:,j+1)\n* and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then x(j) = VR(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* x(j) = VR(:,j) + i*VR(:,j+1)\n* and\n* x(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvalues\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:\n* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;\n* The optimal LWORK is:\n* 2*N + MAX( 6*N, N*(NB+1) ).\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from SGGBAL\n* =N+2: error return from SGEQRF\n* =N+3: error return from SORMQR\n* =N+4: error return from SORGQR\n* =N+5: error return from SGGHRD\n* =N+6: error return from SHGEQZ (other than failed\n* iteration)\n* =N+7: error return from STGEVC\n* =N+8: error return from SGGBAK (computing VL)\n* =N+9: error return from SGGBAK (computing VR)\n* =N+10: error return from SLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls SGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, SGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the real Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] See SHGEQZ, SGEGS, or read the book \"Matrix Computations\",\n* by Golub & van Loan, pub. by Johns Hopkins U. Press.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = 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*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 8*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgegv", rblapack_sgegv, -1);
+}
diff --git a/ext/sgehd2.c b/ext/sgehd2.c
new file mode 100644
index 0000000..d661030
--- /dev/null
+++ b/ext/sgehd2.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID sgehd2_(integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgehd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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 tau, info, a = NumRu::Lapack.sgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to SGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgehd2( ilo, ihi, a, [: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_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = 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*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (n));
+
+ sgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgehd2", rblapack_sgehd2, -1);
+}
diff --git a/ext/sgehrd.c b/ext/sgehrd.c
new file mode 100644
index 0000000..420cc08
--- /dev/null
+++ b/ext/sgehrd.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID sgehrd_(integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgehrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 tau, work, info, a = NumRu::Lapack.sgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEHRD reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to SGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = 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*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgehrd", rblapack_sgehrd, -1);
+}
diff --git a/ext/sgejsv.c b/ext/sgejsv.c
new file mode 100644
index 0000000..7157d20
--- /dev/null
+++ b/ext/sgejsv.c
@@ -0,0 +1,159 @@
+#include "rb_lapack.h"
+
+extern VOID sgejsv_(char* joba, char* jobu, char* jobv, char* jobr, char* jobt, char* jobp, integer* m, integer* n, real* a, integer* lda, real* sva, real* u, integer* ldu, real* v, integer* ldv, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgejsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_joba;
+ char joba;
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobr;
+ char jobr;
+ VALUE rblapack_jobt;
+ char jobt;
+ VALUE rblapack_jobp;
+ char jobp;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sva;
+ real *sva;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_work_out__;
+ real *work_out__;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ 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 sva, u, v, iwork, info, work = NumRu::Lapack.sgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n* SGEJSV computes the singular value decomposition (SVD) of a real M-by-N\n* matrix [A], where M >= N. The SVD of [A] is written as\n*\n* [A] = [U] * [SIGMA] * [V]^t,\n*\n* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N\n* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and\n* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are\n* the singular values of [A]. The columns of [U] and [V] are the left and\n* the right singular vectors of [A], respectively. The matrices [U] and [V]\n* are computed and stored in the arrays U and V, respectively. The diagonal\n* of [SIGMA] is computed and stored in the array SVA.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER*1\n* Specifies the level of accuracy:\n* = 'C': This option works well (high relative accuracy) if A = B * D,\n* with well-conditioned B and arbitrary diagonal matrix D.\n* The accuracy cannot be spoiled by COLUMN scaling. The\n* accuracy of the computed output depends on the condition of\n* B, and the procedure aims at the best theoretical accuracy.\n* The relative error max_{i=1:N}|d sigma_i| / sigma_i is\n* bounded by f(M,N)*epsilon* cond(B), independent of D.\n* The input matrix is preprocessed with the QRF with column\n* pivoting. This initial preprocessing and preconditioning by\n* a rank revealing QR factorization is common for all values of\n* JOBA. Additional actions are specified as follows:\n* = 'E': Computation as with 'C' with an additional estimate of the\n* condition number of B. It provides a realistic error bound.\n* = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings\n* D1, D2, and well-conditioned matrix C, this option gives\n* higher accuracy than the 'C' option. If the structure of the\n* input matrix is not known, and relative accuracy is\n* desirable, then this option is advisable. The input matrix A\n* is preprocessed with QR factorization with FULL (row and\n* column) pivoting.\n* = 'G' Computation as with 'F' with an additional estimate of the\n* condition number of B, where A=D*B. If A has heavily weighted\n* rows, then using this condition number gives too pessimistic\n* error bound.\n* = 'A': Small singular values are the noise and the matrix is treated\n* as numerically rank defficient. The error in the computed\n* singular values is bounded by f(m,n)*epsilon*||A||.\n* The computed SVD A = U * S * V^t restores A up to\n* f(m,n)*epsilon*||A||.\n* This gives the procedure the licence to discard (set to zero)\n* all singular values below N*epsilon*||A||.\n* = 'R': Similar as in 'A'. Rank revealing property of the initial\n* QR factorization is used do reveal (using triangular factor)\n* a gap sigma_{r+1} < epsilon * sigma_r in which case the\n* numerical RANK is declared to be r. The SVD is computed with\n* absolute error bounds, but more accurately than with 'A'.\n* \n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the columns of U:\n* = 'U': N columns of U are returned in the array U.\n* = 'F': full set of M left sing. vectors is returned in the array U.\n* = 'W': U may be used as workspace of length M*N. See the description\n* of U.\n* = 'N': U is not computed.\n* \n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the matrix V:\n* = 'V': N columns of V are returned in the array V; Jacobi rotations\n* are not explicitly accumulated.\n* = 'J': N columns of V are returned in the array V, but they are\n* computed as the product of Jacobi rotations. This option is\n* allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.\n* = 'W': V may be used as workspace of length N*N. See the description\n* of V.\n* = 'N': V is not computed.\n* \n* JOBR (input) CHARACTER*1\n* Specifies the RANGE for the singular values. Issues the licence to\n* set to zero small positive singular values if they are outside\n* specified range. If A .NE. 0 is scaled so that the largest singular\n* value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues\n* the licence to kill columns of A whose norm in c*A is less than\n* SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN,\n* where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').\n* = 'N': Do not kill small columns of c*A. This option assumes that\n* BLAS and QR factorizations and triangular solvers are\n* implemented to work in that range. If the condition of A\n* is greater than BIG, use SGESVJ.\n* = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)]\n* (roughly, as described above). This option is recommended.\n* ===========================\n* For computing the singular values in the FULL range [SFMIN,BIG]\n* use SGESVJ.\n* \n* JOBT (input) CHARACTER*1\n* If the matrix is square then the procedure may determine to use\n* transposed A if A^t seems to be better with respect to convergence.\n* If the matrix is not square, JOBT is ignored. This is subject to\n* changes in the future.\n* The decision is based on two values of entropy over the adjoint\n* orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).\n* = 'T': transpose if entropy test indicates possibly faster\n* convergence of Jacobi process if A^t is taken as input. If A is\n* replaced with A^t, then the row pivoting is included automatically.\n* = 'N': do not speculate.\n* This option can be used to compute only the singular values, or the\n* full SVD (U, SIGMA and V). For only one set of singular vectors\n* (U or V), the caller should provide both U and V, as one of the\n* matrices is used as workspace if the matrix A is transposed.\n* The implementer can easily remove this constraint and make the\n* code more complicated. See the descriptions of U and V.\n* \n* JOBP (input) CHARACTER*1\n* Issues the licence to introduce structured perturbations to drown\n* denormalized numbers. This licence should be active if the\n* denormals are poorly implemented, causing slow computation,\n* especially in cases of fast convergence (!). For details see [1,2].\n* For the sake of simplicity, this perturbations are included only\n* when the full SVD or only the singular values are requested. The\n* implementer/user can easily add the perturbation for the cases of\n* computing one set of singular vectors.\n* = 'P': introduce perturbation\n* = 'N': do not perturb\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. M >= N >= 0.\n*\n* A (input/workspace) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) REAL array, dimension (N)\n* On exit,\n* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the\n* computation SVA contains Euclidean column norms of the\n* iterated matrices in the array A.\n* - For WORK(1) .NE. WORK(2): The singular values of A are\n* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if\n* sigma_max(A) overflows or if small singular values have been\n* saved from underflow by scaling the input matrix A.\n* - If JOBR='R' then some of the singular values may be returned\n* as exact zeros obtained by \"set to zero\" because they are\n* below the numerical rank threshold or are denormalized numbers.\n*\n* U (workspace/output) REAL array, dimension ( LDU, N )\n* If JOBU = 'U', then U contains on exit the M-by-N matrix of\n* the left singular vectors.\n* If JOBU = 'F', then U contains on exit the M-by-M matrix of\n* the left singular vectors, including an ONB\n* of the orthogonal complement of the Range(A).\n* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N),\n* then U is used as workspace if the procedure\n* replaces A with A^t. In that case, [V] is computed\n* in U as left singular vectors of A^t and then\n* copied back to the V array. This 'W' option is just\n* a reminder to the caller that in this case U is\n* reserved as workspace of length N*N.\n* If JOBU = 'N' U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U, LDU >= 1.\n* IF JOBU = 'U' or 'F' or 'W', then LDU >= M.\n*\n* V (workspace/output) REAL array, dimension ( LDV, N )\n* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N),\n* then V is used as workspace if the pprocedure\n* replaces A with A^t. In that case, [U] is computed\n* in V as right singular vectors of A^t and then\n* copied back to the U array. This 'W' option is just\n* a reminder to the caller that in this case V is\n* reserved as workspace of length N*N.\n* If JOBV = 'N' V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV >= 1.\n* If JOBV = 'V' or 'J' or 'W', then LDV >= N.\n*\n* WORK (workspace/output) REAL array, dimension at least LWORK.\n* On exit,\n* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such\n* that SCALE*SVA(1:N) are the computed singular values\n* of A. (See the description of SVA().)\n* WORK(2) = See the description of WORK(1).\n* WORK(3) = SCONDA is an estimate for the condition number of\n* column equilibrated A. (If JOBA .EQ. 'E' or 'G')\n* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).\n* It is computed using SPOCON. It holds\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n* where R is the triangular factor from the QRF of A.\n* However, if R is truncated and the numerical rank is\n* determined to be strictly smaller than N, SCONDA is\n* returned as -1, thus indicating that the smallest\n* singular values might be lost.\n*\n* If full SVD is needed, the following two condition numbers are\n* useful for the analysis of the algorithm. They are provied for\n* a developer/implementer who is familiar with the details of\n* the method.\n*\n* WORK(4) = an estimate of the scaled condition number of the\n* triangular factor in the first QR factorization.\n* WORK(5) = an estimate of the scaled condition number of the\n* triangular factor in the second QR factorization.\n* The following two parameters are computed if JOBT .EQ. 'T'.\n* They are provided for a developer/implementer who is familiar\n* with the details of the method.\n*\n* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy\n* of diag(A^t*A) / Trace(A^t*A) taken as point in the\n* probability simplex.\n* WORK(7) = the entropy of A*A^t.\n*\n* LWORK (input) INTEGER\n* Length of WORK to confirm proper allocation of work space.\n* LWORK depends on the job:\n*\n* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and\n* -> .. no scaled condition estimate required ( JOBE.EQ.'N'):\n* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.\n* For optimal performance (blocked code) the optimal value\n* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal\n* block size for xGEQP3/xGEQRF.\n* -> .. an estimate of the scaled condition number of A is\n* required (JOBA='E', 'G'). In this case, LWORK is the maximum\n* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7).\n*\n* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'),\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If SIGMA and the left singular vectors are needed\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and\n* -> .. the singular vectors are computed without explicit\n* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N\n* -> .. in the iterative part, the Jacobi rotations are\n* explicitly accumulated (option, see the description of JOBV),\n* then the minimal requirement is LWORK >= max(M+3*N+N*N,7).\n* For better performance, if NB is the optimal block size,\n* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7).\n*\n* IWORK (workspace/output) INTEGER array, dimension M+3*N.\n* On exit,\n* IWORK(1) = the numerical rank determined after the initial\n* QR factorization with pivoting. See the descriptions\n* of JOBA and JOBR.\n* IWORK(2) = the number of the computed nonzero singular values\n* IWORK(3) = if nonzero, a warning message:\n* If IWORK(3).EQ.1 then some of the column norms of A\n* were denormalized floats. The requested high accuracy\n* is not warranted by the data.\n*\n* INFO (output) INTEGER\n* < 0 : if INFO = -i, then the i-th argument had an illegal value.\n* = 0 : successfull exit;\n* > 0 : SGEJSV did not converge in the maximal allowed number\n* of sweeps. The computed values may be inaccurate.\n*\n\n* Further Details\n* ===============\n*\n* SGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,\n* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an\n* additional row pivoting can be used as a preprocessor, which in some\n* cases results in much higher accuracy. An example is matrix A with the\n* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned\n* diagonal matrices and C is well-conditioned matrix. In that case, complete\n* pivoting in the first QR factorizations provides accuracy dependent on the\n* condition number of C, and independent of D1, D2. Such higher accuracy is\n* not completely understood theoretically, but it works well in practice.\n* Further, if A can be written as A = B*D, with well-conditioned B and some\n* diagonal D, then the high accuracy is guaranteed, both theoretically and\n* in software, independent of D. For more details see [1], [2].\n* The computational range for the singular values can be the full range\n* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS\n* & LAPACK routines called by SGEJSV are implemented to work in that range.\n* If that is not the case, then the restriction for safe computation with\n* the singular values in the range of normalized IEEE numbers is that the\n* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not\n* overflow. This code (SGEJSV) is best used in this restricted range,\n* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are\n* returned as zeros. See JOBR for details on this.\n* Further, this implementation is somewhat slower than the one described\n* in [1,2] due to replacement of some non-LAPACK components, and because\n* the choice of some tuning parameters in the iterative part (SGESVJ) is\n* left to the implementer on a particular machine.\n* The rank revealing QR factorization (in this code: SGEQP3) should be\n* implemented as in [3]. We have a new version of SGEQP3 under development\n* that is more robust than the current one in LAPACK, with a cleaner cut in\n* rank defficient cases. It will be available in the SIGMA library [4].\n* If M is much larger than N, it is obvious that the inital QRF with\n* column pivoting can be preprocessed by the QRF without pivoting. That\n* well known trick is not used in SGEJSV because in some cases heavy row\n* weighting can be treated with complete pivoting. The overhead in cases\n* M much larger than N is then only due to pivoting, but the benefits in\n* terms of accuracy have prevailed. The implementer/user can incorporate\n* this extra QRF step easily. The implementer can also improve data movement\n* (matrix transpose, matrix copy, matrix transposed copy) - this\n* implementation of SGEJSV uses only the simplest, naive data movement.\n*\n* Contributors\n*\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n*\n* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR\n* factorization software - a case study.\n* ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28.\n* LAPACK Working note 176.\n* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, examples and comments\n*\n* Please report all bugs and send interesting examples and/or comments to\n* drmac at math.hr. Thank you.\n*\n* ===========================================================================\n*\n* .. Local Parameters ..\n REAL ZERO, ONE\n PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )\n* ..\n* .. Local Scalars ..\n REAL AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK,\n & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM,\n & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC\n INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING\n LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC,\n & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN,\n & NOSCAL, ROWPIV, RSVEC, TRANSP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, ALOG, AMAX1, AMIN1, FLOAT,\n & MAX0, MIN0, NINT, SIGN, SQRT\n* ..\n* .. External Functions ..\n REAL SLAMCH, SNRM2\n INTEGER ISAMAX\n LOGICAL LSAME\n EXTERNAL ISAMAX, LSAME, SLAMCH, SNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SGELQF, SGEQP3, SGEQRF, SLACPY, SLASCL,\n & SLASET, SLASSQ, SLASWP, SORGQR, SORMLQ,\n & SORMQR, SPOCON, SSCAL, SSWAP, STRSM, XERBLA\n*\n EXTERNAL SGESVJ\n* ..\n*\n* Test the input arguments\n*\n LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' )\n JRACC = LSAME( JOBV, 'J' )\n RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC\n ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' )\n L2RANK = LSAME( JOBA, 'R' )\n L2ABER = LSAME( JOBA, 'A' )\n ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' )\n L2TRAN = LSAME( JOBT, 'T' )\n L2KILL = LSAME( JOBR, 'R' )\n DEFR = LSAME( JOBR, 'N' )\n L2PERT = LSAME( JOBP, 'P' )\n*\n IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR.\n & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN\n INFO = - 1\n ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR.\n & LSAME( JOBU, 'W' )) ) THEN\n INFO = - 2\n ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR.\n & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN\n INFO = - 3\n ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN\n INFO = - 4\n ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN\n INFO = - 5\n ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN\n INFO = - 6\n ELSE IF ( M .LT. 0 ) THEN\n INFO = - 7\n ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN\n INFO = - 8\n ELSE IF ( LDA .LT. M ) THEN\n INFO = - 10\n ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN\n INFO = - 13\n ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN\n INFO = - 14\n ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND.\n & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR.\n & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND.\n & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR.\n & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N))\n & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N)))\n & THEN\n INFO = - 17\n ELSE\n* #:)\n INFO = 0\n END IF\n*\n IF ( INFO .NE. 0 ) THEN\n* #:(\n CALL XERBLA( 'SGEJSV', - INFO )\n END IF\n*\n* Quick return for void matrix (Y3K safe)\n* #:)\n IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN\n*\n* Determine whether the matrix U should be M x N or M x M\n*\n IF ( LSVEC ) THEN\n N1 = N\n IF ( LSAME( JOBU, 'F' ) ) N1 = M\n END IF\n*\n* Set numerical parameters\n*\n*! NOTE: Make sure SLAMCH() does not fail on the target architecture.\n*\n EPSLN = SLAMCH('Epsilon')\n SFMIN = SLAMCH('SafeMinimum')\n SMALL = SFMIN / EPSLN\n BIG = SLAMCH('O')\n*\n* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N\n*\n*(!) If necessary, scale SVA() to protect the largest norm from\n* overflow. It is possible that this scaling pushes the smallest\n* column norm left from the underflow threshold (extreme case).\n*\n SCALEM = ONE / SQRT(FLOAT(M)*FLOAT(N))\n NOSCAL = .TRUE.\n GOSCAL = .TRUE.\n DO 1874 p = 1, N\n AAPP = ZERO\n AAQQ = ONE\n CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ )\n IF ( AAPP .GT. BIG ) THEN\n INFO = - 9\n CALL XERBLA( 'SGEJSV', -INFO )\n RETURN\n END IF\n AAQQ = SQRT(AAQQ)\n IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN\n SVA(p) = AAPP * AAQQ\n ELSE\n NOSCAL = .FALSE.\n SVA(p) = AAPP * ( AAQQ * SCALEM )\n IF ( GOSCAL ) THEN\n GOSCAL = .FALSE.\n CALL SSCAL( p-1, SCALEM, SVA, 1 )\n END IF\n END IF\n 1874 CONTINUE\n*\n IF ( NOSCAL ) SCALEM = ONE\n*\n AAPP = ZERO\n AAQQ = BIG\n DO 4781 p = 1, N\n AAPP = AMAX1( AAPP, SVA(p) )\n IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( AAQQ, SVA(p) )\n 4781 CONTINUE\n*\n* Quick return for zero M x N matrix\n* #:)\n IF ( AAPP .EQ. ZERO ) THEN\n IF ( LSVEC ) CALL SLASET( 'G', M, N1, ZERO, ONE, U, LDU )\n IF ( RSVEC ) CALL SLASET( 'G', N, N, ZERO, ONE, V, LDV )\n WORK(1) = ONE\n WORK(2) = ONE\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n IWORK(1) = 0\n IWORK(2) = 0\n RETURN\n END IF\n*\n* Issue warning if denormalized column norms detected. Override the\n* high relative accuracy request. Issue licence to kill columns\n* (set them to zero) whose norm is less than sigma_max / BIG (roughly).\n* #:(\n WARNING = 0\n IF ( AAQQ .LE. SFMIN ) THEN\n L2RANK = .TRUE.\n L2KILL = .TRUE.\n WARNING = 1\n END IF\n*\n* Quick return for one-column matrix\n* #:)\n IF ( N .EQ. 1 ) THEN\n*\n IF ( LSVEC ) THEN\n CALL SLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )\n CALL SLACPY( 'A', M, 1, A, LDA, U, LDU )\n* computing all M left singular vectors of the M x 1 matrix\n IF ( N1 .NE. N ) THEN\n CALL SGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )\n CALL SORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )\n CALL SCOPY( M, A(1,1), 1, U(1,1), 1 )\n END IF\n END IF\n IF ( RSVEC ) THEN\n V(1,1) = ONE\n END IF\n IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN\n SVA(1) = SVA(1) / SCALEM\n SCALEM = ONE\n END IF\n WORK(1) = ONE / SCALEM\n WORK(2) = ONE\n IF ( SVA(1) .NE. ZERO ) THEN\n IWORK(1) = 1\n IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN\n IWORK(2) = 1\n ELSE\n IWORK(2) = 0\n END IF\n ELSE\n IWORK(1) = 0\n IWORK(2) = 0\n END IF\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n RETURN\n*\n END IF\n*\n TRANSP = .FALSE.\n L2TRAN = L2TRAN .AND. ( M .EQ. N )\n*\n AATMAX = -ONE\n AATMIN = BIG\n IF ( ROWPIV .OR. L2TRAN ) THEN\n*\n* Compute the row norms, needed to determine row pivoting sequence\n* (in the case of heavily row weighted A, row pivoting is strongly\n* advised) and to collect information needed to compare the\n* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).\n*\n IF ( L2TRAN ) THEN\n DO 1950 p = 1, M\n XSC = ZERO\n TEMP1 = ONE\n CALL SLASSQ( N, A(p,1), LDA, XSC, TEMP1 )\n* SLASSQ gets both the ell_2 and the ell_infinity norm\n* in one pass through the vector\n WORK(M+N+p) = XSC * SCALEM\n WORK(N+p) = XSC * (SCALEM*SQRT(TEMP1))\n AATMAX = AMAX1( AATMAX, WORK(N+p) )\n IF (WORK(N+p) .NE. ZERO) AATMIN = AMIN1(AATMIN,WORK(N+p))\n 1950 CONTINUE\n ELSE\n DO 1904 p = 1, M\n WORK(M+N+p) = SCALEM*ABS( A(p,ISAMAX(N,A(p,1),LDA)) )\n AATMAX = AMAX1( AATMAX, WORK(M+N+p) )\n AATMIN = AMIN1( AATMIN, WORK(M+N+p) )\n 1904 CONTINUE\n END IF\n*\n END IF\n*\n* For square matrix A try to determine whether A^t would be better\n* input for the preconditioned Jacobi SVD, with faster convergence.\n* The decision is based on an O(N) function of the vector of column\n* and row norms of A, based on the Shannon entropy. This should give\n* the right choice in most cases when the difference actually matters.\n* It may fail and pick the slower converging side.\n*\n ENTRA = ZERO\n ENTRAT = ZERO\n IF ( L2TRAN ) THEN\n*\n XSC = ZERO\n TEMP1 = ONE\n CALL SLASSQ( N, SVA, 1, XSC, TEMP1 )\n TEMP1 = ONE / TEMP1\n*\n ENTRA = ZERO\n DO 1113 p = 1, N\n BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * ALOG(BIG1)\n 1113 CONTINUE\n ENTRA = - ENTRA / ALOG(FLOAT(N))\n*\n* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.\n* It is derived from the diagonal of A^t * A. Do the same with the\n* diagonal of A * A^t, compute the entropy of the corresponding\n* probability distribution. Note that A * A^t and A^t * A have the\n* same trace.\n*\n ENTRAT = ZERO\n DO 1114 p = N+1, N+M\n BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * ALOG(BIG1)\n 1114 CONTINUE\n ENTRAT = - ENTRAT / ALOG(FLOAT(M))\n*\n* Analyze the entropies and decide A or A^t. Smaller entropy\n* usually means better input for the algorithm.\n*\n TRANSP = ( ENTRAT .LT. ENTRA )\n*\n* If A^t is better than A, transpose A.\n*\n IF ( TRANSP ) THEN\n* In an optimal implementation, this trivial transpose\n* should be replaced with faster transpose.\n DO 1115 p = 1, N - 1\n DO 1116 q = p + 1, N\n TEMP1 = A(q,p)\n A(q,p) = A(p,q)\n A(p,q) = TEMP1\n 1116 CONTINUE\n 1115 CONTINUE\n DO 1117 p = 1, N\n WORK(M+N+p) = SVA(p)\n SVA(p) = WORK(N+p)\n 1117 CONTINUE\n TEMP1 = AAPP\n AAPP = AATMAX\n AATMAX = TEMP1\n TEMP1 = AAQQ\n AAQQ = AATMIN\n AATMIN = TEMP1\n KILL = LSVEC\n LSVEC = RSVEC\n RSVEC = KILL\n IF ( LSVEC ) N1 = N \n*\n ROWPIV = .TRUE.\n END IF\n*\n END IF\n* END IF L2TRAN\n*\n* Scale the matrix so that its maximal singular value remains less\n* than SQRT(BIG) -- the matrix is scaled so that its maximal column\n* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep\n* SQRT(BIG) instead of BIG is the fact that SGEJSV uses LAPACK and\n* BLAS routines that, in some implementations, are not capable of\n* working in the full interval [SFMIN,BIG] and that they may provoke\n* overflows in the intermediate results. If the singular values spread\n* from SFMIN to BIG, then SGESVJ will compute them. So, in that case,\n* one should use SGESVJ instead of SGEJSV.\n*\n BIG1 = SQRT( BIG )\n TEMP1 = SQRT( BIG / FLOAT(N) )\n*\n CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR )\n IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN\n AAQQ = ( AAQQ / AAPP ) * TEMP1\n ELSE\n AAQQ = ( AAQQ * TEMP1 ) / AAPP\n END IF\n TEMP1 = TEMP1 * SCALEM\n CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR )\n*\n* To undo scaling at the end of this procedure, multiply the\n* computed singular values with USCAL2 / USCAL1.\n*\n USCAL1 = TEMP1\n USCAL2 = AAPP\n*\n IF ( L2KILL ) THEN\n* L2KILL enforces computation of nonzero singular values in\n* the restricted range of condition number of the initial A,\n* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN).\n XSC = SQRT( SFMIN )\n ELSE\n XSC = SMALL\n*\n* Now, if the condition number of A is too big,\n* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN,\n* as a precaution measure, the full SVD is computed using SGESVJ\n* with accumulated Jacobi rotations. This provides numerically\n* more robust computation, at the cost of slightly increased run\n* time. Depending on the concrete implementation of BLAS and LAPACK\n* (i.e. how they behave in presence of extreme ill-conditioning) the\n* implementor may decide to remove this switch.\n IF ( ( AAQQ.LT.SQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN\n JRACC = .TRUE.\n END IF\n*\n END IF\n IF ( AAQQ .LT. XSC ) THEN\n DO 700 p = 1, N\n IF ( SVA(p) .LT. XSC ) THEN\n CALL SLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA )\n SVA(p) = ZERO\n END IF\n 700 CONTINUE\n END IF\n*\n* Preconditioning using QR factorization with pivoting\n*\n IF ( ROWPIV ) THEN\n* Optional row permutation (Bjoerck row pivoting):\n* A result by Cox and Higham shows that the Bjoerck's\n* row pivoting combined with standard column pivoting\n* has similar effect as Powell-Reid complete pivoting.\n* The ell-infinity norms of A are made nonincreasing.\n DO 1952 p = 1, M - 1\n q = ISAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1\n IWORK(2*N+p) = q\n IF ( p .NE. q ) THEN\n TEMP1 = WORK(M+N+p)\n WORK(M+N+p) = WORK(M+N+q)\n WORK(M+N+q) = TEMP1\n END IF\n 1952 CONTINUE\n CALL SLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 )\n END IF\n*\n* End of the preparation phase (scaling, optional sorting and\n* transposing, optional flushing of small columns).\n*\n* Preconditioning\n*\n* If the full SVD is needed, the right singular vectors are computed\n* from a matrix equation, and for that we need theoretical analysis\n* of the Businger-Golub pivoting. So we use SGEQP3 as the first RR QRF.\n* In all other cases the first RR QRF can be chosen by other criteria\n* (eg speed by replacing global with restricted window pivoting, such\n* as in SGEQPX from TOMS # 782). Good results will be obtained using\n* SGEQPX with properly (!) chosen numerical parameters.\n* Any improvement of SGEQP3 improves overal performance of SGEJSV.\n*\n* A * P1 = Q1 * [ R1^t 0]^t:\n DO 1963 p = 1, N\n* .. all columns are free columns\n IWORK(p) = 0\n 1963 CONTINUE\n CALL SGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR )\n*\n* The upper triangular matrix R1 from the first QRF is inspected for\n* rank deficiency and possibilities for deflation, or possible\n* ill-conditioning. Depending on the user specified flag L2RANK,\n* the procedure explores possibilities to reduce the numerical\n* rank by inspecting the computed upper triangular factor. If\n* L2RANK or L2ABER are up, then SGEJSV will compute the SVD of\n* A + dA, where ||dA|| <= f(M,N)*EPSLN.\n*\n NR = 1\n IF ( L2ABER ) THEN\n* Standard absolute error bound suffices. All sigma_i with\n* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an\n* agressive enforcement of lower numerical rank by introducing a\n* backward error of the order of N*EPSLN*||A||.\n TEMP1 = SQRT(FLOAT(N))*EPSLN\n DO 3001 p = 2, N\n IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN\n NR = NR + 1\n ELSE\n GO TO 3002\n END IF\n 3001 CONTINUE\n 3002 CONTINUE\n ELSE IF ( L2RANK ) THEN\n* .. similarly as above, only slightly more gentle (less agressive).\n* Sudden drop on the diagonal of R1 is used as the criterion for\n* close-to-rank-defficient.\n TEMP1 = SQRT(SFMIN)\n DO 3401 p = 2, N\n IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR.\n & ( ABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402\n NR = NR + 1\n 3401 CONTINUE\n 3402 CONTINUE\n*\n ELSE\n* The goal is high relative accuracy. However, if the matrix\n* has high scaled condition number the relative accuracy is in\n* general not feasible. Later on, a condition number estimator\n* will be deployed to estimate the scaled condition number.\n* Here we just remove the underflowed part of the triangular\n* factor. This prevents the situation in which the code is\n* working hard to get the accuracy not warranted by the data.\n TEMP1 = SQRT(SFMIN)\n DO 3301 p = 2, N\n IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302\n NR = NR + 1\n 3301 CONTINUE\n 3302 CONTINUE\n*\n END IF\n*\n ALMORT = .FALSE.\n IF ( NR .EQ. N ) THEN\n MAXPRJ = ONE\n DO 3051 p = 2, N\n TEMP1 = ABS(A(p,p)) / SVA(IWORK(p))\n MAXPRJ = AMIN1( MAXPRJ, TEMP1 )\n 3051 CONTINUE\n IF ( MAXPRJ**2 .GE. ONE - FLOAT(N)*EPSLN ) ALMORT = .TRUE.\n END IF\n*\n*\n SCONDA = - ONE\n CONDR1 = - ONE\n CONDR2 = - ONE\n*\n IF ( ERREST ) THEN\n IF ( N .EQ. NR ) THEN\n IF ( RSVEC ) THEN\n* .. V is available as workspace\n CALL SLACPY( 'U', N, N, A, LDA, V, LDV )\n DO 3053 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, V(1,p), 1 )\n 3053 CONTINUE\n CALL SPOCON( 'U', N, V, LDV, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE IF ( LSVEC ) THEN\n* .. U is available as workspace\n CALL SLACPY( 'U', N, N, A, LDA, U, LDU )\n DO 3054 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, U(1,p), 1 )\n 3054 CONTINUE\n CALL SPOCON( 'U', N, U, LDU, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE\n CALL SLACPY( 'U', N, N, A, LDA, WORK(N+1), N )\n DO 3052 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 )\n 3052 CONTINUE\n* .. the columns of R are scaled to have unit Euclidean lengths.\n CALL SPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1,\n & WORK(N+N*N+1), IWORK(2*N+M+1), IERR )\n END IF\n SCONDA = ONE / SQRT(TEMP1)\n* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n ELSE\n SCONDA = - ONE\n END IF\n END IF\n*\n L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) )\n* If there is no violent scaling, artificial perturbation is not needed.\n*\n* Phase 3:\n*\n IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN\n*\n* Singular Values only\n*\n* .. transpose A(1:NR,1:N)\n DO 1946 p = 1, MIN0( N-1, NR )\n CALL SCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1946 CONTINUE\n*\n* The following two DO-loops introduce small relative perturbation\n* into the strict upper triangle of the lower triangular matrix.\n* Small entries below the main diagonal are also changed.\n* This modification is useful if the computing environment does not\n* provide/allow FLUSH TO ZERO underflow, for it prevents many\n* annoying denormalized numbers in case of strongly scaled matrices.\n* The perturbation is structured so that it does not introduce any\n* new perturbation of the singular values, and it does not destroy\n* the job done by the preconditioner.\n* The licence for this perturbation is in the variable L2PERT, which\n* should be .FALSE. if FLUSH TO ZERO underflow is active.\n*\n IF ( .NOT. ALMORT ) THEN\n*\n IF ( L2PERT ) THEN\n* XSC = SQRT(SMALL)\n XSC = EPSLN / FLOAT(N)\n DO 4947 q = 1, NR\n TEMP1 = XSC*ABS(A(q,q))\n DO 4949 p = 1, N\n IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = SIGN( TEMP1, A(p,q) )\n 4949 CONTINUE\n 4947 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA )\n END IF\n*\n* .. second preconditioning using the QR factorization\n*\n CALL SGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR )\n*\n* .. and transpose upper to lower triangular\n DO 1948 p = 1, NR - 1\n CALL SCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1948 CONTINUE\n*\n END IF\n*\n* Row-cyclic Jacobi SVD algorithm with column pivoting\n*\n* .. again some perturbation (a \"background noise\") is added\n* to drown denormals\n IF ( L2PERT ) THEN\n* XSC = SQRT(SMALL)\n XSC = EPSLN / FLOAT(N)\n DO 1947 q = 1, NR\n TEMP1 = XSC*ABS(A(q,q))\n DO 1949 p = 1, NR\n IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = SIGN( TEMP1, A(p,q) )\n 1949 CONTINUE\n 1947 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA )\n END IF\n*\n* .. and one-sided Jacobi rotations are started on a lower\n* triangular matrix (plus perturbation which is ignored in\n* the part which destroys triangular form (confusing?!))\n*\n CALL SGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,\n & N, V, LDV, WORK, LWORK, INFO )\n*\n SCALEM = WORK(1)\n NUMRANK = NINT(WORK(2))\n*\n*\n ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN\n*\n* -> Singular Values and Right Singular Vectors <-\n*\n IF ( ALMORT ) THEN\n*\n* .. in this case NR equals N\n DO 1998 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1998 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL SGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,\n & WORK, LWORK, INFO )\n SCALEM = WORK(1)\n NUMRANK = NINT(WORK(2))\n\n ELSE\n*\n* .. two more QR factorizations ( one QRF is not enough, two require\n* accumulated product of Jacobi rotations, three are perfect )\n*\n CALL SLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )\n CALL SGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)\n CALL SLACPY( 'Lower', NR, NR, A, LDA, V, LDV )\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n CALL SGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n DO 8998 p = 1, NR\n CALL SCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )\n 8998 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL SGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,\n & LDU, WORK(N+1), LWORK, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = NINT(WORK(N+2))\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV )\n CALL SLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )\n END IF\n*\n CALL SORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK,\n & V, LDV, WORK(N+1), LWORK-N, IERR )\n*\n END IF\n*\n DO 8991 p = 1, N\n CALL SCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )\n 8991 CONTINUE\n CALL SLACPY( 'All', N, N, A, LDA, V, LDV )\n*\n IF ( TRANSP ) THEN\n CALL SLACPY( 'All', N, N, V, LDV, U, LDU )\n END IF\n*\n ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN\n*\n* .. Singular Values and Left Singular Vectors ..\n*\n* .. second preconditioning step to avoid need to accumulate\n* Jacobi rotations in the Jacobi iterations.\n DO 1965 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )\n 1965 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL SGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n DO 1967 p = 1, NR - 1\n CALL SCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )\n 1967 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL SGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A,\n & LDA, WORK(N+1), LWORK-N, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = NINT(WORK(N+2))\n*\n IF ( NR .LT. M ) THEN\n CALL SLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )\n CALL SLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )\n END IF\n END IF\n*\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n DO 1974 p = 1, N1\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n CALL SSCAL( M, XSC, U(1,p), 1 )\n 1974 CONTINUE\n*\n IF ( TRANSP ) THEN\n CALL SLACPY( 'All', N, N, U, LDU, V, LDV )\n END IF\n*\n ELSE\n*\n* .. Full SVD ..\n*\n IF ( .NOT. JRACC ) THEN\n*\n IF ( .NOT. ALMORT ) THEN\n*\n* Second Preconditioning Step (QRF [with pivoting])\n* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is\n* equivalent to an LQF CALL. Since in many libraries the QRF\n* seems to be better optimized than the LQF, we do explicit\n* transpose and use the QRF. This is subject to changes in an\n* optimized implementation of SGEJSV.\n*\n DO 1968 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1968 CONTINUE\n*\n* .. the following two loops perturb small entries to avoid\n* denormals in the second QR factorization, where they are\n* as good as zeros. This is done to avoid painfully slow\n* computation with denormals. The relative size of the perturbation\n* is a parameter that can be changed by the implementer.\n* This perturbation device will be obsolete on machines with\n* properly implemented arithmetic.\n* To switch it off, set L2PERT=.FALSE. To remove it from the\n* code, remove the action under L2PERT=.TRUE., leave the ELSE part.\n* The following two loops should be blocked and fused with the\n* transposed copy above.\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 2969 q = 1, NR\n TEMP1 = XSC*ABS( V(q,q) )\n DO 2968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = SIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 2968 CONTINUE\n 2969 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n*\n* Estimate the row scaled condition number of R1\n* (If R1 is rectangular, N > NR, then the condition number\n* of the leading NR x NR submatrix is estimated.)\n*\n CALL SLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )\n DO 3950 p = 1, NR\n TEMP1 = SNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)\n CALL SSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)\n 3950 CONTINUE\n CALL SPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1,\n & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR)\n CONDR1 = ONE / SQRT(TEMP1)\n* .. here need a second oppinion on the condition number\n* .. then assume worst case scenario\n* R1 is OK for inverse <=> CONDR1 .LT. FLOAT(N)\n* more conservative <=> CONDR1 .LT. SQRT(FLOAT(N))\n*\n COND_OK = SQRT(FLOAT(NR))\n*[TP] COND_OK is a tuning parameter.\n\n IF ( CONDR1 .LT. COND_OK ) THEN\n* .. the second QRF without pivoting. Note: in an optimized\n* implementation, this QRF should be implemented as the QRF\n* of a lower triangular matrix.\n* R1^t = Q2 * R2\n CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)/EPSLN\n DO 3959 p = 2, NR\n DO 3958 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n IF ( ABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = SIGN( TEMP1, V(q,p) )\n 3958 CONTINUE\n 3959 CONTINUE\n END IF\n*\n IF ( NR .NE. N )\n* .. save ...\n & CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n* .. this transposed copy should be better than naive\n DO 1969 p = 1, NR - 1\n CALL SCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 )\n 1969 CONTINUE\n*\n CONDR2 = CONDR1\n*\n ELSE\n*\n* .. ill-conditioned case: second QRF with pivoting\n* Note that windowed pivoting would be equaly good\n* numerically, and more run-time efficient. So, in\n* an optimal implementation, the next call to SGEQP3\n* should be replaced with eg. CALL SGEQPX (ACM TOMS #782)\n* with properly (carefully) chosen parameters.\n*\n* R1^t * P2 = Q2 * R2\n DO 3003 p = 1, NR\n IWORK(N+p) = 0\n 3003 CONTINUE\n CALL SGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),\n & WORK(2*N+1), LWORK-2*N, IERR )\n** CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n** & LWORK-2*N, IERR )\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 3969 p = 2, NR\n DO 3968 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n IF ( ABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = SIGN( TEMP1, V(q,p) )\n 3968 CONTINUE\n 3969 CONTINUE\n END IF\n*\n CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 8970 p = 2, NR\n DO 8971 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n V(p,q) = - SIGN( TEMP1, V(q,p) )\n 8971 CONTINUE\n 8970 CONTINUE\n ELSE\n CALL SLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV )\n END IF\n* Now, compute R2 = L3 * Q3, the LQ factorization.\n CALL SGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1),\n & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR )\n* .. and estimate the condition number\n CALL SLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )\n DO 4950 p = 1, NR\n TEMP1 = SNRM2( p, WORK(2*N+N*NR+NR+p), NR )\n CALL SSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )\n 4950 CONTINUE\n CALL SPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1,\n & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR )\n CONDR2 = ONE / SQRT(TEMP1)\n*\n IF ( CONDR2 .GE. COND_OK ) THEN\n* .. save the Householder vectors used for Q3\n* (this overwrittes the copy of R2, as it will not be\n* needed in this branch, but it does not overwritte the\n* Huseholder vectors of Q2.).\n CALL SLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N )\n* .. and the rest of the information on Q3 is in\n* WORK(2*N+N*NR+1:2*N+N*NR+N)\n END IF\n*\n END IF\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 4968 q = 2, NR\n TEMP1 = XSC * V(q,q)\n DO 4969 p = 1, q - 1\n* V(p,q) = - SIGN( TEMP1, V(q,p) )\n V(p,q) = - SIGN( TEMP1, V(p,q) )\n 4969 CONTINUE\n 4968 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV )\n END IF\n*\n* Second preconditioning finished; continue with Jacobi SVD\n* The input matrix is lower trinagular.\n*\n* Recover the right singular vectors as solution of a well\n* conditioned triangular matrix equation.\n*\n IF ( CONDR1 .LT. COND_OK ) THEN\n*\n CALL SGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U,\n & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+NR+2))\n DO 3970 p = 1, NR\n CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL SSCAL( NR, SVA(p), V(1,p), 1 )\n 3970 CONTINUE\n\n* .. pick the right matrix equation and solve it\n*\n IF ( NR. EQ. N ) THEN\n* :)) .. best case, R1 is inverted. The solution of this matrix\n* equation is Q2*V2 = the product of the Jacobi rotations\n* used in SGESVJ, premultiplied with the orthogonal matrix\n* from the second QR factorization.\n CALL STRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV )\n ELSE\n* .. R1 is well conditioned, but non-square. Transpose(R2)\n* is inverted to get the product of the Jacobi rotations\n* used in SGESVJ. The Q-factor from the second QR\n* factorization is then built in explicitly.\n CALL STRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),\n & N,V,LDV)\n IF ( NR .LT. N ) THEN\n CALL SLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)\n CALL SLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)\n CALL SLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)\n END IF\n CALL SORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR)\n END IF\n*\n ELSE IF ( CONDR2 .LT. COND_OK ) THEN\n*\n* :) .. the input matrix A is very likely a relative of\n* the Kahan matrix :)\n* The matrix R2 is inverted. The solution of the matrix equation\n* is Q3^T*V3 = the product of the Jacobi rotations (appplied to\n* the lower triangular L3 from the LQ factorization of\n* R2=L3*Q3), pre-multiplied with the transposed Q3.\n CALL SGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+NR+2))\n DO 3870 p = 1, NR\n CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL SSCAL( NR, SVA(p), U(1,p), 1 )\n 3870 CONTINUE\n CALL STRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU)\n* .. apply the permutation from the second QR factorization\n DO 873 q = 1, NR\n DO 872 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 872 CONTINUE\n DO 874 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 874 CONTINUE\n 873 CONTINUE\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n ELSE\n* Last line of defense.\n* #:( This is a rather pathological case: no scaled condition\n* improvement after two pivoted QR factorizations. Other\n* possibility is that the rank revealing QR factorization\n* or the condition estimator has failed, or the COND_OK\n* is set very close to ONE (which is unnecessary). Normally,\n* this branch should never be executed, but in rare cases of\n* failure of the RRQR or condition estimator, the last line of\n* defense ensures that SGEJSV completes the task.\n* Compute the full SVD of L3 using SGESVJ with explicit\n* accumulation of Jacobi rotations.\n CALL SGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+NR+2))\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n CALL SORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N,\n & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1),\n & LWORK-2*N-N*NR-NR, IERR )\n DO 773 q = 1, NR\n DO 772 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 772 CONTINUE\n DO 774 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 774 CONTINUE\n 773 CONTINUE\n*\n END IF\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = SQRT(FLOAT(N)) * EPSLN\n DO 1972 q = 1, N\n DO 972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 972 CONTINUE\n DO 973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 973 CONTINUE\n XSC = ONE / SNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( N, XSC, V(1,q), 1 )\n 1972 CONTINUE\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n IF ( NR .LT. M ) THEN\n CALL SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)\n CALL SLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU)\n END IF\n END IF\n*\n* The Q matrix from the first QRF is built into the left singular\n* matrix U. This applies to all cases.\n*\n CALL SORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n\n* The columns of U are normalized. The cost is O(M*N) flops.\n TEMP1 = SQRT(FLOAT(M)) * EPSLN\n DO 1973 p = 1, NR\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( M, XSC, U(1,p), 1 )\n 1973 CONTINUE\n*\n* If the initial QRF is computed with row pivoting, the left\n* singular vectors must be adjusted.\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n ELSE\n*\n* .. the initial matrix A has almost orthogonal columns and\n* the second QRF is not needed\n*\n CALL SLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 5970 p = 2, N\n TEMP1 = XSC * WORK( N + (p-1)*N + p )\n DO 5971 q = 1, p - 1\n WORK(N+(q-1)*N+p)=-SIGN(TEMP1,WORK(N+(p-1)*N+q))\n 5971 CONTINUE\n 5970 CONTINUE\n ELSE\n CALL SLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )\n END IF\n*\n CALL SGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA,\n & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO )\n*\n SCALEM = WORK(N+N*N+1)\n NUMRANK = NINT(WORK(N+N*N+2))\n DO 6970 p = 1, N\n CALL SCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )\n CALL SSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )\n 6970 CONTINUE\n*\n CALL STRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,\n & ONE, A, LDA, WORK(N+1), N )\n DO 6972 p = 1, N\n CALL SCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )\n 6972 CONTINUE\n TEMP1 = SQRT(FLOAT(N))*EPSLN\n DO 6971 p = 1, N\n XSC = ONE / SNRM2( N, V(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( N, XSC, V(1,p), 1 )\n 6971 CONTINUE\n*\n* Assemble the left singular vector matrix U (M x N).\n*\n IF ( N .LT. M ) THEN\n CALL SLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU )\n IF ( N .LT. N1 ) THEN\n CALL SLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU )\n CALL SLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )\n END IF\n END IF\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n TEMP1 = SQRT(FLOAT(M))*EPSLN\n DO 6973 p = 1, N1\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( M, XSC, U(1,p), 1 )\n 6973 CONTINUE\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n END IF\n*\n* end of the >> almost orthogonal case << in the full SVD\n*\n ELSE\n*\n* This branch deploys a preconditioned Jacobi SVD with explicitly\n* accumulated rotations. It is included as optional, mainly for\n* experimental purposes. It does perfom well, and can also be used.\n* In this implementation, this branch will be automatically activated\n* if the condition number sigma_max(A) / sigma_min(A) is predicted\n* to be greater than the overflow threshold. This is because the\n* a posteriori computation of the singular vectors assumes robust\n* implementation of BLAS and some LAPACK procedures, capable of working\n* in presence of extreme values. Since that is not always the case, ...\n*\n DO 7968 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 7968 CONTINUE\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL/EPSLN)\n DO 5969 q = 1, NR\n TEMP1 = XSC*ABS( V(q,q) )\n DO 5968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = SIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 5968 CONTINUE\n 5969 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n\n CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n CALL SLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )\n*\n DO 7969 p = 1, NR\n CALL SCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )\n 7969 CONTINUE\n\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL/EPSLN)\n DO 9970 q = 2, NR\n DO 9971 p = 1, q - 1\n TEMP1 = XSC * AMIN1(ABS(U(p,p)),ABS(U(q,q)))\n U(p,q) = - SIGN( TEMP1, U(q,p) )\n 9971 CONTINUE\n 9970 CONTINUE\n ELSE\n CALL SLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n END IF\n\n CALL SGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA,\n & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO )\n SCALEM = WORK(2*N+N*NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+2))\n\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n\n CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = SQRT(FLOAT(N)) * EPSLN\n DO 7972 q = 1, N\n DO 8972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 8972 CONTINUE\n DO 8973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 8973 CONTINUE\n XSC = ONE / SNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( N, XSC, V(1,q), 1 )\n 7972 CONTINUE\n*\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n*\n IF ( NR .LT. M ) THEN\n CALL SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU )\n CALL SLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )\n END IF\n END IF\n*\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n*\n END IF\n IF ( TRANSP ) THEN\n* .. swap U and V because the procedure worked on A^t\n DO 6974 p = 1, N\n CALL SSWAP( N, U(1,p), 1, V(1,p), 1 )\n 6974 CONTINUE\n END IF\n*\n END IF\n* end of the full SVD\n*\n* Undo scaling, if necessary (and possible)\n*\n IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN\n CALL SLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR )\n USCAL1 = ONE\n USCAL2 = ONE\n END IF\n*\n IF ( NR .LT. N ) THEN\n DO 3004 p = NR+1, N\n SVA(p) = ZERO\n 3004 CONTINUE\n END IF\n*\n WORK(1) = USCAL2 * SCALEM\n WORK(2) = USCAL1\n IF ( ERREST ) WORK(3) = SCONDA\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = CONDR1\n WORK(5) = CONDR2\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ENTRA\n WORK(7) = ENTRAT\n END IF\n*\n IWORK(1) = NR\n IWORK(2) = NUMRANK\n IWORK(3) = WARNING\n*\n RETURN\n* ..\n* .. END OF SGEJSV\n* ..\n END\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sva, u, v, iwork, info, work = NumRu::Lapack.sgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_joba = argv[0];
+ rblapack_jobu = argv[1];
+ rblapack_jobv = argv[2];
+ rblapack_jobr = argv[3];
+ rblapack_jobt = argv[4];
+ rblapack_jobp = argv[5];
+ rblapack_m = argv[6];
+ rblapack_a = argv[7];
+ rblapack_work = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ joba = StringValueCStr(rblapack_joba)[0];
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ jobt = StringValueCStr(rblapack_jobt)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (9th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
+ lwork = NA_SHAPE0(rblapack_work);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobp = StringValueCStr(rblapack_jobp)[0];
+ ldu = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? m : 1;
+ jobr = StringValueCStr(rblapack_jobr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (8th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ ldv = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&jobu,"N")&&lsame_(&jobv,"N")) ? MAX(MAX(2*m+n,4*n+n*n),7) : lsame_(&jobv,"V") ? MAX(2*n+m,7) : ((lsame_(&jobu,"U")||lsame_(&jobu,"F"))&&lsame_(&jobv,"V")) ? MAX(MAX(6*n+2*n*n,m+3*n+n*n),7) : MAX(2*n+m,7);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sva = NA_PTR_TYPE(rblapack_sva, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = n;
+ rblapack_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ {
+ int shape[1];
+ shape[0] = m+3*n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = lwork;
+ rblapack_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work_out__ = NA_PTR_TYPE(rblapack_work_out__, real*);
+ MEMCPY(work_out__, work, real, NA_TOTAL(rblapack_work));
+ rblapack_work = rblapack_work_out__;
+ work = work_out__;
+
+ sgejsv_(&joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a, &lda, sva, u, &ldu, v, &ldv, work, &lwork, iwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_sva, rblapack_u, rblapack_v, rblapack_iwork, rblapack_info, rblapack_work);
+}
+
+void
+init_lapack_sgejsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgejsv", rblapack_sgejsv, -1);
+}
diff --git a/ext/sgelq2.c b/ext/sgelq2.c
new file mode 100644
index 0000000..ff7fa9b
--- /dev/null
+++ b/ext/sgelq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID sgelq2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgelq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELQ2 computes an LQ factorization of a real m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgelq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (m));
+
+ sgelq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgelq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgelq2", rblapack_sgelq2, -1);
+}
diff --git a/ext/sgelqf.c b/ext/sgelqf.c
new file mode 100644
index 0000000..a7ed29b
--- /dev/null
+++ b/ext/sgelqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sgelqf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgelqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 tau, work, info, a = NumRu::Lapack.sgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELQF computes an LQ factorization of a real M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGELQ2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgelqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgelqf", rblapack_sgelqf, -1);
+}
diff --git a/ext/sgels.c b/ext/sgels.c
new file mode 100644
index 0000000..44be155
--- /dev/null
+++ b/ext/sgels.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID sgels_(char* trans, integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgels(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 work, info, a, b = NumRu::Lapack.sgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELS solves overdetermined or underdetermined real linear systems\n* involving an M-by-N matrix A, or its transpose, using a QR or LQ\n* factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided: \n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of\n* an undetermined system A**T * X = B.\n*\n* 4. If TRANS = 'T' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**T * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be \n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution \n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'T': the linear system involves A**T. \n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >=0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by SGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by SGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'T'. \n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of\n* elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.sgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } 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 (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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ 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*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(4, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sgels(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgels", rblapack_sgels, -1);
+}
diff --git a/ext/sgelsd.c b/ext/sgelsd.c
new file mode 100644
index 0000000..94bfe1b
--- /dev/null
+++ b/ext/sgelsd.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID sgelsd_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* s, real* rcond, integer* rank, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgelsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+ integer c__9;
+ integer c__0;
+ integer liwork;
+ integer nlvl;
+ integer smlsiz;
+
+ 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 s, rank, work, info, b = NumRu::Lapack.sgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder transformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of 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* A (input) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n* if M is greater than or equal to N or\n* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the array WORK and the\n* minimum size of the array IWORK, and returns these values as\n* the first entries of the WORK and IWORK arrays, and no error\n* message related to LWORK is issued by XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, b = NumRu::Lapack.sgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = 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*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ m = lda;
+ c__9 = 9;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ 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*);
+ ldb = MAX(m,n);
+ c__0 = 0;
+ smlsiz = ilaenv_(&c__9,"SGELSD"," ",&c__0,&c__0,&c__0,&c__0);
+ nlvl = MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1));
+ if (rblapack_lwork == Qnil)
+ lwork = m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ liwork = 3*(MIN(m,n))*nlvl+11*(MIN(m,n));
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+
+ sgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_sgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgelsd", rblapack_sgelsd, -1);
+}
diff --git a/ext/sgelss.c b/ext/sgelss.c
new file mode 100644
index 0000000..2212b06
--- /dev/null
+++ b/ext/sgelss.c
@@ -0,0 +1,148 @@
+#include "rb_lapack.h"
+
+extern VOID sgelss_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* s, real* rcond, integer* rank, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgelss(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 s, rank, work, info, a, b = NumRu::Lapack.sgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELSS computes the minimum norm solution to a real linear least\n* squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(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, and also:\n* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n* For good performance, LWORK should generally be larger.\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* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.sgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = 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*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ 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*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, &info);
+
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgelss", rblapack_sgelss, -1);
+}
diff --git a/ext/sgelsx.c b/ext/sgelsx.c
new file mode 100644
index 0000000..63e2ac1
--- /dev/null
+++ b/ext/sgelsx.c
@@ -0,0 +1,136 @@
+#include "rb_lapack.h"
+
+extern VOID sgelsx_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgelsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 rank, info, a, b, jpvt = NumRu::Lapack.sgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGELSY.\n*\n* SGELSX computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be \n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) REAL array, dimension\n* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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 rank, info, a, b, jpvt = NumRu::Lapack.sgelsx( m, a, b, jpvt, rcond, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_rcond = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(real, (MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)));
+
+ sgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_sgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgelsx", rblapack_sgelsx, -1);
+}
diff --git a/ext/sgelsy.c b/ext/sgelsy.c
new file mode 100644
index 0000000..8b656e9
--- /dev/null
+++ b/ext/sgelsy.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID sgelsy_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgelsy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 rank, work, info, a, b, jpvt = NumRu::Lapack.sgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELSY computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of AP\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\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.\n* The unblocked strategy requires that:\n* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n* where MN = min( M, N ).\n* The block algorithm requires that:\n* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,\n* and SORMRZ.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.sgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_jpvt = argv[2];
+ rblapack_rcond = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = 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_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ ldb = MAX(m,n);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+
+ sgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, &info);
+
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_sgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgelsy", rblapack_sgelsy, -1);
+}
diff --git a/ext/sgeql2.c b/ext/sgeql2.c
new file mode 100644
index 0000000..301b527
--- /dev/null
+++ b/ext/sgeql2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID sgeql2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgeql2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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 tau, info, a = NumRu::Lapack.sgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQL2 computes a QL factorization of a real m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgeql2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (n));
+
+ sgeql2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeql2", rblapack_sgeql2, -1);
+}
diff --git a/ext/sgeqlf.c b/ext/sgeqlf.c
new file mode 100644
index 0000000..91d17e8
--- /dev/null
+++ b/ext/sgeqlf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sgeqlf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgeqlf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 tau, work, info, a = NumRu::Lapack.sgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQLF computes a QL factorization of a real M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQL2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeqlf", rblapack_sgeqlf, -1);
+}
diff --git a/ext/sgeqp3.c b/ext/sgeqp3.c
new file mode 100644
index 0000000..6d4696e
--- /dev/null
+++ b/ext/sgeqp3.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID sgeqp3_(integer* m, integer* n, real* a, integer* lda, integer* jpvt, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgeqp3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_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 tau, work, info, a, jpvt = NumRu::Lapack.sgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* orthogonal matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\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 >= 3*N+1.\n* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n* is the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.sgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n+1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+
+ sgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_sgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeqp3", rblapack_sgeqp3, -1);
+}
diff --git a/ext/sgeqpf.c b/ext/sgeqpf.c
new file mode 100644
index 0000000..22dcfcc
--- /dev/null
+++ b/ext/sgeqpf.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID sgeqpf_(integer* m, integer* n, real* a, integer* lda, integer* jpvt, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgeqpf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ real *work;
+
+ 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 tau, info, a, jpvt = NumRu::Lapack.sgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGEQP3.\n*\n* SGEQPF computes a QR factorization with column pivoting of a\n* real M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the orthogonal matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) REAL array, dimension (3*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.sgeqpf( m, a, jpvt, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(real, (3*n));
+
+ sgeqpf_(&m, &n, a, &lda, jpvt, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_sgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeqpf", rblapack_sgeqpf, -1);
+}
diff --git a/ext/sgeqr2.c b/ext/sgeqr2.c
new file mode 100644
index 0000000..a428985
--- /dev/null
+++ b/ext/sgeqr2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID sgeqr2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgeqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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 tau, info, a = NumRu::Lapack.sgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQR2 computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgeqr2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (n));
+
+ sgeqr2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeqr2", rblapack_sgeqr2, -1);
+}
diff --git a/ext/sgeqr2p.c b/ext/sgeqr2p.c
new file mode 100644
index 0000000..3612aa4
--- /dev/null
+++ b/ext/sgeqr2p.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID sgeqr2p_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgeqr2p(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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 tau, info, a = NumRu::Lapack.sgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQR2P computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgeqr2p( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (n));
+
+ sgeqr2p_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeqr2p", rblapack_sgeqr2p, -1);
+}
diff --git a/ext/sgeqrf.c b/ext/sgeqrf.c
new file mode 100644
index 0000000..d78c9b5
--- /dev/null
+++ b/ext/sgeqrf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sgeqrf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgeqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 tau, work, info, a = NumRu::Lapack.sgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQRF computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is \n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQR2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeqrf", rblapack_sgeqrf, -1);
+}
diff --git a/ext/sgeqrfp.c b/ext/sgeqrfp.c
new file mode 100644
index 0000000..4571f25
--- /dev/null
+++ b/ext/sgeqrfp.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sgeqrfp_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgeqrfp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 tau, work, info, a = NumRu::Lapack.sgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQRFP computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is \n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQR2P, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgeqrfp", rblapack_sgeqrfp, -1);
+}
diff --git a/ext/sgerfs.c b/ext/sgerfs.c
new file mode 100644
index 0000000..11dcc49
--- /dev/null
+++ b/ext/sgerfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID sgerfs_(char* trans, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgerfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ 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 lda;
+ integer n;
+ integer ldaf;
+ 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.sgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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 matrices B and X. NRHS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\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 SGETRS.\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.sgerfs( trans, a, af, ipiv, 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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ 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*);
+ 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 1 of af");
+ 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_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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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));
+
+ sgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, 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_sgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgerfs", rblapack_sgerfs, -1);
+}
diff --git a/ext/sgerfsx.c b/ext/sgerfsx.c
new file mode 100644
index 0000000..6687e46
--- /dev/null
+++ b/ext/sgerfsx.c
@@ -0,0 +1,219 @@
+#include "rb_lapack.h"
+
+extern VOID sgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgerfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.sgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) REAL array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. \n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.sgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_r = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_x = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_x))
+ rb_raise(rb_eArgError, "x (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (9th 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*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (6th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_sgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgerfsx", rblapack_sgerfsx, -1);
+}
diff --git a/ext/sgerq2.c b/ext/sgerq2.c
new file mode 100644
index 0000000..8285bfd
--- /dev/null
+++ b/ext/sgerq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID sgerq2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sgerq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERQ2 computes an RQ factorization of a real m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the orthogonal matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgerq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (m));
+
+ sgerq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgerq2", rblapack_sgerq2, -1);
+}
diff --git a/ext/sgerqf.c b/ext/sgerqf.c
new file mode 100644
index 0000000..8c64b53
--- /dev/null
+++ b/ext/sgerqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sgerqf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgerqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 tau, work, info, a = NumRu::Lapack.sgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERQF computes an RQ factorization of a real M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGERQ2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgerqf", rblapack_sgerqf, -1);
+}
diff --git a/ext/sgesc2.c b/ext/sgesc2.c
new file mode 100644
index 0000000..2af9ca3
--- /dev/null
+++ b/ext/sgesc2.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID sgesc2_(integer* n, real* a, integer* lda, real* rhs, integer* ipiv, integer* jpiv, real* scale);
+
+
+static VALUE
+rblapack_sgesc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_rhs;
+ real *rhs;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_rhs_out__;
+ real *rhs_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 scale, rhs = NumRu::Lapack.sgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* SGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by SGETC2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by SGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) REAL array, dimension (N).\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) REAL\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.sgesc2( a, rhs, ipiv, jpiv, [: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_a = argv[0];
+ rblapack_rhs = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_jpiv = argv[3];
+ if (argc == 4) {
+ } 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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th 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 1 of a");
+ 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_rhs))
+ rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rhs) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_rhs) != NA_SFLOAT)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_SFLOAT);
+ rhs = NA_PTR_TYPE(rblapack_rhs, real*);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, real*);
+ MEMCPY(rhs_out__, rhs, real, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ sgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
+
+ rblapack_scale = rb_float_new((double)scale);
+ return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
+}
+
+void
+init_lapack_sgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgesc2", rblapack_sgesc2, -1);
+}
diff --git a/ext/sgesdd.c b/ext/sgesdd.c
new file mode 100644
index 0000000..be6fc99
--- /dev/null
+++ b/ext/sgesdd.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID sgesdd_(char* jobz, integer* m, integer* n, real* a, integer* lda, real* s, real* u, integer* ldu, real* vt, integer* ldvt, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgesdd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ucol;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.sgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESDD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and right singular\n* vectors. If singular vectors are desired, it uses a\n* divide-and-conquer algorithm.\n*\n* The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**T, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**T are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**T are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* on the array A and all rows of V**T are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**T are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**T are computed.\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 >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**T (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) REAL array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* orthogonal matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) REAL array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N orthogonal matrix V**T;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\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 JOBZ = 'N',\n* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).\n* If JOBZ = 'O',\n* LWORK >= 3*min(M,N) + \n* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n* If JOBZ = 'S' or 'A'\n* LWORK >= 3*min(M,N) +\n* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n* For good performance, LWORK should generally be larger.\n* If LWORK = -1 but other input arguments are legal, WORK(1)\n* returns the optimal LWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: SBDSDC did not converge, updating process failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.sgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ m = lda;
+ ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"N") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,"O") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
+ ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = ucol;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+ iwork = ALLOC_N(integer, (8*MIN(m,n)));
+
+ sgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgesdd", rblapack_sgesdd, -1);
+}
diff --git a/ext/sgesv.c b/ext/sgesv.c
new file mode 100644
index 0000000..300033a
--- /dev/null
+++ b/ext/sgesv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID sgesv_(integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sgesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, a, b = NumRu::Lapack.sgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGESV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL SGETRF, SGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.sgesv( 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);
+ n = 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_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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgesv", rblapack_sgesv, -1);
+}
diff --git a/ext/sgesvd.c b/ext/sgesvd.c
new file mode 100644
index 0000000..321b2d7
--- /dev/null
+++ b/ext/sgesvd.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID sgesvd_(char* jobu, char* jobvt, integer* m, integer* n, real* a, integer* lda, real* s, real* u, integer* ldu, real* vt, integer* ldvt, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgesvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobvt;
+ char jobvt;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.sgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**T, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**T:\n* = 'A': all N rows of V**T are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**T (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**T (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**T (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**T (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) REAL array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) REAL array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n* V**T;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;\n* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n* superdiagonal elements of an upper bidiagonal matrix B\n* whose diagonal is in S (not necessarily sorted). B\n* satisfies A = U * B * VT, so it has the same singular values\n* as A, and singular vectors related by U and VT.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n* For good performance, LWORK should generally be larger.\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* > 0: if SBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of WORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.sgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobu = argv[0];
+ rblapack_jobvt = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[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);
+ n = 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*);
+ m = lda;
+ ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
+ jobvt = StringValueCStr(rblapack_jobvt)[0];
+ ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n));
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = MAX(n, MIN(m,n));
+ rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
+ __shape__[2] = rblapack_a;
+ na_aset(3, __shape__, rblapack_a_out__);
+ }
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ sgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
+ rblapack_a = na_aref(2, __shape__, rblapack_a);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgesvd", rblapack_sgesvd, -1);
+}
diff --git a/ext/sgesvj.c b/ext/sgesvj.c
new file mode 100644
index 0000000..a9914b0
--- /dev/null
+++ b/ext/sgesvj.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID sgesvj_(char* joba, char* jobu, char* jobv, integer* m, integer* n, real* a, integer* lda, real* sva, integer* mv, real* v, integer* ldv, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgesvj(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_joba;
+ char joba;
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_mv;
+ integer mv;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sva;
+ real *sva;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_v_out__;
+ real *v_out__;
+ VALUE rblapack_work_out__;
+ real *work_out__;
+
+ 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 sva, info, a, v, work = NumRu::Lapack.sgesvj( joba, jobu, jobv, m, a, mv, v, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVJ computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, where M >= N. The SVD of A is written as\n* [++] [xx] [x0] [xx]\n* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]\n* [++] [xx]\n* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n* of SIGMA are the singular values of A. The columns of U and V are the\n* left and the right singular vectors of A, respectively.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n* rotations. The rotations are implemented as fast scaled rotations of\n* Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n* column interchanges of de Rijk [2]. The relative accuracy of the computed\n* singular values and the accuracy of the computed singular vectors (in\n* angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n* The condition number that determines the accuracy in the full rank case\n* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n* spectral condition number. The best performance of this Jacobi SVD\n* procedure is achieved if used in an accelerated version of Drmac and\n* Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n* Some tunning parameters (marked with [TP]) are available for the\n* implementer.\n* The computational range for the nonzero singular values is the machine\n* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n* denormalized singular values can be computed with the corresponding\n* gradual loss of accurate digits.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n* ~~~~~~~~~~\n* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n* singular value decomposition on a vector computer.\n* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n* value computation in floating point arithmetic.\n* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER* 1\n* Specifies the structure of A.\n* = 'L': The input matrix A is lower triangular;\n* = 'U': The input matrix A is upper triangular;\n* = 'G': The input matrix A is general M-by-N matrix, M >= N.\n*\n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the left singular vectors\n* (columns of U):\n* = 'U': The left singular vectors corresponding to the nonzero\n* singular values are computed and returned in the leading\n* columns of A. See more details in the description of A.\n* The default numerical orthogonality threshold is set to\n* approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E').\n* = 'C': Analogous to JOBU='U', except that user can control the\n* level of numerical orthogonality of the computed left\n* singular vectors. TOL can be set to TOL = CTOL*EPS, where\n* CTOL is given on input in the array WORK.\n* No CTOL smaller than ONE is allowed. CTOL greater\n* than 1 / EPS is meaningless. The option 'C'\n* can be used if M*EPS is satisfactory orthogonality\n* of the computed left singular vectors, so CTOL=M could\n* save few sweeps of Jacobi rotations.\n* See the descriptions of A and WORK(1).\n* = 'N': The matrix U is not computed. However, see the\n* description of A.\n*\n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the right singular vectors, that\n* is, the matrix V:\n* = 'V' : the matrix V is computed and returned in the array V\n* = 'A' : the Jacobi rotations are applied to the MV-by-N\n* array V. In other words, the right singular vector\n* matrix V is not computed explicitly; instead it is\n* applied to an MV-by-N matrix initially stored in the\n* first MV rows of V.\n* = 'N' : the matrix V is not computed and the array V is not\n* referenced\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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':\n* If INFO .EQ. 0 :\n* RANKA orthonormal columns of U are returned in the\n* leading RANKA columns of the array A. Here RANKA <= N\n* is the number of computed singular values of A that are\n* above the underflow threshold SLAMCH('S'). The singular\n* vectors corresponding to underflowed or zero singular\n* values are not computed. The value of RANKA is returned\n* in the array WORK as RANKA=NINT(WORK(2)). Also see the\n* descriptions of SVA and WORK. The computed columns of U\n* are mutually numerically orthogonal up to approximately\n* TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n* see the description of JOBU.\n* If INFO .GT. 0,\n* the procedure SGESVJ did not converge in the given number\n* of iterations (sweeps). In that case, the computed\n* columns of U may not be orthogonal up to TOL. The output\n* U (stored in A), SIGMA (given by the computed singular\n* values in SVA(1:N)) and V is still a decomposition of the\n* input matrix A in the sense that the residual\n* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n* If JOBU .EQ. 'N':\n* If INFO .EQ. 0 :\n* Note that the left singular vectors are 'for free' in the\n* one-sided Jacobi SVD algorithm. However, if only the\n* singular values are needed, the level of numerical\n* orthogonality of U is not an issue and iterations are\n* stopped when the columns of the iterated matrix are\n* numerically orthogonal up to approximately M*EPS. Thus,\n* on exit, A contains the columns of U scaled with the\n* corresponding singular values.\n* If INFO .GT. 0 :\n* the procedure SGESVJ did not converge in the given number\n* of iterations (sweeps).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) REAL array, dimension (N)\n* On exit,\n* If INFO .EQ. 0 :\n* depending on the value SCALE = WORK(1), we have:\n* If SCALE .EQ. ONE:\n* SVA(1:N) contains the computed singular values of A.\n* During the computation SVA contains the Euclidean column\n* norms of the iterated matrices in the array A.\n* If SCALE .NE. ONE:\n* The singular values of A are SCALE*SVA(1:N), and this\n* factored representation is due to the fact that some of the\n* singular values of A might underflow or overflow.\n*\n* If INFO .GT. 0 :\n* the procedure SGESVJ did not converge in the given number of\n* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n*\n* MV (input) INTEGER\n* If JOBV .EQ. 'A', then the product of Jacobi rotations in SGESVJ\n* is applied to the first MV rows of V. See the description of JOBV.\n*\n* V (input/output) REAL array, dimension (LDV,N)\n* If JOBV = 'V', then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'A', then V contains the product of the computed right\n* singular vector matrix and the initial matrix in\n* the array V.\n* If JOBV = 'N', then V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV .GE. 1.\n* If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n*\n* WORK (input/workspace/output) REAL array, dimension max(4,M+N).\n* On entry,\n* If JOBU .EQ. 'C' :\n* WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n* The process stops if all columns of A are mutually\n* orthogonal up to CTOL*EPS, EPS=SLAMCH('E').\n* It is required that CTOL >= ONE, i.e. it is not\n* allowed to force the routine to obtain orthogonality\n* below EPSILON.\n* On exit,\n* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n* are the computed singular vcalues of A.\n* (See description of SVA().)\n* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n* singular values.\n* WORK(3) = NINT(WORK(3)) is the number of the computed singular\n* values that are larger than the underflow threshold.\n* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n* rotations needed for numerical convergence.\n* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n* This is useful information in cases when SGESVJ did\n* not converge, as it can be used to estimate whether\n* the output is stil useful and for post festum analysis.\n* WORK(6) = the largest absolute value over all sines of the\n* Jacobi rotation angles in the last sweep. It can be\n* useful for a post festum analysis.\n*\n* LWORK length of WORK, WORK >= MAX(6,M+N)\n*\n* INFO (output) INTEGER\n* = 0 : successful exit.\n* < 0 : if INFO = -i, then the i-th argument had an illegal value\n* > 0 : SGESVJ did not converge in the maximal allowed number (30)\n* of sweeps. The output may still be useful. See the\n* description of WORK.\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 INTEGER NSWEEP\n PARAMETER ( NSWEEP = 30 )\n* ..\n* .. Local Scalars ..\n REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n + THSIGN, TOL\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n + SWBAND\n LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n + RSVEC, UCTOL, UPPER\n* ..\n* .. Local Arrays ..\n REAL FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT\n* ..\n* .. External Functions ..\n* from BLAS\n REAL SDOT, SNRM2\n EXTERNAL SDOT, SNRM2\n INTEGER ISAMAX\n EXTERNAL ISAMAX\n* from LAPACK\n REAL SLAMCH\n EXTERNAL SLAMCH\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n* from BLAS\n EXTERNAL SAXPY, SCOPY, SROTM, SSCAL, SSWAP\n* from LAPACK\n EXTERNAL SLASCL, SLASET, SLASSQ, XERBLA\n*\n EXTERNAL SGSVJ0, SGSVJ1\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sva, info, a, v, work = NumRu::Lapack.sgesvj( joba, jobu, jobv, m, a, mv, v, work, [: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_joba = argv[0];
+ rblapack_jobu = argv[1];
+ rblapack_jobv = argv[2];
+ rblapack_m = argv[3];
+ rblapack_a = argv[4];
+ rblapack_mv = argv[5];
+ rblapack_v = argv[6];
+ rblapack_work = 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;
+ }
+
+ joba = StringValueCStr(rblapack_joba)[0];
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th 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 1 of a");
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ mv = NUM2INT(rblapack_mv);
+ m = NUM2INT(rblapack_m);
+ lwork = MAX(6,m+n);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (8th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != lwork)
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be MAX(6,m+n)");
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sva = NA_PTR_TYPE(rblapack_sva, 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[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__;
+ {
+ int shape[1];
+ shape[0] = lwork;
+ rblapack_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work_out__ = NA_PTR_TYPE(rblapack_work_out__, real*);
+ MEMCPY(work_out__, work, real, NA_TOTAL(rblapack_work));
+ rblapack_work = rblapack_work_out__;
+ work = work_out__;
+
+ sgesvj_(&joba, &jobu, &jobv, &m, &n, a, &lda, sva, &mv, v, &ldv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_sva, rblapack_info, rblapack_a, rblapack_v, rblapack_work);
+}
+
+void
+init_lapack_sgesvj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgesvj", rblapack_sgesvj, -1);
+}
diff --git a/ext/sgesvx.c b/ext/sgesvx.c
new file mode 100644
index 0000000..efdf379
--- /dev/null
+++ b/ext/sgesvx.c
@@ -0,0 +1,278 @@
+#include "rb_lapack.h"
+
+extern VOID sgesvx_(char* fact, char* trans, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgesvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_af_out__;
+ real *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.sgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVX uses the LU factorization to compute the solution to a real\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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/output) REAL array, dimension (4*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.sgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 9) {
+ rblapack_af = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_equed = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ } else if (rblapack_options != Qnil) {
+ rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_af = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = 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 (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ldaf = n;
+ 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);
+ 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*);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ }
+ if (rblapack_af != Qnil) {
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (option) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_af) != ldaf)
+ rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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[1];
+ shape[0] = 4*n;
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
+ if (rblapack_af != Qnil) {
+ MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
+ }
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+
+ sgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_sgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgesvx", rblapack_sgesvx, -1);
+}
diff --git a/ext/sgesvxx.c b/ext/sgesvxx.c
new file mode 100644
index 0000000..80bc68c
--- /dev/null
+++ b/ext/sgesvxx.c
@@ -0,0 +1,281 @@
+#include "rb_lapack.h"
+
+extern VOID sgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgesvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_af_out__;
+ real *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ real *r_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.sgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVXX uses the LU factorization to compute the solution to a\n* real system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In SGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.sgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_r = argv[6];
+ rblapack_c = argv[7];
+ rblapack_b = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_r))
+ rb_raise(rb_eArgError, "r (7th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th 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_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, 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[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
+ MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
+ MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_sgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgesvxx", rblapack_sgesvxx, -1);
+}
diff --git a/ext/sgetc2.c b/ext/sgetc2.c
new file mode 100644
index 0000000..d74e28d
--- /dev/null
+++ b/ext/sgetc2.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID sgetc2_(integer* n, real* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);
+
+
+static VALUE
+rblapack_sgetc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 ipiv, jpiv, info, a = NumRu::Lapack.sgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGETC2 computes an LU factorization with complete pivoting of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is the Level 2 BLAS algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the n-by-n matrix A to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, i.e., giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n* we try to solve for x in Ax = b. So U is perturbed to\n* avoid the overflow.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.sgetc2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ 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__;
+
+ sgetc2_(&n, a, &lda, ipiv, jpiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgetc2", rblapack_sgetc2, -1);
+}
diff --git a/ext/sgetf2.c b/ext/sgetf2.c
new file mode 100644
index 0000000..eca3058
--- /dev/null
+++ b/ext/sgetf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID sgetf2_(integer* m, integer* n, real* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_sgetf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 ipiv, info, a = NumRu::Lapack.sgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.sgetf2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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__;
+
+ sgetf2_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgetf2", rblapack_sgetf2, -1);
+}
diff --git a/ext/sgetrf.c b/ext/sgetrf.c
new file mode 100644
index 0000000..7c82a42
--- /dev/null
+++ b/ext/sgetrf.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID sgetrf_(integer* m, integer* n, real* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_sgetrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 ipiv, info, a = NumRu::Lapack.sgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.sgetrf( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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__;
+
+ sgetrf_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgetrf", rblapack_sgetrf, -1);
+}
diff --git a/ext/sgetri.c b/ext/sgetri.c
new file mode 100644
index 0000000..fd60ae7
--- /dev/null
+++ b/ext/sgetri.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sgetri_(integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgetri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 work, info, a = NumRu::Lapack.sgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGETRI computes the inverse of a matrix using the LU factorization\n* computed by SGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_a = argv[0];
+ rblapack_ipiv = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (2th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgetri", rblapack_sgetri, -1);
+}
diff --git a/ext/sgetrs.c b/ext/sgetrs.c
new file mode 100644
index 0000000..51bc64e
--- /dev/null
+++ b/ext/sgetrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sgetrs_(char* trans, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sgetrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.sgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGETRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by SGETRF.\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'* X = B (Transpose)\n* = 'C': A'* 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* A (input) REAL array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.sgetrs( trans, a, ipiv, b, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ 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_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);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_sgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgetrs", rblapack_sgetrs, -1);
+}
diff --git a/ext/sggbak.c b/ext/sggbak.c
new file mode 100644
index 0000000..ca1e741
--- /dev/null
+++ b/ext/sggbak.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID sggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* lscale, real* rscale, integer* m, real* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_sggbak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ real *lscale;
+ VALUE rblapack_rscale;
+ real *rscale;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ real *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.sggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* SGGBAK forms the right or left eigenvectors of a real generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* SGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to SGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by SGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by SGGBAL.\n*\n* RSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by SGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) REAL array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by STGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSCAL, SSWAP, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.sggbak( job, side, ilo, ihi, lscale, rscale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_lscale = argv[4];
+ rblapack_rscale = argv[5];
+ rblapack_v = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_lscale))
+ rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_lscale) != 1)
+ rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_lscale);
+ if (NA_TYPE(rblapack_lscale) != NA_SFLOAT)
+ rblapack_lscale = na_change_type(rblapack_lscale, NA_SFLOAT);
+ lscale = NA_PTR_TYPE(rblapack_lscale, real*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_rscale))
+ rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
+ if (NA_RANK(rblapack_rscale) != 1)
+ rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rscale) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
+ if (NA_TYPE(rblapack_rscale) != NA_SFLOAT)
+ rblapack_rscale = na_change_type(rblapack_rscale, NA_SFLOAT);
+ rscale = NA_PTR_TYPE(rblapack_rscale, real*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ 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__;
+
+ sggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_sggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggbak", rblapack_sggbak, -1);
+}
diff --git a/ext/sggbal.c b/ext/sggbal.c
new file mode 100644
index 0000000..e950a62
--- /dev/null
+++ b/ext/sggbal.c
@@ -0,0 +1,128 @@
+#include "rb_lapack.h"
+
+extern VOID sggbal_(char* job, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* ilo, integer* ihi, real* lscale, real* rscale, real* work, integer* info);
+
+
+static VALUE
+rblapack_sggbal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ real *lscale;
+ VALUE rblapack_rscale;
+ real *rscale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.sggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGBAL balances a pair of general real matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i = 1,...,N.\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j)\n* is the scaling factor applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j)\n* is the scaling factor applied to column j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) REAL array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.sggbal( job, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_job = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = 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*);
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
+
+ sggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
+
+ free(work);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggbal", rblapack_sggbal, -1);
+}
diff --git a/ext/sgges.c b/ext/sgges.c
new file mode 100644
index 0000000..ca80532
--- /dev/null
+++ b/ext/sgges.c
@@ -0,0 +1,198 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(real *arg0, real *arg1, real *arg2){
+ VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+ rblapack_arg2 = rb_float_new((double)(*arg2));
+
+ rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID sgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* sdim, real* alphar, real* alphai, real* beta, real* vsl, integer* ldvsl, real* vsr, integer* ldvsr, real* work, integer* lwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_sgges(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_vsl;
+ real *vsl;
+ VALUE rblapack_vsr;
+ real *vsr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n* the generalized eigenvalues, the generalized real Schur form (S,T),\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T.The\n* leading columns of VSL and VSR then form an orthonormal basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* SGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG);\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n*\n* Note that in the ill-conditioned case, a selected complex\n* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n* in this case.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) REAL array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) REAL array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\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.\n* If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).\n* For good performance , LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ.\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in STGSEN.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[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);
+ n = 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*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(8*n,6*n+16);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ sgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, bwork, &info);
+
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgges", rblapack_sgges, -1);
+}
diff --git a/ext/sggesx.c b/ext/sggesx.c
new file mode 100644
index 0000000..4366c7c
--- /dev/null
+++ b/ext/sggesx.c
@@ -0,0 +1,231 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(real *arg0, real *arg1, real *arg2){
+ VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_float_new((double)(*arg0));
+ rblapack_arg1 = rb_float_new((double)(*arg1));
+ rblapack_arg2 = rb_float_new((double)(*arg2));
+
+ rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID sggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* sdim, real* alphar, real* alphai, real* beta, real* vsl, integer* ldvsl, real* vsr, integer* ldvsr, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_sggesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_vsl;
+ real *vsl;
+ VALUE rblapack_vsr;
+ real *vsr;
+ VALUE rblapack_rconde;
+ real *rconde;
+ VALUE rblapack_rcondv;
+ real *rcondv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ integer *iwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGESX computes for a pair of N-by-N real nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n* since ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) REAL array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) REAL array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) REAL array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition numbers for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n* LWORK >= max( 8*N, 6*N+16 ).\n* Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n* this may not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+6.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in STGSEN.\n*\n\n* Further Details\n* ===============\n*\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / RCONDE( 1 ).\n*\n* An approximate (asymptotic) bound on the maximum angular error in\n* the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / RCONDV( 2 ).\n*\n* See LAPACK User's Guide, section 4.11 for more information.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 8) {
+ rblapack_lwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+6;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ sggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, iwork, &liwork, bwork, &info);
+
+ free(iwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggesx", rblapack_sggesx, -1);
+}
diff --git a/ext/sggev.c b/ext/sggev.c
new file mode 100644
index 0000000..c99b3da
--- /dev/null
+++ b/ext/sggev.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID sggev_(char* jobvl, char* jobvr, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vl, integer* ldvl, real* vr, integer* ldvr, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sggev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B .\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* alpha/beta. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ.\n* =N+2: error return from STGEVC.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = 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*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(1,8*n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggev", rblapack_sggev, -1);
+}
diff --git a/ext/sggevx.c b/ext/sggevx.c
new file mode 100644
index 0000000..e8c4b40
--- /dev/null
+++ b/ext/sggevx.c
@@ -0,0 +1,229 @@
+#include "rb_lapack.h"
+
+extern VOID sggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* ilo, integer* ihi, real* lscale, real* rscale, real* abnrm, real* bbnrm, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_sggevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ real *lscale;
+ VALUE rblapack_rscale;
+ real *rscale;
+ VALUE rblapack_abnrm;
+ real abnrm;
+ VALUE rblapack_bbnrm;
+ real bbnrm;
+ VALUE rblapack_rconde;
+ real *rconde;
+ VALUE rblapack_rcondv;
+ real *rcondv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ integer *iwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j) .\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed.\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) REAL\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) REAL array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* For a complex conjugate pair of eigenvalues two consecutive\n* elements of RCONDE are set to the same value. Thus RCONDE(j),\n* RCONDV(j), and the j-th columns of VL and VR all correspond\n* to the j-th eigenpair.\n* If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) REAL array, dimension (N)\n* If SENSE = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. For a complex eigenvector two consecutive\n* elements of RCONDV are set to the same value. If the\n* eigenvalues cannot be reordered to compute RCONDV(j),\n* RCONDV(j) is set to 0; this can only occur when the true\n* value would be very small anyway.\n* If SENSE = 'N' or 'E', RCONDV is not referenced.\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 >= max(1,2*N).\n* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n* LWORK >= max(1,6*N).\n* If SENSE = 'E', LWORK >= max(1,10*N).\n* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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 (N+6)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ.\n* =N+2: error return from STGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&balanc,"S")||lsame_(&balanc,"B")||lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 6*n : lsame_(&sense,"E") ? 10*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+8*n+16 : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+6));
+ bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
+
+ sggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, iwork, bwork, &info);
+
+ free(iwork);
+ free(bwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_bbnrm = rb_float_new((double)bbnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(17, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggevx", rblapack_sggevx, -1);
+}
diff --git a/ext/sggglm.c b/ext/sggglm.c
new file mode 100644
index 0000000..06955f3
--- /dev/null
+++ b/ext/sggglm.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID sggglm_(integer* n, integer* m, integer* p, real* a, integer* lda, real* b, integer* ldb, real* d, real* x, real* y, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sggglm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ integer p;
+ 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 x, y, work, info, a, b, d = NumRu::Lapack.sggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) REAL array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) REAL array, dimension (M)\n* Y (output) REAL array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* SGEQRF, SGERQF, SORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.sggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_d = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ 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_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);
+ p = 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_y = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_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__;
+
+ sggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
+}
+
+void
+init_lapack_sggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggglm", rblapack_sggglm, -1);
+}
diff --git a/ext/sgghrd.c b/ext/sgghrd.c
new file mode 100644
index 0000000..94bd0cd
--- /dev/null
+++ b/ext/sgghrd.c
@@ -0,0 +1,167 @@
+#include "rb_lapack.h"
+
+extern VOID sgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_sgghrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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, b, q, z = NumRu::Lapack.sgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* SGGHRD reduces a pair of real matrices (A,B) to generalized upper\n* Hessenberg form using orthogonal transformations, where A is a\n* general matrix and B is upper triangular. The form of the\n* generalized eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the orthogonal matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**T*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**T*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**T*x.\n*\n* The orthogonal matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n*\n* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n*\n* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n*\n* If Q1 is the orthogonal matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then SGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Z;\n* = 'I': Z is initialized to the unit matrix, and the\n* orthogonal matrix Z is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry,\n* and the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to SGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**T B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n* typically from the QR factorization of B.\n* On exit, if COMPQ='I', the orthogonal matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n* On exit, if COMPZ='I', the orthogonal matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and Van Loan (Johns Hopkins Press.)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.sgghrd( compq, compz, ilo, ihi, a, b, q, z, [: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_compq = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ sgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_sgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgghrd", rblapack_sgghrd, -1);
+}
diff --git a/ext/sgglse.c b/ext/sgglse.c
new file mode 100644
index 0000000..ac9874d
--- /dev/null
+++ b/ext/sgglse.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID sgglse_(integer* m, integer* n, integer* p, real* a, integer* lda, real* b, integer* ldb, real* c, real* d, real* x, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sgglse(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer m;
+ 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 x, work, info, a, b, c, d = NumRu::Lapack.sgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( (A) ) = N.\n* ( (B) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) REAL array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) REAL array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) REAL array, dimension (N)\n* On exit, X is the solution of the LSE problem.\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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* SGEQRF, SGERQF, SORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.sgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = 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 (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ m = NA_SHAPE0(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_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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+ 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_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);
+ p = 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 (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = p;
+ 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__;
+
+ sgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
+}
+
+void
+init_lapack_sgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgglse", rblapack_sgglse, -1);
+}
diff --git a/ext/sggqrf.c b/ext/sggqrf.c
new file mode 100644
index 0000000..257aeb5
--- /dev/null
+++ b/ext/sggqrf.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID sggqrf_(integer* n, integer* m, integer* p, real* a, integer* lda, real* taua, real* b, integer* ldb, real* taub, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sggqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ real *taua;
+ VALUE rblapack_taub;
+ real *taub;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.sggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the orthogonal matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) REAL array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) REAL array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the orthogonal\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) REAL array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of SORMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine SORGQR.\n* To use Q to update another matrix, use LAPACK subroutine SORMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine SORGRQ.\n* To use Z to update another matrix, use LAPACK subroutine SORMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQRF, SGERQF, SORMQR, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV \n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.sggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_n = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ p = 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*);
+ 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);
+ 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 (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(n,m);
+ rblapack_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(n,p);
+ rblapack_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggqrf", rblapack_sggqrf, -1);
+}
diff --git a/ext/sggrqf.c b/ext/sggrqf.c
new file mode 100644
index 0000000..096a39a
--- /dev/null
+++ b/ext/sggrqf.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID sggrqf_(integer* m, integer* p, integer* n, real* a, integer* lda, real* taua, real* b, integer* ldb, real* taub, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sggrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_p;
+ integer p;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ real *taua;
+ VALUE rblapack_taub;
+ real *taub;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.sggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the orthogonal\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the orthogonal matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) REAL array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of SORMRQ.\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 INF0= -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine SORGRQ.\n* To use Q to update another matrix, use LAPACK subroutine SORMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine SORGQR.\n* To use Z to update another matrix, use LAPACK subroutine SORMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQRF, SGERQF, SORMRQ, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV \n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.sggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_m = argv[0];
+ rblapack_p = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = 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*);
+ p = NUM2INT(rblapack_p);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, real*);
+ {
+ int shape[1];
+ shape[0] = MIN(p,n);
+ rblapack_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggrqf", rblapack_sggrqf, -1);
+}
diff --git a/ext/sggsvd.c b/ext/sggsvd.c
new file mode 100644
index 0000000..dd9cdeb
--- /dev/null
+++ b/ext/sggsvd.c
@@ -0,0 +1,181 @@
+#include "rb_lapack.h"
+
+extern VOID sggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, real* a, integer* lda, real* b, integer* ldb, real* alpha, real* beta, real* u, integer* ldu, real* v, integer* ldv, real* q, integer* ldq, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sggsvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_alpha;
+ real *alpha;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.sggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N real matrix A and P-by-N real matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are orthogonal matrices, and Z' is the transpose\n* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',\n* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n* D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n* following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the orthogonal\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n* also equal to the CS decomposition of A and B. Furthermore, the GSVD\n* can be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) ).\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in the Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix R if M-K-L < 0.\n* See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n* BETA(K+1:M) =S, BETA(M+1:K+L) =1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) REAL array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) REAL array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) REAL array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) REAL array,\n* dimension (max(3*N,M,P)+N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine STGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA REAL\n* TOLB REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n REAL SLAMCH, SLANGE\n EXTERNAL LSAME, SLAMCH, SLANGE\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SGGSVP, STGSJA, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.sggsvd( jobu, jobv, jobq, a, b, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ n = 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*);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (MAX(3*n,m)*(p)+n));
+
+ sggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, iwork, &info);
+
+ free(work);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggsvd", rblapack_sggsvd, -1);
+}
diff --git a/ext/sggsvp.c b/ext/sggsvp.c
new file mode 100644
index 0000000..f8cdc5e
--- /dev/null
+++ b/ext/sggsvp.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID sggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, real* a, integer* lda, real* b, integer* ldb, real* tola, real* tolb, integer* k, integer* l, real* u, integer* ldu, real* v, integer* ldv, real* q, integer* ldq, integer* iwork, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sggsvp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_tola;
+ real tola;
+ VALUE rblapack_tolb;
+ real tolb;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ integer *iwork;
+ real *tau;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, u, v, q, info, a, b = NumRu::Lapack.sggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGSVP computes orthogonal matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* SGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) REAL array, dimension (LDU,M)\n* If JOBU = 'U', U contains the orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) REAL array, dimension (LDV,P)\n* If JOBV = 'V', V contains the orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) REAL array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* TAU (workspace) REAL array, dimension (N)\n*\n* WORK (workspace) REAL array, dimension (max(3*N,M,P))\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* Further Details\n* ===============\n*\n* The subroutine uses LAPACK subroutine SGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.sggsvp( jobu, jobv, jobq, a, b, tola, tolb, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_tola = argv[5];
+ rblapack_tolb = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ n = 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*);
+ tolb = (real)NUM2DBL(rblapack_tolb);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ tola = (real)NUM2DBL(rblapack_tola);
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+ tau = ALLOC_N(real, (n));
+ work = ALLOC_N(real, (MAX(MAX(3*n,m),p)));
+
+ sggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, tau, work, &info);
+
+ free(iwork);
+ free(tau);
+ free(work);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sggsvp", rblapack_sggsvp, -1);
+}
diff --git a/ext/sgsvj0.c b/ext/sgsvj0.c
new file mode 100644
index 0000000..6884ab3
--- /dev/null
+++ b/ext/sgsvj0.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID sgsvj0_(char* jobv, integer* m, integer* n, 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_sgsvj0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_m;
+ integer m;
+ 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.sgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGSVJ0 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 does not check convergence (stopping criterion). Few tuning\n* parameters (marked by [TP]) are available for the implementer.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* SGSVJ0 is used just to enable SGESVJ to call a simplified version of\n* itself to work on a submatrix of the original matrix.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\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* 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 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 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, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n + THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n + NOTROT, 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, AMIN1, 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.sgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_jobv = argv[0];
+ rblapack_m = argv[1];
+ rblapack_a = argv[2];
+ rblapack_d = argv[3];
+ rblapack_sva = argv[4];
+ rblapack_mv = argv[5];
+ rblapack_v = argv[6];
+ rblapack_eps = argv[7];
+ rblapack_sfmin = argv[8];
+ rblapack_tol = argv[9];
+ rblapack_nsweep = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } 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];
+ 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);
+ n = 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_sva))
+ rb_raise(rb_eArgError, "sva (5th argument) must be NArray");
+ if (NA_RANK(rblapack_sva) != 1)
+ rb_raise(rb_eArgError, "rank of sva (5th 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 1 of a");
+ if (NA_TYPE(rblapack_sva) != NA_SFLOAT)
+ rblapack_sva = na_change_type(rblapack_sva, NA_SFLOAT);
+ sva = NA_PTR_TYPE(rblapack_sva, real*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th 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 1 of a");
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ sfmin = NUM2INT(rblapack_sfmin);
+ nsweep = NUM2INT(rblapack_nsweep);
+ m = NUM2INT(rblapack_m);
+ mv = NUM2INT(rblapack_mv);
+ tol = (real)NUM2DBL(rblapack_tol);
+ 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 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*);
+ lwork = m;
+ eps = NUM2INT(rblapack_eps);
+ {
+ 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));
+
+ sgsvj0_(&jobv, &m, &n, 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_sgsvj0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgsvj0", rblapack_sgsvj0, -1);
+}
diff --git a/ext/sgsvj1.c b/ext/sgsvj1.c
new file mode 100644
index 0000000..d5fea95
--- /dev/null
+++ b/ext/sgsvj1.c
@@ -0,0 +1,186 @@
+#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);
+}
diff --git a/ext/sgtcon.c b/ext/sgtcon.c
new file mode 100644
index 0000000..27351a1
--- /dev/null
+++ b/ext/sgtcon.c
@@ -0,0 +1,124 @@
+#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);
+}
diff --git a/ext/sgtrfs.c b/ext/sgtrfs.c
new file mode 100644
index 0000000..1a6b6df
--- /dev/null
+++ b/ext/sgtrfs.c
@@ -0,0 +1,209 @@
+#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);
+}
diff --git a/ext/sgtsv.c b/ext/sgtsv.c
new file mode 100644
index 0000000..cae7077
--- /dev/null
+++ b/ext/sgtsv.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern VOID sgtsv_(integer* n, integer* nrhs, real* dl, real* d, real* du, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sgtsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_dl;
+ real *dl;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_du;
+ real *du;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ real *dl_out__;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_du_out__;
+ real *du_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, dl, d, du, b = NumRu::Lapack.sgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an n by n tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) REAL array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-2) elements of the\n* second super-diagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) REAL array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N by NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.sgtsv( dl, d, du, b, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_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);
+ 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*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, real*);
+ MEMCPY(dl_out__, dl, real, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_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-1;
+ rblapack_du_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, real*);
+ MEMCPY(du_out__, du, real, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
+}
+
+void
+init_lapack_sgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgtsv", rblapack_sgtsv, -1);
+}
diff --git a/ext/sgtsvx.c b/ext/sgtsvx.c
new file mode 100644
index 0000000..a78f4ec
--- /dev/null
+++ b/ext/sgtsvx.c
@@ -0,0 +1,256 @@
+#include "rb_lapack.h"
+
+extern VOID sgtsvx_(char* fact, 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* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sgtsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ 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_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dlf_out__;
+ real *dlf_out__;
+ VALUE rblapack_df_out__;
+ real *df_out__;
+ VALUE rblapack_duf_out__;
+ real *duf_out__;
+ VALUE rblapack_du2_out__;
+ real *du2_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_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 x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.sgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGTSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B or A**T * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored\n* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n* will not be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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 n 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 or output) REAL array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by SGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) REAL array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) REAL array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) REAL array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by SGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.sgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_dlf = argv[5];
+ rblapack_df = argv[6];
+ rblapack_duf = argv[7];
+ rblapack_du2 = argv[8];
+ rblapack_ipiv = argv[9];
+ rblapack_b = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ 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);
+ 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 (7th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (7th 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 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (10th 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*);
+ ldx = MAX(1,n);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_duf))
+ rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
+ if (NA_RANK(rblapack_duf) != 1)
+ rb_raise(rb_eArgError, "rank of duf (8th 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*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th 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*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_du2) != 1)
+ rb_raise(rb_eArgError, "rank of du2 (9th 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_dlf))
+ rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_dlf) != 1)
+ rb_raise(rb_eArgError, "rank of dlf (6th 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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[1];
+ shape[0] = n-1;
+ rblapack_dlf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, real*);
+ MEMCPY(dlf_out__, dlf, real, NA_TOTAL(rblapack_dlf));
+ rblapack_dlf = rblapack_dlf_out__;
+ dlf = dlf_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, real*);
+ MEMCPY(df_out__, df, real, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_duf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, real*);
+ MEMCPY(duf_out__, duf, real, NA_TOTAL(rblapack_duf));
+ rblapack_duf = rblapack_duf_out__;
+ duf = duf_out__;
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, real*);
+ MEMCPY(du2_out__, du2, real, NA_TOTAL(rblapack_du2));
+ rblapack_du2 = rblapack_du2_out__;
+ du2 = du2_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
+}
+
+void
+init_lapack_sgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgtsvx", rblapack_sgtsvx, -1);
+}
diff --git a/ext/sgttrf.c b/ext/sgttrf.c
new file mode 100644
index 0000000..bf8a6e5
--- /dev/null
+++ b/ext/sgttrf.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID sgttrf_(integer* n, real* dl, real* d, real* du, real* du2, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_sgttrf(int argc, VALUE *argv, VALUE self){
+ 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_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ real *dl_out__;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_du_out__;
+ real *du_out__;
+
+ 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 du2, ipiv, info, dl, d, du = NumRu::Lapack.sgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGTTRF computes an LU factorization of a real tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) REAL array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) REAL array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) REAL array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.sgttrf( dl, d, du, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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*);
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ du2 = NA_PTR_TYPE(rblapack_du2, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, real*);
+ MEMCPY(dl_out__, dl, real, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_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-1;
+ rblapack_du_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, real*);
+ MEMCPY(du_out__, du, real, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+
+ sgttrf_(&n, dl, d, du, du2, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
+}
+
+void
+init_lapack_sgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgttrf", rblapack_sgttrf, -1);
+}
diff --git a/ext/sgttrs.c b/ext/sgttrs.c
new file mode 100644
index 0000000..8509dc3
--- /dev/null
+++ b/ext/sgttrs.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID sgttrs_(char* trans, integer* n, integer* nrhs, real* dl, real* d, real* du, real* du2, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sgttrs(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_du2;
+ real *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.sgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGTTRS solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by SGTTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) multipliers that define the matrix L from the\n* LU factorization of A.\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 super-diagonal of U.\n*\n* DU2 (input) REAL array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) REAL array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SGTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.sgttrs( trans, dl, d, du, du2, ipiv, b, [: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_trans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } 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_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*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_sgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgttrs", rblapack_sgttrs, -1);
+}
diff --git a/ext/sgtts2.c b/ext/sgtts2.c
new file mode 100644
index 0000000..b22befd
--- /dev/null
+++ b/ext/sgtts2.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID sgtts2_(integer* itrans, integer* n, integer* nrhs, real* dl, real* d, real* du, real* du2, integer* ipiv, real* b, integer* ldb);
+
+
+static VALUE
+rblapack_sgtts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itrans;
+ integer itrans;
+ 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_b;
+ real *b;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.sgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* SGTTS2 solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by SGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A'* X = B (Transpose)\n* = 2: A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) multipliers that define the matrix L from the\n* LU factorization of A.\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 super-diagonal of U.\n*\n* DU2 (input) REAL array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) REAL array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IP, J\n REAL TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.sgtts2( itrans, dl, d, du, du2, ipiv, b, [: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_itrans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itrans = NUM2INT(rblapack_itrans);
+ 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*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_sgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sgtts2", rblapack_sgtts2, -1);
+}
diff --git a/ext/shgeqz.c b/ext/shgeqz.c
new file mode 100644
index 0000000..c080d02
--- /dev/null
+++ b/ext/shgeqz.c
@@ -0,0 +1,213 @@
+#include "rb_lapack.h"
+
+extern VOID shgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* t, integer* ldt, real* alphar, real* alphai, real* beta, real* q, integer* ldq, real* z, integer* ldz, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_shgeqz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_t_out__;
+ real *t_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldt;
+ integer ldq;
+ integer ldz;
+
+ 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 alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.shgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the double-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a real matrix pair (A,B):\n*\n* A = Q1*H*Z1**T, B = Q1*T*Z1**T,\n*\n* as computed by SGGHRD.\n*\n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**T, T = Q*P*Z**T,\n* \n* where Q and Z are orthogonal matrices, P is an upper triangular\n* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n* diagonal blocks.\n*\n* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n* eigenvalues.\n*\n* Additionally, the 2-by-2 upper triangular diagonal blocks of P\n* corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n* P(j,j) > 0, and P(j+1,j+1) > 0.\n*\n* Optionally, the orthogonal matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced\n* the matrix pair (A,B) to generalized upper Hessenberg form, then the\n* output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n* generalized Schur factorization of (A,B):\n*\n* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n* complex and beta real.\n* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n* generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* Real eigenvalues can be read directly from the generalized Schur\n* form: \n* alpha = S(i,i), beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Compute eigenvalues and the Schur form. \n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) REAL array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper quasi-triangular\n* matrix S from the generalized Schur factorization;\n* 2-by-2 diagonal blocks (corresponding to complex conjugate\n* pairs of eigenvalues) are returned in standard form, with\n* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n* If JOB = 'E', the diagonal blocks of H match those of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) REAL array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization;\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n* are reduced to positive diagonal form, i.e., if H(j+1,j) is\n* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n* T(j+1,j+1) > 0.\n* If JOB = 'E', the diagonal blocks of T match those of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) REAL array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) REAL array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n* of left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of\n* right Schur vectors of (H,T), and if COMPZ = 'V', the\n* orthogonal matrix of right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\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 >= max(1,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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* Iteration counters:\n*\n* JITER -- counts iterations.\n* IITER -- counts iterations run since ILAST was last\n* changed. This is therefore reset only when a 1-by-1 or\n* 2-by-2 block deflates off the bottom.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.shgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_compz = argv[2];
+ rblapack_ilo = argv[3];
+ rblapack_ihi = argv[4];
+ rblapack_h = argv[5];
+ rblapack_t = argv[6];
+ rblapack_q = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ compz = StringValueCStr(rblapack_compz)[0];
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ n = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (8th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
+ MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ shgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alphar, alphai, beta, q, &ldq, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_shgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "shgeqz", rblapack_shgeqz, -1);
+}
diff --git a/ext/shsein.c b/ext/shsein.c
new file mode 100644
index 0000000..4a163a7
--- /dev/null
+++ b/ext/shsein.c
@@ -0,0 +1,205 @@
+#include "rb_lapack.h"
+
+extern VOID shsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, real* h, integer* ldh, real* wr, real* wi, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* mm, integer* m, real* work, integer* ifaill, integer* ifailr, integer* info);
+
+
+static VALUE
+rblapack_shsein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_eigsrc;
+ char eigsrc;
+ VALUE rblapack_initv;
+ char initv;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_ifaill;
+ integer *ifaill;
+ VALUE rblapack_ifailr;
+ integer *ifailr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_select_out__;
+ logical *select_out__;
+ VALUE rblapack_wr_out__;
+ real *wr_out__;
+ VALUE rblapack_vl_out__;
+ real *vl_out__;
+ VALUE rblapack_vr_out__;
+ real *vr_out__;
+ real *work;
+
+ integer n;
+ integer ldh;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.shsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* SHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a real upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in (WR,WI):\n* = 'Q': the eigenvalues were found using SHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows SHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, SHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* real eigenvector corresponding to a real eigenvalue WR(j),\n* SELECT(j) must be set to .TRUE.. To select the complex\n* eigenvector corresponding to a complex eigenvalue\n* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n* .FALSE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) REAL array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input/output) REAL array, dimension (N)\n* WI (input) REAL array, dimension (N)\n* On entry, the real and imaginary parts of the eigenvalues of\n* H; a complex conjugate pair of eigenvalues must be stored in\n* consecutive elements of WR and WI.\n* On exit, WR may have been altered since close eigenvalues\n* are perturbed slightly in searching for independent\n* eigenvectors.\n*\n* VL (input/output) REAL array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) REAL array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors; each selected real eigenvector\n* occupies one column and each selected complex eigenvector\n* occupies two columns.\n*\n* WORK (workspace) REAL array, dimension ((N+2)*N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VL hold a complex eigenvector, then IFAILL(i) and\n* IFAILL(i+1) are set to the same value.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VR hold a complex eigenvector, then IFAILR(i) and\n* IFAILR(i+1) are set to the same value.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.shsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_side = argv[0];
+ rblapack_eigsrc = argv[1];
+ rblapack_initv = argv[2];
+ rblapack_select = argv[3];
+ rblapack_h = argv[4];
+ rblapack_wr = argv[5];
+ rblapack_wi = argv[6];
+ rblapack_vl = argv[7];
+ rblapack_vr = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ initv = StringValueCStr(rblapack_initv)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ if (!NA_IsNArray(rblapack_wi))
+ rb_raise(rb_eArgError, "wi (7th argument) must be NArray");
+ if (NA_RANK(rblapack_wi) != 1)
+ rb_raise(rb_eArgError, "rank of wi (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wi) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wi must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_wi) != NA_SFLOAT)
+ rblapack_wi = na_change_type(rblapack_wi, NA_SFLOAT);
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (9th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (9th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ mm = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ eigsrc = StringValueCStr(rblapack_eigsrc)[0];
+ if (!NA_IsNArray(rblapack_wr))
+ rb_raise(rb_eArgError, "wr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_wr) != 1)
+ rb_raise(rb_eArgError, "rank of wr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wr must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_wr) != NA_SFLOAT)
+ rblapack_wr = na_change_type(rblapack_wr, NA_SFLOAT);
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (8th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
+ MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
+ rblapack_select = rblapack_select_out__;
+ select = select_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr_out__ = NA_PTR_TYPE(rblapack_wr_out__, real*);
+ MEMCPY(wr_out__, wr, real, NA_TOTAL(rblapack_wr));
+ rblapack_wr = rblapack_wr_out__;
+ wr = wr_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
+ MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
+ MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(real, ((n+2)*n));
+
+ shsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, wr, wi, vl, &ldvl, vr, &ldvr, &mm, &m, work, ifaill, ifailr, &info);
+
+ free(work);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_select, rblapack_wr, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_shsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "shsein", rblapack_shsein, -1);
+}
diff --git a/ext/shseqr.c b/ext/shseqr.c
new file mode 100644
index 0000000..c5f8081
--- /dev/null
+++ b/ext/shseqr.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID shseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, real* z, integer* ldz, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_shseqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer ldh;
+ 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 wr, wi, work, info, h, z = NumRu::Lapack.shseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an orthogonal matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to SGEBAL, and then passed to SGEHRD\n* when the matrix output by SGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', then H contains the\n* upper quasi-triangular matrix T from the Schur decomposition\n* (the Schur form); 2-by-2 diagonal blocks (corresponding to\n* complex conjugate pairs of eigenvalues) are returned in\n* standard form, with H(i,i) = H(i+1,i+1) and\n* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n* contents of H are unspecified on exit. (The output value of\n* H when INFO.GT.0 is given under the description of INFO\n* below.)\n*\n* Unlike earlier versions of SHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues. If two eigenvalues are computed as a complex\n* conjugate pair, they are stored in consecutive elements of\n* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n* the same order as on the diagonal of the Schur form returned\n* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the orthogonal matrix generated by SORGHR\n* after the call to SGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then SHSEQR does a workspace query.\n* In this case, SHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, SHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The SLAHQR vs SLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* SLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.shseqr( job, compz, ilo, ihi, h, z, ldz, [: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_job = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_z = argv[5];
+ rblapack_ldz = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ ldz = NUM2INT(rblapack_ldz);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
+ if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = lsame_(&compz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&compz,"N") ? 0 : n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ shseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_shseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "shseqr", rblapack_shseqr, -1);
+}
diff --git a/ext/sisnan.c b/ext/sisnan.c
new file mode 100644
index 0000000..7ce27a5
--- /dev/null
+++ b/ext/sisnan.c
@@ -0,0 +1,51 @@
+#include "rb_lapack.h"
+
+extern logical sisnan_(real* sin);
+
+
+static VALUE
+rblapack_sisnan(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_sin;
+ real sin;
+ VALUE rblapack___out__;
+ logical __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 __out__ = NumRu::Lapack.sisnan( sin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n LOGICAL FUNCTION SISNAN( SIN )\n\n* Purpose\n* =======\n*\n* SISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n* otherwise. To be replaced by the Fortran 2003 intrinsic in the\n* future.\n*\n\n* Arguments\n* =========\n*\n* SIN (input) REAL\n* Input to test for NaN.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL SLAISNAN\n EXTERNAL SLAISNAN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sisnan( sin, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_sin = argv[0];
+ if (argc == 1) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ sin = (real)NUM2DBL(rblapack_sin);
+
+ __out__ = sisnan_(&sin);
+
+ rblapack___out__ = __out__ ? Qtrue : Qfalse;
+ return rblapack___out__;
+}
+
+void
+init_lapack_sisnan(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sisnan", rblapack_sisnan, -1);
+}
diff --git a/ext/sla_gbamv.c b/ext/sla_gbamv.c
new file mode 100644
index 0000000..e472b26
--- /dev/null
+++ b/ext/sla_gbamv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID sla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, real* alpha, real* ab, integer* ldab, real* x, integer* incx, real* beta, real* y, integer* incy);
+
+
+static VALUE
+rblapack_sla_gbamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+
+ integer ldab;
+ integer lda;
+
+ 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 y = NumRu::Lapack.sla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - REAL array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.sla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [: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_trans = argv[0];
+ rblapack_m = argv[1];
+ rblapack_n = argv[2];
+ rblapack_kl = argv[3];
+ rblapack_ku = argv[4];
+ rblapack_alpha = argv[5];
+ rblapack_ab = argv[6];
+ rblapack_x = argv[7];
+ rblapack_incx = argv[8];
+ rblapack_beta = argv[9];
+ rblapack_y = argv[10];
+ rblapack_incy = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+ n = NUM2INT(rblapack_n);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 1)
+ rb_raise(rb_eArgError, "rank of ab (7th argument) must be %d", 1);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ beta = (real)NUM2DBL(rblapack_beta);
+ lda = MAX(1,m);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (11th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ sla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_sla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_gbamv", rblapack_sla_gbamv, -1);
+}
diff --git a/ext/sla_gbrcond.c b/ext/sla_gbrcond.c
new file mode 100644
index 0000000..c9cf880
--- /dev/null
+++ b/ext/sla_gbrcond.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern real sla_gbrcond_(char* trans, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, integer* cmode, real* c, integer* info, real* work, integer* iwork);
+
+
+static VALUE
+rblapack_sla_gbrcond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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, __out__ = NumRu::Lapack.sla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (5*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J, KD, KE\n REAL AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_cmode = argv[6];
+ rblapack_c = argv[7];
+ rblapack_work = argv[8];
+ rblapack_iwork = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ cmode = NUM2INT(rblapack_cmode);
+ if (!NA_IsNArray(rblapack_iwork))
+ rb_raise(rb_eArgError, "iwork (10th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
+ 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_work))
+ rb_raise(rb_eArgError, "work (9th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (5*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 5*n);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+
+ __out__ = sla_gbrcond_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_sla_gbrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_gbrcond", rblapack_sla_gbrcond, -1);
+}
diff --git a/ext/sla_gbrfsx_extended.c b/ext/sla_gbrfsx_extended.c
new file mode 100644
index 0000000..26fdccc
--- /dev/null
+++ b/ext/sla_gbrfsx_extended.c
@@ -0,0 +1,291 @@
+#include "rb_lapack.h"
+
+extern VOID sla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_sla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ real *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ real *dy;
+ VALUE rblapack_y_tail;
+ real *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_norms;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* SLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGBTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 22 && argc != 22)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 22)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_colequ = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_y = argv[10];
+ rblapack_err_bnds_norm = argv[11];
+ rblapack_err_bnds_comp = argv[12];
+ rblapack_res = argv[13];
+ rblapack_ayb = argv[14];
+ rblapack_dy = argv[15];
+ rblapack_y_tail = argv[16];
+ rblapack_rcond = argv[17];
+ rblapack_ithresh = argv[18];
+ rblapack_rthresh = argv[19];
+ rblapack_dz_ub = argv[20];
+ rblapack_ignore_cwise = argv[21];
+ if (argc == 22) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ ldab = n;
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ colequ = (rblapack_colequ == Qtrue);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
+ n_norms = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ trans_type = NUM2INT(rblapack_trans_type);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (11th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ if (NA_SHAPE1(rblapack_y) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ n = ldab;
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be ldab");
+ 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_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (13th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (15th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be ldab");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (17th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be ldab");
+ if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
+ ldafb = n;
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_afb) != ldafb)
+ rb_raise(rb_eRuntimeError, "shape 0 of afb must be n");
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be ldab");
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (14th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be ldab");
+ if (NA_TYPE(rblapack_res) != NA_SFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, real*);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be ldab");
+ 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_dy))
+ rb_raise(rb_eArgError, "dy (16th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be ldab");
+ if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, real*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ sla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_sla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_gbrfsx_extended", rblapack_sla_gbrfsx_extended, -1);
+}
diff --git a/ext/sla_gbrpvgrw.c b/ext/sla_gbrpvgrw.c
new file mode 100644
index 0000000..c9dc25a
--- /dev/null
+++ b/ext/sla_gbrpvgrw.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern real sla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, real* ab, integer* ldab, real* afb, integer* ldafb);
+
+
+static VALUE
+rblapack_sla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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 __out__ = NumRu::Lapack.sla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* SLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n REAL AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_gbrpvgrw( kl, ku, ncols, ab, afb, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ncols = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+
+ __out__ = sla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_sla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_gbrpvgrw", rblapack_sla_gbrpvgrw, -1);
+}
diff --git a/ext/sla_geamv.c b/ext/sla_geamv.c
new file mode 100644
index 0000000..73486f3
--- /dev/null
+++ b/ext/sla_geamv.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID sla_geamv_(char* trans, integer* m, integer* n, real* alpha, real* a, integer* lda, real* x, integer* incx, real* beta, real* y, integer* incy);
+
+
+static VALUE
+rblapack_sla_geamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ real *y_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 y = NumRu::Lapack.sla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - REAL array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y - REAL\n* Array of DIMENSION at least\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.sla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_trans = argv[0];
+ rblapack_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_a = argv[3];
+ rblapack_x = argv[4];
+ rblapack_incx = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_y = argv[7];
+ rblapack_incy = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ beta = (real)NUM2DBL(rblapack_beta);
+ lda = MAX(1, 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);
+ if (NA_SHAPE0(rblapack_a) != lda)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be MAX(1, m)");
+ n = 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_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy));
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy);
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ sla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_sla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_geamv", rblapack_sla_geamv, -1);
+}
diff --git a/ext/sla_gercond.c b/ext/sla_gercond.c
new file mode 100644
index 0000000..939dbfe
--- /dev/null
+++ b/ext/sla_gercond.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern real sla_gercond_(char* trans, integer* n, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, integer* cmode, real* c, integer* info, real* work, integer* iwork);
+
+
+static VALUE
+rblapack_sla_gercond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.sla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.2\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_cmode = argv[4];
+ rblapack_c = argv[5];
+ rblapack_work = argv[6];
+ rblapack_iwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ cmode = NUM2INT(rblapack_cmode);
+ if (!NA_IsNArray(rblapack_iwork))
+ rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ 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 1 of af");
+ 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 (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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (3*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+
+ __out__ = sla_gercond_(&trans, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_sla_gercond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_gercond", rblapack_sla_gercond, -1);
+}
diff --git a/ext/sla_gerfsx_extended.c b/ext/sla_gerfsx_extended.c
new file mode 100644
index 0000000..7d3bcdb
--- /dev/null
+++ b/ext/sla_gerfsx_extended.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID sla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_sla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ real *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ real *dy;
+ VALUE rblapack_y_tail;
+ real *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* SLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 21 && argc != 21)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_n_norms = argv[9];
+ rblapack_err_bnds_norm = argv[10];
+ rblapack_err_bnds_comp = argv[11];
+ rblapack_res = argv[12];
+ rblapack_ayb = argv[13];
+ rblapack_dy = argv[14];
+ rblapack_y_tail = argv[15];
+ rblapack_rcond = argv[16];
+ rblapack_ithresh = argv[17];
+ rblapack_rthresh = argv[18];
+ rblapack_dz_ub = argv[19];
+ rblapack_ignore_cwise = argv[20];
+ if (argc == 21) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (13th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_SFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, real*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, real*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ trans_type = NUM2INT(rblapack_trans_type);
+ colequ = (rblapack_colequ == Qtrue);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ 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_y_tail))
+ rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ sla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_sla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_gerfsx_extended", rblapack_sla_gerfsx_extended, -1);
+}
diff --git a/ext/sla_lin_berr.c b/ext/sla_lin_berr.c
new file mode 100644
index 0000000..df8419c
--- /dev/null
+++ b/ext/sla_lin_berr.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID sla_lin_berr_(integer* n, integer* nz, integer* nrhs, real* res, real* ayb, real* berr);
+
+
+static VALUE
+rblapack_sla_lin_berr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nz;
+ integer nz;
+ VALUE rblapack_res;
+ real *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_berr;
+ real *berr;
+
+ integer n;
+ integer nrhs;
+
+ 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 berr = NumRu::Lapack.sla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* SLA_LIN_BERR computes componentwise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z.\n*\n\n* Arguments\n* ==========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) REAL array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) REAL array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see sla_gerfsx_extended.f).\n* \n* BERR (output) REAL array, dimension (NRHS)\n* The componentwise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL TMP\n INTEGER I, J\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. External Functions ..\n EXTERNAL SLAMCH\n REAL SLAMCH\n REAL SAFE1\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr = NumRu::Lapack.sla_lin_berr( nz, res, ayb, [: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_nz = argv[0];
+ rblapack_res = argv[1];
+ rblapack_ayb = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nz = NUM2INT(rblapack_nz);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 2)
+ rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
+ n = NA_SHAPE0(rblapack_ayb);
+ nrhs = NA_SHAPE1(rblapack_ayb);
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (2th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 2)
+ rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
+ if (NA_SHAPE1(rblapack_res) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
+ if (NA_TYPE(rblapack_res) != NA_SFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, real*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, real*);
+
+ sla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
+
+ return rblapack_berr;
+}
+
+void
+init_lapack_sla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_lin_berr", rblapack_sla_lin_berr, -1);
+}
diff --git a/ext/sla_porcond.c b/ext/sla_porcond.c
new file mode 100644
index 0000000..ff855a6
--- /dev/null
+++ b/ext/sla_porcond.c
@@ -0,0 +1,122 @@
+#include "rb_lapack.h"
+
+extern real sla_porcond_(char* uplo, integer* n, real* a, integer* lda, real* af, integer* ldaf, integer* cmode, real* c, integer* info, real* work, integer* iwork);
+
+
+static VALUE
+rblapack_sla_porcond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.sla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, TMP\n LOGICAL UP\n* ..\n* .. Array Arguments ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ISAMAX\n EXTERNAL LSAME, ISAMAX\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_cmode = argv[3];
+ rblapack_c = argv[4];
+ rblapack_work = argv[5];
+ rblapack_iwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ 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_iwork))
+ rb_raise(rb_eArgError, "iwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (3*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ cmode = NUM2INT(rblapack_cmode);
+
+ __out__ = sla_porcond_(&uplo, &n, a, &lda, af, &ldaf, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_sla_porcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_porcond", rblapack_sla_porcond, -1);
+}
diff --git a/ext/sla_porfsx_extended.c b/ext/sla_porfsx_extended.c
new file mode 100644
index 0000000..45278d7
--- /dev/null
+++ b/ext/sla_porfsx_extended.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID sla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_sla_porfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ real *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ real *dy;
+ VALUE rblapack_y_tail;
+ real *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* SLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 20 && argc != 20)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_colequ = argv[4];
+ rblapack_c = argv[5];
+ rblapack_b = argv[6];
+ rblapack_y = argv[7];
+ rblapack_n_norms = argv[8];
+ rblapack_err_bnds_norm = argv[9];
+ rblapack_err_bnds_comp = argv[10];
+ rblapack_res = argv[11];
+ rblapack_ayb = argv[12];
+ rblapack_dy = argv[13];
+ rblapack_y_tail = argv[14];
+ rblapack_rcond = argv[15];
+ rblapack_ithresh = argv[16];
+ rblapack_rthresh = argv[17];
+ rblapack_dz_ub = argv[18];
+ rblapack_ignore_cwise = argv[19];
+ if (argc == 20) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = 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*);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, real*);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (12th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_SFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, real*);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ if (NA_SHAPE1(rblapack_y) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ sla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_sla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_porfsx_extended", rblapack_sla_porfsx_extended, -1);
+}
diff --git a/ext/sla_porpvgrw.c b/ext/sla_porpvgrw.c
new file mode 100644
index 0000000..89f9786
--- /dev/null
+++ b/ext/sla_porpvgrw.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern real sla_porpvgrw_(char* uplo, integer* ncols, real* a, integer* lda, real* af, integer* ldaf, real* work);
+
+
+static VALUE
+rblapack_sla_porpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.sla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* SLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) REAL array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, SLASET\n LOGICAL LSAME\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_porpvgrw( uplo, ncols, a, af, work, [: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_ncols = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_work = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (5th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+
+ __out__ = sla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_sla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_porpvgrw", rblapack_sla_porpvgrw, -1);
+}
diff --git a/ext/sla_rpvgrw.c b/ext/sla_rpvgrw.c
new file mode 100644
index 0000000..b04e742
--- /dev/null
+++ b/ext/sla_rpvgrw.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern real sla_rpvgrw_(integer* n, integer* ncols, real* a, integer* lda, real* af, integer* ldaf);
+
+
+static VALUE
+rblapack_sla_rpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.sla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n*\n* SLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_rpvgrw( ncols, a, af, [: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_ncols = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+
+ __out__ = sla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_sla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_rpvgrw", rblapack_sla_rpvgrw, -1);
+}
diff --git a/ext/sla_syamv.c b/ext/sla_syamv.c
new file mode 100644
index 0000000..efd7c21
--- /dev/null
+++ b/ext/sla_syamv.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID sla_syamv_(integer* uplo, integer* n, real* alpha, real* a, integer* lda, real* x, integer* incx, real* beta, real* y, integer* incy);
+
+
+static VALUE
+rblapack_sla_syamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ integer uplo;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ real *y_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 y = NumRu::Lapack.sla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - REAL array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.sla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = NUM2INT(rblapack_uplo);
+ 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);
+ if (lda != (MAX(1, n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
+ n = 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*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ beta = (real)NUM2DBL(rblapack_beta);
+ lda = MAX(1, n);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ 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_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ sla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_sla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_syamv", rblapack_sla_syamv, -1);
+}
diff --git a/ext/sla_syrcond.c b/ext/sla_syrcond.c
new file mode 100644
index 0000000..a56fe27
--- /dev/null
+++ b/ext/sla_syrcond.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern real sla_syrcond_(char* uplo, integer* n, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, integer* cmode, real* c, integer* info, real* work, integer* iwork);
+
+
+static VALUE
+rblapack_sla_syrcond(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_cmode;
+ integer cmode;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.sla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER NORMIN\n INTEGER KASE, I, J\n REAL AINVNM, SMLNUM, TMP\n LOGICAL UP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ISAMAX\n REAL SLAMCH\n EXTERNAL LSAME, ISAMAX, SLAMCH\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA, SSYTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [: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_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_cmode = argv[4];
+ rblapack_c = argv[5];
+ rblapack_work = argv[6];
+ rblapack_iwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ cmode = NUM2INT(rblapack_cmode);
+ if (!NA_IsNArray(rblapack_iwork))
+ rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_iwork) != 1)
+ rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_iwork) != NA_LINT)
+ rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ 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 1 of af");
+ 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 (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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (3*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+
+ __out__ = sla_syrcond_(&uplo, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_sla_syrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_syrcond", rblapack_sla_syrcond, -1);
+}
diff --git a/ext/sla_syrfsx_extended.c b/ext/sla_syrfsx_extended.c
new file mode 100644
index 0000000..4cffe87
--- /dev/null
+++ b/ext/sla_syrfsx_extended.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID sla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_sla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_res;
+ real *res;
+ VALUE rblapack_ayb;
+ real *ayb;
+ VALUE rblapack_dy;
+ real *dy;
+ VALUE rblapack_y_tail;
+ real *y_tail;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ real rthresh;
+ VALUE rblapack_dz_ub;
+ real dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ real *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ real *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ real *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* SLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 21 && argc != 21)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_n_norms = argv[9];
+ rblapack_err_bnds_norm = argv[10];
+ rblapack_err_bnds_comp = argv[11];
+ rblapack_res = argv[12];
+ rblapack_ayb = argv[13];
+ rblapack_dy = argv[14];
+ rblapack_y_tail = argv[15];
+ rblapack_rcond = argv[16];
+ rblapack_ithresh = argv[17];
+ rblapack_rthresh = argv[18];
+ rblapack_dz_ub = argv[19];
+ rblapack_ignore_cwise = argv[20];
+ if (argc == 21) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ 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_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (13th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_SFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, real*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
+ rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
+ dy = NA_PTR_TYPE(rblapack_dy, real*);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ rthresh = (real)NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ colequ = (rblapack_colequ == Qtrue);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, real*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ dz_ub = (real)NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ 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_y_tail))
+ rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ sla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_sla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_syrfsx_extended", rblapack_sla_syrfsx_extended, -1);
+}
diff --git a/ext/sla_syrpvgrw.c b/ext/sla_syrpvgrw.c
new file mode 100644
index 0000000..5ac44bf
--- /dev/null
+++ b/ext/sla_syrpvgrw.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern real sla_syrpvgrw_(char* uplo, integer* n, integer* info, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* work);
+
+
+static VALUE
+rblapack_sla_syrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack___out__;
+ real __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.sla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* SLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from SSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* WORK (input) REAL array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, SLASET\n LOGICAL LSAME\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_syrpvgrw( uplo, info, a, af, ipiv, work, [: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_info = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_work = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ info = NUM2INT(rblapack_info);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+
+ __out__ = sla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_sla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_syrpvgrw", rblapack_sla_syrpvgrw, -1);
+}
diff --git a/ext/sla_wwaddw.c b/ext/sla_wwaddw.c
new file mode 100644
index 0000000..33b52a6
--- /dev/null
+++ b/ext/sla_wwaddw.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID sla_wwaddw_(integer* n, real* x, real* y, real* w);
+
+
+static VALUE
+rblapack_sla_wwaddw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+
+ 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 x, y = NumRu::Lapack.sla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* SLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) REAL array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) REAL array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) REAL array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL S\n INTEGER I\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.sla_wwaddw( x, y, w, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_w = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(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_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (2th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ sla_wwaddw_(&n, x, y, w);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_sla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sla_wwaddw", rblapack_sla_wwaddw, -1);
+}
diff --git a/ext/slabad.c b/ext/slabad.c
new file mode 100644
index 0000000..4130d95
--- /dev/null
+++ b/ext/slabad.c
@@ -0,0 +1,54 @@
+#include "rb_lapack.h"
+
+extern VOID slabad_(real* small, real* large);
+
+
+static VALUE
+rblapack_slabad(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_small;
+ real small;
+ VALUE rblapack_large;
+ real large;
+
+
+ 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 small, large = NumRu::Lapack.slabad( small, large, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLABAD( SMALL, LARGE )\n\n* Purpose\n* =======\n*\n* SLABAD takes as input the values computed by SLAMCH for underflow and\n* overflow, and returns the square root of each of these values if the\n* log of LARGE is sufficiently large. This subroutine is intended to\n* identify machines with a large exponent range, such as the Crays, and\n* redefine the underflow and overflow limits to be the square roots of\n* the values computed by SLAMCH. This subroutine is needed because\n* SLAMCH does not compensate for poor arithmetic in the upper half of\n* the exponent range, as is found on a Cray.\n*\n\n* Arguments\n* =========\n*\n* SMALL (input/output) REAL\n* On entry, the underflow threshold as computed by SLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of SMALL, otherwise unchanged.\n*\n* LARGE (input/output) REAL\n* On entry, the overflow threshold as computed by SLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of LARGE, otherwise unchanged.\n*\n\n* =====================================================================\n*\n* .. Intrinsic Functions ..\n INTRINSIC LOG10, SQRT\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n small, large = NumRu::Lapack.slabad( small, large, [: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_small = argv[0];
+ rblapack_large = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ small = (real)NUM2DBL(rblapack_small);
+ large = (real)NUM2DBL(rblapack_large);
+
+ slabad_(&small, &large);
+
+ rblapack_small = rb_float_new((double)small);
+ rblapack_large = rb_float_new((double)large);
+ return rb_ary_new3(2, rblapack_small, rblapack_large);
+}
+
+void
+init_lapack_slabad(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slabad", rblapack_slabad, -1);
+}
diff --git a/ext/slabrd.c b/ext/slabrd.c
new file mode 100644
index 0000000..7c81f68
--- /dev/null
+++ b/ext/slabrd.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID slabrd_(integer* m, integer* n, integer* nb, real* a, integer* lda, real* d, real* e, real* tauq, real* taup, real* x, integer* ldx, real* y, integer* ldy);
+
+
+static VALUE
+rblapack_slabrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tauq;
+ real *tauq;
+ VALUE rblapack_taup;
+ real *taup;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldx;
+ integer ldy;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.slabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* SLABRD reduces the first NB rows and columns of a real general\n* m by n matrix A to upper or lower bidiagonal form by an orthogonal\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by SGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the orthogonal matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) REAL array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) REAL array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* X (output) REAL array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= M.\n*\n* Y (output) REAL array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.slabrd( m, nb, a, [: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_m = argv[0];
+ rblapack_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = 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*);
+ ldy = n;
+ nb = NUM2INT(rblapack_nb);
+ ldx = m;
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, real*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = MAX(1,nb);
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, 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__;
+
+ slabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
+
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_slabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slabrd", rblapack_slabrd, -1);
+}
diff --git a/ext/slacn2.c b/ext/slacn2.c
new file mode 100644
index 0000000..b6904bd
--- /dev/null
+++ b/ext/slacn2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID slacn2_(integer* n, real* v, real* x, integer* isgn, real* est, integer* kase, integer* isave);
+
+
+static VALUE
+rblapack_slacn2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_est;
+ real est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_isave;
+ integer *isave;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_isave_out__;
+ integer *isave_out__;
+ real *v;
+ integer *isgn;
+
+ 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 x, est, kase, isave = NumRu::Lapack.slacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* SLACN2 estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) REAL array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) REAL array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and SLACN2 must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to SLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to SLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from SLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to SLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* This is a thread safe version of SLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* SLACON SLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.slacn2( x, est, kase, isave, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ rblapack_isave = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(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*);
+ kase = NUM2INT(rblapack_kase);
+ est = (real)NUM2DBL(rblapack_est);
+ if (!NA_IsNArray(rblapack_isave))
+ rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
+ if (NA_RANK(rblapack_isave) != 1)
+ rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isave) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
+ if (NA_TYPE(rblapack_isave) != NA_LINT)
+ rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
+ isave = NA_PTR_TYPE(rblapack_isave, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = 3;
+ rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
+ MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
+ rblapack_isave = rblapack_isave_out__;
+ isave = isave_out__;
+ v = ALLOC_N(real, (n));
+ isgn = ALLOC_N(integer, (n));
+
+ slacn2_(&n, v, x, isgn, &est, &kase, isave);
+
+ free(v);
+ free(isgn);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
+}
+
+void
+init_lapack_slacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slacn2", rblapack_slacn2, -1);
+}
diff --git a/ext/slacon.c b/ext/slacon.c
new file mode 100644
index 0000000..2e9b8fd
--- /dev/null
+++ b/ext/slacon.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID slacon_(integer* n, real* v, real* x, integer* isgn, real* est, integer* kase);
+
+
+static VALUE
+rblapack_slacon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_est;
+ real est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ real *v;
+ integer *isgn;
+
+ 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 x, est, kase = NumRu::Lapack.slacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE )\n\n* Purpose\n* =======\n*\n* SLACON estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) REAL array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) REAL array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and SLACON must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to SLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to SLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from SLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.slacon( x, est, kase, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(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*);
+ kase = NUM2INT(rblapack_kase);
+ est = (real)NUM2DBL(rblapack_est);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ v = ALLOC_N(real, (n));
+ isgn = ALLOC_N(integer, (n));
+
+ slacon_(&n, v, x, isgn, &est, &kase);
+
+ free(v);
+ free(isgn);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
+}
+
+void
+init_lapack_slacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slacon", rblapack_slacon, -1);
+}
diff --git a/ext/slacpy.c b/ext/slacpy.c
new file mode 100644
index 0000000..6ff8dd5
--- /dev/null
+++ b/ext/slacpy.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID slacpy_(char* uplo, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb);
+
+
+static VALUE
+rblapack_slacpy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.slacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* SLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper triangle\n* or trapezoid is accessed; if UPLO = 'L', only the lower\n* triangle or trapezoid is accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) REAL array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.slacpy( uplo, m, a, [: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_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ m = NUM2INT(rblapack_m);
+ ldb = MAX(1,m);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b = NA_PTR_TYPE(rblapack_b, real*);
+
+ slacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_slacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slacpy", rblapack_slacpy, -1);
+}
diff --git a/ext/sladiv.c b/ext/sladiv.c
new file mode 100644
index 0000000..59fb62a
--- /dev/null
+++ b/ext/sladiv.c
@@ -0,0 +1,66 @@
+#include "rb_lapack.h"
+
+extern VOID sladiv_(real* a, real* b, real* c, real* d, real* p, real* q);
+
+
+static VALUE
+rblapack_sladiv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real a;
+ VALUE rblapack_b;
+ real b;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_d;
+ real d;
+ VALUE rblapack_p;
+ real p;
+ VALUE rblapack_q;
+ real q;
+
+
+ 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 p, q = NumRu::Lapack.sladiv( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLADIV( A, B, C, D, P, Q )\n\n* Purpose\n* =======\n*\n* SLADIV performs complex division in real arithmetic\n*\n* a + i*b\n* p + i*q = ---------\n* c + i*d\n*\n* The algorithm is due to Robert L. Smith and can be found\n* in D. Knuth, The art of Computer Programming, Vol.2, p.195\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL\n* B (input) REAL\n* C (input) REAL\n* D (input) REAL\n* The scalars a, b, c, and d in the above expression.\n*\n* P (output) REAL\n* Q (output) REAL\n* The scalars p and q in the above expression.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL E, F\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n p, q = NumRu::Lapack.sladiv( a, b, c, d, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = (real)NUM2DBL(rblapack_a);
+ c = (real)NUM2DBL(rblapack_c);
+ b = (real)NUM2DBL(rblapack_b);
+ d = (real)NUM2DBL(rblapack_d);
+
+ sladiv_(&a, &b, &c, &d, &p, &q);
+
+ rblapack_p = rb_float_new((double)p);
+ rblapack_q = rb_float_new((double)q);
+ return rb_ary_new3(2, rblapack_p, rblapack_q);
+}
+
+void
+init_lapack_sladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sladiv", rblapack_sladiv, -1);
+}
diff --git a/ext/slae2.c b/ext/slae2.c
new file mode 100644
index 0000000..f2e5430
--- /dev/null
+++ b/ext/slae2.c
@@ -0,0 +1,62 @@
+#include "rb_lapack.h"
+
+extern VOID slae2_(real* a, real* b, real* c, real* rt1, real* rt2);
+
+
+static VALUE
+rblapack_slae2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real a;
+ VALUE rblapack_b;
+ real b;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_rt1;
+ real rt1;
+ VALUE rblapack_rt2;
+ real rt2;
+
+
+ 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 rt1, rt2 = NumRu::Lapack.slae2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAE2( A, B, C, RT1, RT2 )\n\n* Purpose\n* =======\n*\n* SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, and RT2\n* is the eigenvalue of smaller absolute value.\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) REAL\n* The (1,2) and (2,1) elements of the 2-by-2 matrix.\n*\n* C (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) REAL\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) REAL\n* The eigenvalue of smaller absolute value.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2 = NumRu::Lapack.slae2( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = (real)NUM2DBL(rblapack_a);
+ c = (real)NUM2DBL(rblapack_c);
+ b = (real)NUM2DBL(rblapack_b);
+
+ slae2_(&a, &b, &c, &rt1, &rt2);
+
+ rblapack_rt1 = rb_float_new((double)rt1);
+ rblapack_rt2 = rb_float_new((double)rt2);
+ return rb_ary_new3(2, rblapack_rt1, rblapack_rt2);
+}
+
+void
+init_lapack_slae2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slae2", rblapack_slae2, -1);
+}
diff --git a/ext/slaebz.c b/ext/slaebz.c
new file mode 100644
index 0000000..b825a3f
--- /dev/null
+++ b/ext/slaebz.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID slaebz_(integer* ijob, integer* nitmax, integer* n, integer* mmax, integer* minp, integer* nbmin, real* abstol, real* reltol, real* pivmin, real* d, real* e, real* e2, integer* nval, real* ab, real* c, integer* mout, integer* nab, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slaebz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_nitmax;
+ integer nitmax;
+ VALUE rblapack_minp;
+ integer minp;
+ VALUE rblapack_nbmin;
+ integer nbmin;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_reltol;
+ real reltol;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_e2;
+ real *e2;
+ VALUE rblapack_nval;
+ integer *nval;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_nab;
+ integer *nab;
+ VALUE rblapack_mout;
+ integer mout;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_nval_out__;
+ integer *nval_out__;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ VALUE rblapack_nab_out__;
+ integer *nab_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer mmax;
+
+ 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 mout, info, nval, ab, c, nab = NumRu::Lapack.slaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAEBZ contains the iteration loops which compute and use the\n* function N(w), which is the count of eigenvalues of a symmetric\n* tridiagonal matrix T less than or equal to its argument w. It\n* performs a choice of two types of loops:\n*\n* IJOB=1, followed by\n* IJOB=2: It takes as input a list of intervals and returns a list of\n* sufficiently small intervals whose union contains the same\n* eigenvalues as the union of the original intervals.\n* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n* The output interval (AB(j,1),AB(j,2)] will contain\n* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n*\n* IJOB=3: It performs a binary search in each input interval\n* (AB(j,1),AB(j,2)] for a point w(j) such that\n* N(w(j))=NVAL(j), and uses C(j) as the starting point of\n* the search. If such a w(j) is found, then on output\n* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output\n* (AB(j,1),AB(j,2)] will be a small interval containing the\n* point where N(w) jumps through NVAL(j), unless that point\n* lies outside the initial interval.\n*\n* Note that the intervals are in all cases half-open intervals,\n* i.e., of the form (a,b] , which includes b but not a .\n*\n* To avoid underflow, the matrix should be scaled so that its largest\n* element is no greater than overflow**(1/2) * underflow**(1/4)\n* in absolute value. To assure the most accurate computation\n* of small eigenvalues, the matrix should be scaled to be\n* not much smaller than that, either.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966\n*\n* Note: the arguments are, in general, *not* checked for unreasonable\n* values.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies what is to be done:\n* = 1: Compute NAB for the initial intervals.\n* = 2: Perform bisection iteration to find eigenvalues of T.\n* = 3: Perform bisection iteration to invert N(w), i.e.,\n* to find a point which has a specified number of\n* eigenvalues of T to its left.\n* Other values will cause SLAEBZ to return with INFO=-1.\n*\n* NITMAX (input) INTEGER\n* The maximum number of \"levels\" of bisection to be\n* performed, i.e., an interval of width W will not be made\n* smaller than 2^(-NITMAX) * W. If not all intervals\n* have converged after NITMAX iterations, then INFO is set\n* to the number of non-converged intervals.\n*\n* N (input) INTEGER\n* The dimension n of the tridiagonal matrix T. It must be at\n* least 1.\n*\n* MMAX (input) INTEGER\n* The maximum number of intervals. If more than MMAX intervals\n* are generated, then SLAEBZ will quit with INFO=MMAX+1.\n*\n* MINP (input) INTEGER\n* The initial number of intervals. It may not be greater than\n* MMAX.\n*\n* NBMIN (input) INTEGER\n* The smallest number of intervals that should be processed\n* using a vector loop. If zero, then only the scalar loop\n* will be used.\n*\n* ABSTOL (input) REAL\n* The minimum (absolute) width of an interval. When an\n* interval is narrower than ABSTOL, or than RELTOL times the\n* larger (in magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. This must be at least\n* zero.\n*\n* RELTOL (input) REAL\n* The minimum relative width of an interval. When an interval\n* is narrower than ABSTOL, or than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* PIVMIN (input) REAL\n* The minimum absolute value of a \"pivot\" in the Sturm\n* sequence loop. This *must* be at least max |e(j)**2| *\n* safe_min and at least safe_min, where safe_min is at least\n* the smallest number that can divide one without overflow.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N)\n* The offdiagonal elements of the tridiagonal matrix T in\n* positions 1 through N-1. E(N) is arbitrary.\n*\n* E2 (input) REAL array, dimension (N)\n* The squares of the offdiagonal elements of the tridiagonal\n* matrix T. E2(N) is ignored.\n*\n* NVAL (input/output) INTEGER array, dimension (MINP)\n* If IJOB=1 or 2, not referenced.\n* If IJOB=3, the desired values of N(w). The elements of NVAL\n* will be reordered to correspond with the intervals in AB.\n* Thus, NVAL(j) on output will not, in general be the same as\n* NVAL(j) on input, but it will correspond with the interval\n* (AB(j,1),AB(j,2)] on output.\n*\n* AB (input/output) REAL array, dimension (MMAX,2)\n* The endpoints of the intervals. AB(j,1) is a(j), the left\n* endpoint of the j-th interval, and AB(j,2) is b(j), the\n* right endpoint of the j-th interval. The input intervals\n* will, in general, be modified, split, and reordered by the\n* calculation.\n*\n* C (input/output) REAL array, dimension (MMAX)\n* If IJOB=1, ignored.\n* If IJOB=2, workspace.\n* If IJOB=3, then on input C(j) should be initialized to the\n* first search point in the binary search.\n*\n* MOUT (output) INTEGER\n* If IJOB=1, the number of eigenvalues in the intervals.\n* If IJOB=2 or 3, the number of intervals output.\n* If IJOB=3, MOUT will equal MINP.\n*\n* NAB (input/output) INTEGER array, dimension (MMAX,2)\n* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n* If IJOB=2, then on input, NAB(i,j) should be set. It must\n* satisfy the condition:\n* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n* which means that in interval i only eigenvalues\n* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,\n* NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with\n* IJOB=1.\n* On output, NAB(i,j) will contain\n* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n* the input interval that the output interval\n* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n* the input values of NAB(k,1) and NAB(k,2).\n* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n* unless N(w) > NVAL(i) for all search points w , in which\n* case NAB(i,1) will not be modified, i.e., the output\n* value will be the same as the input value (modulo\n* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n* for all search points w , in which case NAB(i,2) will\n* not be modified. Normally, NAB should be set to some\n* distinctive value(s) before SLAEBZ is called.\n*\n* WORK (workspace) REAL array, dimension (MMAX)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (MMAX)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: All intervals converged.\n* = 1--MMAX: The last INFO intervals did not converge.\n* = MMAX+1: More than MMAX intervals were generated.\n*\n\n* Further Details\n* ===============\n*\n* This routine is intended to be called only by other LAPACK\n* routines, thus the interface is less user-friendly. It is intended\n* for two purposes:\n*\n* (a) finding eigenvalues. In this case, SLAEBZ should have one or\n* more initial intervals set up in AB, and SLAEBZ should be called\n* with IJOB=1. This sets up NAB, and also counts the eigenvalues.\n* Intervals with no eigenvalues would usually be thrown out at\n* this point. Also, if not all the eigenvalues in an interval i\n* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n* eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX\n* no smaller than the value of MOUT returned by the call with\n* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n* tolerance specified by ABSTOL and RELTOL.\n*\n* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n* In this case, start with a Gershgorin interval (a,b). Set up\n* AB to contain 2 search intervals, both initially (a,b). One\n* NVAL element should contain f-1 and the other should contain l\n* , while C should contain a and b, resp. NAB(i,1) should be -1\n* and NAB(i,2) should be N+1, to flag an error if the desired\n* interval does not lie in (a,b). SLAEBZ is then called with\n* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --\n* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and\n* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and\n* w(l-r)=...=w(l+k) are handled similarly.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n mout, info, nval, ab, c, nab = NumRu::Lapack.slaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 14 && argc != 14)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
+ rblapack_ijob = argv[0];
+ rblapack_nitmax = argv[1];
+ rblapack_minp = argv[2];
+ rblapack_nbmin = argv[3];
+ rblapack_abstol = argv[4];
+ rblapack_reltol = argv[5];
+ rblapack_pivmin = argv[6];
+ rblapack_d = argv[7];
+ rblapack_e = argv[8];
+ rblapack_e2 = argv[9];
+ rblapack_nval = argv[10];
+ rblapack_ab = argv[11];
+ rblapack_c = argv[12];
+ rblapack_nab = argv[13];
+ if (argc == 14) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ minp = NUM2INT(rblapack_minp);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (9th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_e);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (!NA_IsNArray(rblapack_nval))
+ rb_raise(rb_eArgError, "nval (11th argument) must be NArray");
+ if (NA_RANK(rblapack_nval) != 1)
+ rb_raise(rb_eArgError, "rank of nval (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_nval) != ((ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of nval must be %d", (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0);
+ if (NA_TYPE(rblapack_nval) != NA_LINT)
+ rblapack_nval = na_change_type(rblapack_nval, NA_LINT);
+ nval = NA_PTR_TYPE(rblapack_nval, integer*);
+ if (!NA_IsNArray(rblapack_nab))
+ rb_raise(rb_eArgError, "nab (14th argument) must be NArray");
+ if (NA_RANK(rblapack_nab) != 2)
+ rb_raise(rb_eArgError, "rank of nab (14th argument) must be %d", 2);
+ mmax = NA_SHAPE0(rblapack_nab);
+ if (NA_SHAPE1(rblapack_nab) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of nab must be %d", 2);
+ if (NA_TYPE(rblapack_nab) != NA_LINT)
+ rblapack_nab = na_change_type(rblapack_nab, NA_LINT);
+ nab = NA_PTR_TYPE(rblapack_nab, integer*);
+ nitmax = NUM2INT(rblapack_nitmax);
+ reltol = (real)NUM2DBL(rblapack_reltol);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
+ if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, real*);
+ nbmin = NUM2INT(rblapack_nbmin);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (12th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_ab) != mmax)
+ rb_raise(rb_eRuntimeError, "shape 0 of ab must be the same as shape 0 of nab");
+ if (NA_SHAPE1(rblapack_ab) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be %d", 2);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (8th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (8th 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 e");
+ 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_c))
+ rb_raise(rb_eArgError, "c (13th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0);
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0;
+ rblapack_nval_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ nval_out__ = NA_PTR_TYPE(rblapack_nval_out__, integer*);
+ MEMCPY(nval_out__, nval, integer, NA_TOTAL(rblapack_nval));
+ rblapack_nval = rblapack_nval_out__;
+ nval = nval_out__;
+ {
+ int shape[2];
+ shape[0] = mmax;
+ shape[1] = 2;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[1];
+ shape[0] = ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = mmax;
+ shape[1] = 2;
+ rblapack_nab_out__ = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ nab_out__ = NA_PTR_TYPE(rblapack_nab_out__, integer*);
+ MEMCPY(nab_out__, nab, integer, NA_TOTAL(rblapack_nab));
+ rblapack_nab = rblapack_nab_out__;
+ nab = nab_out__;
+ work = ALLOC_N(real, (mmax));
+ iwork = ALLOC_N(integer, (mmax));
+
+ slaebz_(&ijob, &nitmax, &n, &mmax, &minp, &nbmin, &abstol, &reltol, &pivmin, d, e, e2, nval, ab, c, &mout, nab, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_mout = INT2NUM(mout);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_mout, rblapack_info, rblapack_nval, rblapack_ab, rblapack_c, rblapack_nab);
+}
+
+void
+init_lapack_slaebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaebz", rblapack_slaebz, -1);
+}
diff --git a/ext/slaed0.c b/ext/slaed0.c
new file mode 100644
index 0000000..63cc1ca
--- /dev/null
+++ b/ext/slaed0.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID slaed0_(integer* icompq, integer* qsiz, integer* n, real* d, real* e, real* q, integer* ldq, real* qstore, integer* ldqs, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slaed0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ real *qstore;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+ integer ldqs;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q = NumRu::Lapack.slaed0( icompq, qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAED0 computes all eigenvalues and corresponding eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n* = 2: Compute eigenvalues and eigenvectors of tridiagonal\n* matrix.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the main diagonal of the tridiagonal matrix.\n* On exit, its eigenvalues.\n*\n* E (input) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, Q must contain an N-by-N orthogonal matrix.\n* If ICOMPQ = 0 Q is not referenced.\n* If ICOMPQ = 1 On entry, Q is a subset of the columns of the\n* orthogonal matrix used to reduce the full\n* matrix to tridiagonal form corresponding to\n* the subset of the full matrix which is being\n* decomposed at this time.\n* If ICOMPQ = 2 On entry, Q will be the identity matrix.\n* On exit, Q contains the eigenvectors of the\n* tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If eigenvectors are\n* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.\n*\n* QSTORE (workspace) REAL array, dimension (LDQS, N)\n* Referenced only when ICOMPQ = 1. Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE. If ICOMPQ = 1,\n* then LDQS >= max(1,N). In any case, LDQS >= 1.\n*\n* WORK (workspace) REAL array,\n* If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n* 1 + 3*N + 2*N*lg N + 2*N**2\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of WORK must be at least\n* 4*N + N**2.\n*\n* IWORK (workspace) INTEGER array,\n* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of IWORK must be at least\n* 3 + 5*N.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q = NumRu::Lapack.slaed0( icompq, qsiz, d, e, q, [: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_icompq = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ 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_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ qsiz = NUM2INT(rblapack_qsiz);
+ ldqs = icompq == 1 ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ qstore = ALLOC_N(real, (ldqs)*(n));
+ work = ALLOC_N(real, (((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0));
+ iwork = ALLOC_N(integer, (((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0));
+
+ slaed0_(&icompq, &qsiz, &n, d, e, q, &ldq, qstore, &ldqs, work, iwork, &info);
+
+ free(qstore);
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_q);
+}
+
+void
+init_lapack_slaed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed0", rblapack_slaed0, -1);
+}
diff --git a/ext/slaed1.c b/ext/slaed1.c
new file mode 100644
index 0000000..4afec91
--- /dev/null
+++ b/ext/slaed1.c
@@ -0,0 +1,133 @@
+#include "rb_lapack.h"
+
+extern VOID slaed1_(integer* n, real* d, real* q, integer* ldq, integer* indxq, real* rho, integer* cutpnt, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slaed1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_indxq_out__;
+ integer *indxq_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q, indxq = NumRu::Lapack.slaed1( d, q, indxq, rho, cutpnt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAED1 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles\n* the case in which eigenvalues only or eigenvalues and eigenvectors\n* of a full symmetric matrix (which was reduced to tridiagonal form)\n* are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine SLAED4 (as called by SLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* On entry, the permutation which separately sorts the two\n* subproblems in D into ascending order.\n* On exit, the permutation which will reintegrate the\n* subproblems back into sorted order,\n* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* RHO (input) REAL\n* The subdiagonal entry used to create the rank-1 modification.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= CUTPNT <= N/2.\n*\n* WORK (workspace) REAL array, dimension (4*N + N**2)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,\n $ IQ2, IS, IW, IZ, K, N1, N2\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, q, indxq = NumRu::Lapack.slaed1( d, q, indxq, rho, cutpnt, [: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_d = argv[0];
+ rblapack_q = argv[1];
+ rblapack_indxq = argv[2];
+ rblapack_rho = argv[3];
+ rblapack_cutpnt = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_indxq))
+ rb_raise(rb_eArgError, "indxq (3th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (2th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ {
+ 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[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
+ MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
+ rblapack_indxq = rblapack_indxq_out__;
+ indxq = indxq_out__;
+ work = ALLOC_N(real, (4*n + pow(n,2)));
+ iwork = ALLOC_N(integer, (4*n));
+
+ slaed1_(&n, d, q, &ldq, indxq, &rho, &cutpnt, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq);
+}
+
+void
+init_lapack_slaed1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed1", rblapack_slaed1, -1);
+}
diff --git a/ext/slaed2.c b/ext/slaed2.c
new file mode 100644
index 0000000..6a81e7c
--- /dev/null
+++ b/ext/slaed2.c
@@ -0,0 +1,189 @@
+#include "rb_lapack.h"
+
+extern VOID slaed2_(integer* k, integer* n, integer* n1, real* d, real* q, integer* ldq, integer* indxq, real* rho, real* z, real* dlamda, real* w, real* q2, integer* indx, integer* indxc, integer* indxp, integer* coltyp, integer* info);
+
+
+static VALUE
+rblapack_slaed2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_dlamda;
+ real *dlamda;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_q2;
+ real *q2;
+ VALUE rblapack_indxc;
+ integer *indxc;
+ VALUE rblapack_coltyp;
+ integer *coltyp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_indxq_out__;
+ integer *indxq_out__;
+ integer *indx;
+ integer *indxp;
+
+ integer n;
+ integer ldq;
+
+ 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 k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.slaed2( n1, d, q, indxq, rho, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* SLAED2 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation. 0 <= K <=N.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined.\n* On exit, D contains the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, Q contains the eigenvectors of two submatrices in\n* the two square blocks with corners at (1,1), (N1,N1)\n* and (N1+1, N1+1), (N,N).\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have N1 added to their\n* values. Destroyed on exit.\n*\n* RHO (input/output) REAL\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* SLAED3.\n*\n* Z (input) REAL array, dimension (N)\n* On entry, Z contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n* On exit, the contents of Z have been destroyed by the updating\n* process.\n*\n* DLAMDA (output) REAL array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* SLAED3 to form the secular equation.\n*\n* W (output) REAL array, dimension (N)\n* The first k values of the final deflation-altered z-vector\n* which will be passed to SLAED3.\n*\n* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2)\n* A copy of the first K eigenvectors which will be used by\n* SLAED3 in a matrix multiply (SGEMM) to solve for the new\n* eigenvectors.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of DLAMDA into\n* ascending order.\n*\n* INDXC (output) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups: the first group contains non-zero\n* elements only at and above N1, the second contains\n* non-zero elements only below N1, and the third is dense.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* COLTYP (workspace/output) INTEGER array, dimension (N)\n* During execution, a label which will indicate which of the\n* following types a column in the Q2 matrix is:\n* 1 : non-zero in the upper half only;\n* 2 : dense;\n* 3 : non-zero in the lower half only;\n* 4 : deflated.\n* On exit, COLTYP(i) is the number of columns of type i,\n* for i=1 to 4 only.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.slaed2( n1, d, q, indxq, rho, z, [: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_n1 = argv[0];
+ rblapack_d = argv[1];
+ rblapack_q = argv[2];
+ rblapack_indxq = argv[3];
+ rblapack_rho = argv[4];
+ rblapack_z = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n1 = NUM2INT(rblapack_n1);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of q");
+ 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_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_indxq))
+ rb_raise(rb_eArgError, "indxq (4th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = pow(n1,2)+pow(n-n1,2);
+ rblapack_q2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ q2 = NA_PTR_TYPE(rblapack_q2, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxc = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxc = NA_PTR_TYPE(rblapack_indxc, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
+ {
+ 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[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
+ MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
+ rblapack_indxq = rblapack_indxq_out__;
+ indxq = indxq_out__;
+ indx = ALLOC_N(integer, (n));
+ indxp = ALLOC_N(integer, (n));
+
+ slaed2_(&k, &n, &n1, d, q, &ldq, indxq, &rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, &info);
+
+ free(indx);
+ free(indxp);
+ rblapack_k = INT2NUM(k);
+ rblapack_info = INT2NUM(info);
+ rblapack_rho = rb_float_new((double)rho);
+ return rb_ary_new3(11, rblapack_k, rblapack_dlamda, rblapack_w, rblapack_q2, rblapack_indxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq, rblapack_rho);
+}
+
+void
+init_lapack_slaed2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed2", rblapack_slaed2, -1);
+}
diff --git a/ext/slaed3.c b/ext/slaed3.c
new file mode 100644
index 0000000..1840a0e
--- /dev/null
+++ b/ext/slaed3.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID slaed3_(integer* k, integer* n, integer* n1, real* d, real* q, integer* ldq, real* rho, real* dlamda, real* q2, integer* indx, integer* ctot, real* w, real* s, integer* info);
+
+
+static VALUE
+rblapack_slaed3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_dlamda;
+ real *dlamda;
+ VALUE rblapack_q2;
+ real *q2;
+ VALUE rblapack_indx;
+ integer *indx;
+ VALUE rblapack_ctot;
+ integer *ctot;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dlamda_out__;
+ real *dlamda_out__;
+ VALUE rblapack_w_out__;
+ real *w_out__;
+ real *s;
+
+ integer k;
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, q, info, dlamda, w = NumRu::Lapack.slaed3( n1, rho, dlamda, q2, indx, ctot, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n* Purpose\n* =======\n*\n* SLAED3 finds the roots of the secular equation, as defined by the\n* values in D, W, and RHO, between 1 and K. It makes the\n* appropriate calls to SLAED4 and then updates the eigenvectors by\n* multiplying the matrix of eigenvectors of the pair of eigensystems\n* being combined by the matrix of eigenvectors of the K-by-K system\n* which is solved here.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* SLAED4. K >= 0.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (deflation may result in N>K).\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading submatrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (output) REAL array, dimension (N)\n* D(I) contains the updated eigenvalues for\n* 1 <= I <= K.\n*\n* Q (output) REAL array, dimension (LDQ,N)\n* Initially the first K columns are used as workspace.\n* On output the columns 1 to K contain\n* the updated eigenvectors.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) REAL\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input/output) REAL array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation. May be changed on output by\n* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n* Cray-2, or Cray C-90, as described above.\n*\n* Q2 (input) REAL array, dimension (LDQ2, N)\n* The first K columns of this matrix contain the non-deflated\n* eigenvectors for the split problem.\n*\n* INDX (input) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups (see SLAED2).\n* The rows of the eigenvectors found by SLAED4 must be likewise\n* permuted before the matrix multiply can take place.\n*\n* CTOT (input) INTEGER array, dimension (4)\n* A count of the total number of the various types of columns\n* in Q, as described in INDX. The fourth column type is any\n* column which has been deflated.\n*\n* W (input/output) REAL array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector. Destroyed on\n* output.\n*\n* S (workspace) REAL array, dimension (N1 + 1)*K\n* Will contain the eigenvectors of the repaired matrix which\n* will be multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, q, info, dlamda, w = NumRu::Lapack.slaed3( n1, rho, dlamda, q2, indx, ctot, w, [: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_n1 = argv[0];
+ rblapack_rho = argv[1];
+ rblapack_dlamda = argv[2];
+ rblapack_q2 = argv[3];
+ rblapack_indx = argv[4];
+ rblapack_ctot = argv[5];
+ rblapack_w = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n1 = NUM2INT(rblapack_n1);
+ if (!NA_IsNArray(rblapack_dlamda))
+ rb_raise(rb_eArgError, "dlamda (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dlamda) != 1)
+ rb_raise(rb_eArgError, "rank of dlamda (3th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_dlamda);
+ if (NA_TYPE(rblapack_dlamda) != NA_SFLOAT)
+ rblapack_dlamda = na_change_type(rblapack_dlamda, NA_SFLOAT);
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
+ if (!NA_IsNArray(rblapack_indx))
+ rb_raise(rb_eArgError, "indx (5th argument) must be NArray");
+ if (NA_RANK(rblapack_indx) != 1)
+ rb_raise(rb_eArgError, "rank of indx (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_indx);
+ if (NA_TYPE(rblapack_indx) != NA_LINT)
+ rblapack_indx = na_change_type(rblapack_indx, NA_LINT);
+ indx = NA_PTR_TYPE(rblapack_indx, integer*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (7th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_ctot))
+ rb_raise(rb_eArgError, "ctot (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ctot) != 1)
+ rb_raise(rb_eArgError, "rank of ctot (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ctot) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
+ if (NA_TYPE(rblapack_ctot) != NA_LINT)
+ rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
+ ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
+ if (!NA_IsNArray(rblapack_q2))
+ rb_raise(rb_eArgError, "q2 (4th argument) must be NArray");
+ if (NA_RANK(rblapack_q2) != 2)
+ rb_raise(rb_eArgError, "rank of q2 (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_q2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of q2 must be the same as shape 0 of indx");
+ if (NA_SHAPE1(rblapack_q2) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q2 must be the same as shape 0 of indx");
+ if (NA_TYPE(rblapack_q2) != NA_SFLOAT)
+ rblapack_q2 = na_change_type(rblapack_q2, NA_SFLOAT);
+ q2 = NA_PTR_TYPE(rblapack_q2, real*);
+ ldq = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_dlamda_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dlamda_out__ = NA_PTR_TYPE(rblapack_dlamda_out__, real*);
+ MEMCPY(dlamda_out__, dlamda, real, NA_TOTAL(rblapack_dlamda));
+ rblapack_dlamda = rblapack_dlamda_out__;
+ dlamda = dlamda_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
+ MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ s = ALLOC_N(real, (MAX(1,k))*(n1 + 1));
+
+ slaed3_(&k, &n, &n1, d, q, &ldq, &rho, dlamda, q2, indx, ctot, w, s, &info);
+
+ free(s);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_q, rblapack_info, rblapack_dlamda, rblapack_w);
+}
+
+void
+init_lapack_slaed3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed3", rblapack_slaed3, -1);
+}
diff --git a/ext/slaed4.c b/ext/slaed4.c
new file mode 100644
index 0000000..b9d5de8
--- /dev/null
+++ b/ext/slaed4.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID slaed4_(integer* n, integer* i, real* d, real* z, real* delta, real* rho, real* dlam, integer* info);
+
+
+static VALUE
+rblapack_slaed4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_delta;
+ real *delta;
+ VALUE rblapack_dlam;
+ real dlam;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 delta, dlam, info = NumRu::Lapack.slaed4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th updated eigenvalue of a symmetric\n* rank-one modification to a diagonal matrix whose elements are\n* given in the array d, and that\n*\n* D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) REAL array, dimension (N)\n* The original eigenvalues. It is assumed that they are in\n* order, D(I) < D(J) for I < J.\n*\n* Z (input) REAL array, dimension (N)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (N)\n* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5\n* for detail. The vector DELTA contains the information necessary\n* to construct the eigenvectors by SLAED3 and SLAED9.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) REAL\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, dlam, info = NumRu::Lapack.slaed4( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, real*);
+
+ slaed4_(&n, &i, d, z, delta, &rho, &dlam, &info);
+
+ rblapack_dlam = rb_float_new((double)dlam);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_delta, rblapack_dlam, rblapack_info);
+}
+
+void
+init_lapack_slaed4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed4", rblapack_slaed4, -1);
+}
diff --git a/ext/slaed5.c b/ext/slaed5.c
new file mode 100644
index 0000000..1ef5f2a
--- /dev/null
+++ b/ext/slaed5.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID slaed5_(integer* i, real* d, real* z, real* delta, real* rho, real* dlam);
+
+
+static VALUE
+rblapack_slaed5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_delta;
+ real *delta;
+ VALUE rblapack_dlam;
+ real dlam;
+
+
+ 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 delta, dlam = NumRu::Lapack.slaed5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th eigenvalue of a symmetric rank-one\n* modification of a 2-by-2 diagonal matrix\n*\n* diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal elements in the array D are assumed to satisfy\n*\n* D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) REAL array, dimension (2)\n* The original eigenvalues. We assume D(1) < D(2).\n*\n* Z (input) REAL array, dimension (2)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (2)\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) REAL\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, dlam = NumRu::Lapack.slaed5( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_d) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, real*);
+
+ slaed5_(&i, d, z, delta, &rho, &dlam);
+
+ rblapack_dlam = rb_float_new((double)dlam);
+ return rb_ary_new3(2, rblapack_delta, rblapack_dlam);
+}
+
+void
+init_lapack_slaed5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed5", rblapack_slaed5, -1);
+}
diff --git a/ext/slaed6.c b/ext/slaed6.c
new file mode 100644
index 0000000..5be0c4c
--- /dev/null
+++ b/ext/slaed6.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID slaed6_(integer* kniter, logical* orgati, real* rho, real* d, real* z, real* finit, real* tau, integer* info);
+
+
+static VALUE
+rblapack_slaed6(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kniter;
+ integer kniter;
+ VALUE rblapack_orgati;
+ logical orgati;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_finit;
+ real finit;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 tau, info = NumRu::Lapack.slaed6( kniter, orgati, rho, d, z, finit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n* Purpose\n* =======\n*\n* SLAED6 computes the positive or negative root (closest to the origin)\n* of\n* z(1) z(2) z(3)\n* f(x) = rho + --------- + ---------- + ---------\n* d(1)-x d(2)-x d(3)-x\n*\n* It is assumed that\n*\n* if ORGATI = .true. the root is between d(2) and d(3);\n* otherwise it is between d(1) and d(2)\n*\n* This routine will be called by SLAED4 when necessary. In most cases,\n* the root sought is the smallest in magnitude, though it might not be\n* in some extremely rare situations.\n*\n\n* Arguments\n* =========\n*\n* KNITER (input) INTEGER\n* Refer to SLAED4 for its significance.\n*\n* ORGATI (input) LOGICAL\n* If ORGATI is true, the needed root is between d(2) and\n* d(3); otherwise it is between d(1) and d(2). See\n* SLAED4 for further details.\n*\n* RHO (input) REAL \n* Refer to the equation f(x) above.\n*\n* D (input) REAL array, dimension (3)\n* D satisfies d(1) < d(2) < d(3).\n*\n* Z (input) REAL array, dimension (3)\n* Each of the elements in z must be positive.\n*\n* FINIT (input) REAL \n* The value of f at 0. It is more accurate than the one\n* evaluated inside this routine (if someone wants to do\n* so).\n*\n* TAU (output) REAL \n* The root of the equation f(x).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, failure to converge\n*\n\n* Further Details\n* ===============\n*\n* 30/06/99: Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* 10/02/03: This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). SJH.\n*\n* 05/10/06: Modified from a new version of Ren-Cang Li, use\n* Gragg-Thornton-Warner cubic convergent scheme for better stability.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info = NumRu::Lapack.slaed6( kniter, orgati, rho, d, z, finit, [: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_kniter = argv[0];
+ rblapack_orgati = argv[1];
+ rblapack_rho = argv[2];
+ rblapack_d = argv[3];
+ rblapack_z = argv[4];
+ rblapack_finit = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kniter = NUM2INT(rblapack_kniter);
+ rho = (real)NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (5th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 3);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ orgati = (rblapack_orgati == Qtrue);
+ finit = (real)NUM2DBL(rblapack_finit);
+ 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) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 3);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+
+ slaed6_(&kniter, &orgati, &rho, d, z, &finit, &tau, &info);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_tau, rblapack_info);
+}
+
+void
+init_lapack_slaed6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed6", rblapack_slaed6, -1);
+}
diff --git a/ext/slaed7.c b/ext/slaed7.c
new file mode 100644
index 0000000..d6105fa
--- /dev/null
+++ b/ext/slaed7.c
@@ -0,0 +1,248 @@
+#include "rb_lapack.h"
+
+extern VOID slaed7_(integer* icompq, integer* n, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, real* d, real* q, integer* ldq, integer* indxq, real* rho, integer* cutpnt, real* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, real* givnum, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slaed7(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_tlvls;
+ integer tlvls;
+ VALUE rblapack_curlvl;
+ integer curlvl;
+ VALUE rblapack_curpbm;
+ integer curpbm;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_qstore;
+ real *qstore;
+ VALUE rblapack_qptr;
+ integer *qptr;
+ VALUE rblapack_prmptr;
+ integer *prmptr;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_qstore_out__;
+ real *qstore_out__;
+ VALUE rblapack_qptr_out__;
+ integer *qptr_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+
+ 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 indxq, info, d, q, qstore, qptr = NumRu::Lapack.slaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense symmetric matrix\n* that has been reduced to tridiagonal form. SLAED1 handles\n* the case in which all eigenvalues and eigenvectors of a symmetric\n* tridiagonal matrix are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLAED8.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine SLAED4 (as called by SLAED9).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= CURLVL <= TLVLS.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* The permutation which will reintegrate the subproblem just\n* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n* will be in ascending order.\n*\n* RHO (input) REAL\n* The subdiagonal element used to create the rank-1\n* modification.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSTORE (input/output) REAL array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) REAL array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* WORK (workspace) REAL array, dimension (3*N+QSIZ*N)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.slaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 16 && argc != 16)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_tlvls = argv[2];
+ rblapack_curlvl = argv[3];
+ rblapack_curpbm = argv[4];
+ rblapack_d = argv[5];
+ rblapack_q = argv[6];
+ rblapack_rho = argv[7];
+ rblapack_cutpnt = argv[8];
+ rblapack_qstore = argv[9];
+ rblapack_qptr = argv[10];
+ rblapack_prmptr = argv[11];
+ rblapack_perm = argv[12];
+ rblapack_givptr = argv[13];
+ rblapack_givcol = argv[14];
+ rblapack_givnum = argv[15];
+ if (argc == 16) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ tlvls = NUM2INT(rblapack_tlvls);
+ curpbm = NUM2INT(rblapack_curpbm);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (6th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (6th 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 1 of q");
+ 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_qstore))
+ rb_raise(rb_eArgError, "qstore (10th argument) must be NArray");
+ if (NA_RANK(rblapack_qstore) != 1)
+ rb_raise(rb_eArgError, "rank of qstore (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
+ if (NA_TYPE(rblapack_qstore) != NA_SFLOAT)
+ rblapack_qstore = na_change_type(rblapack_qstore, NA_SFLOAT);
+ qstore = NA_PTR_TYPE(rblapack_qstore, real*);
+ if (!NA_IsNArray(rblapack_prmptr))
+ rb_raise(rb_eArgError, "prmptr (12th argument) must be NArray");
+ if (NA_RANK(rblapack_prmptr) != 1)
+ rb_raise(rb_eArgError, "rank of prmptr (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_prmptr) != NA_LINT)
+ rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
+ prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (14th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (16th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (16th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
+ if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ curlvl = NUM2INT(rblapack_curlvl);
+ if (!NA_IsNArray(rblapack_qptr))
+ rb_raise(rb_eArgError, "qptr (11th argument) must be NArray");
+ if (NA_RANK(rblapack_qptr) != 1)
+ rb_raise(rb_eArgError, "rank of qptr (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qptr) != (n+2))
+ rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
+ if (NA_TYPE(rblapack_qptr) != NA_LINT)
+ rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
+ qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (15th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (15th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
+ if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (13th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ {
+ 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[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = pow(n,2)+1;
+ rblapack_qstore_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, real*);
+ MEMCPY(qstore_out__, qstore, real, NA_TOTAL(rblapack_qstore));
+ rblapack_qstore = rblapack_qstore_out__;
+ qstore = qstore_out__;
+ {
+ int shape[1];
+ shape[0] = n+2;
+ rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
+ MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
+ rblapack_qptr = rblapack_qptr_out__;
+ qptr = qptr_out__;
+ work = ALLOC_N(real, (3*n+qsiz*n));
+ iwork = ALLOC_N(integer, (4*n));
+
+ slaed7_(&icompq, &n, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, indxq, &rho, &cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
+}
+
+void
+init_lapack_slaed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed7", rblapack_slaed7, -1);
+}
diff --git a/ext/slaed8.c b/ext/slaed8.c
new file mode 100644
index 0000000..e443602
--- /dev/null
+++ b/ext/slaed8.c
@@ -0,0 +1,206 @@
+#include "rb_lapack.h"
+
+extern VOID slaed8_(integer* icompq, integer* k, integer* n, integer* qsiz, real* d, real* q, integer* ldq, integer* indxq, real* rho, integer* cutpnt, real* z, real* dlamda, real* q2, integer* ldq2, real* w, integer* perm, integer* givptr, integer* givcol, real* givnum, integer* indxp, integer* indx, integer* info);
+
+
+static VALUE
+rblapack_slaed8(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_dlamda;
+ real *dlamda;
+ VALUE rblapack_q2;
+ real *q2;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ integer *indxp;
+ integer *indx;
+
+ integer n;
+ integer ldq2;
+
+ 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 k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.slaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n* Purpose\n* =======\n*\n* SLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the two submatrices to be\n* combined. On exit, the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* If ICOMPQ = 0, Q is not referenced. Otherwise,\n* on entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have CUTPNT added to\n* their values in order to be accurate.\n*\n* RHO (input/output) REAL\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* SLAED3.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* Z (input) REAL array, dimension (N)\n* On entry, Z contains the updating vector (the last row of\n* the first sub-eigenvector matrix and the first row of the\n* second sub-eigenvector matrix).\n* On exit, the contents of Z are destroyed by the updating\n* process.\n*\n* DLAMDA (output) REAL array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* SLAED3 to form the secular equation.\n*\n* Q2 (output) REAL array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* a copy of the first K eigenvectors which will be used by\n* SLAED7 in a matrix multiply (SGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* The first k values of the final deflation-altered z-vector and\n* will be passed to SLAED3.\n*\n* PERM (output) INTEGER array, dimension (N)\n* The permutations (from deflation and sorting) to be applied\n* to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) REAL array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of D into ascending\n* order.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.slaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_q = argv[3];
+ rblapack_ldq = argv[4];
+ rblapack_indxq = argv[5];
+ rblapack_rho = argv[6];
+ rblapack_cutpnt = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ 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*);
+ ldq = NUM2INT(rblapack_ldq);
+ rho = (real)NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_indxq))
+ rb_raise(rb_eArgError, "indxq (6th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ ldq2 = MAX(1,n);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (4th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_q) != (icompq==0 ? 0 : ldq))
+ rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", icompq==0 ? 0 : ldq);
+ if (NA_SHAPE1(rblapack_q) != (icompq==0 ? 0 : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", icompq==0 ? 0 : n);
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
+ {
+ int shape[2];
+ shape[0] = icompq==0 ? 0 : ldq2;
+ shape[1] = icompq==0 ? 0 : n;
+ rblapack_q2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q2 = NA_PTR_TYPE(rblapack_q2, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ {
+ 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[2];
+ shape[0] = icompq==0 ? 0 : ldq;
+ shape[1] = icompq==0 ? 0 : n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ indxp = ALLOC_N(integer, (n));
+ indx = ALLOC_N(integer, (n));
+
+ slaed8_(&icompq, &k, &n, &qsiz, d, q, &ldq, indxq, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, perm, &givptr, givcol, givnum, indxp, indx, &info);
+
+ free(indxp);
+ free(indx);
+ rblapack_k = INT2NUM(k);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_info = INT2NUM(info);
+ rblapack_rho = rb_float_new((double)rho);
+ return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_d, rblapack_q, rblapack_rho);
+}
+
+void
+init_lapack_slaed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed8", rblapack_slaed8, -1);
+}
diff --git a/ext/slaed9.c b/ext/slaed9.c
new file mode 100644
index 0000000..249afdb
--- /dev/null
+++ b/ext/slaed9.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID slaed9_(integer* k, integer* kstart, integer* kstop, integer* n, real* d, real* q, integer* ldq, real* rho, real* dlamda, real* w, real* s, integer* lds, integer* info);
+
+
+static VALUE
+rblapack_slaed9(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kstart;
+ integer kstart;
+ VALUE rblapack_kstop;
+ integer kstop;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_dlamda;
+ real *dlamda;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_info;
+ integer info;
+ real *q;
+
+ integer k;
+ integer lds;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, s, info = NumRu::Lapack.slaed9( kstart, kstop, n, rho, dlamda, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n* Purpose\n* =======\n*\n* SLAED9 finds the roots of the secular equation, as defined by the\n* values in D, Z, and RHO, between KSTART and KSTOP. It makes the\n* appropriate calls to SLAED4 and then stores the new matrix of\n* eigenvectors for use in calculating the next level of Z vectors.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* SLAED4. K >= 0.\n*\n* KSTART (input) INTEGER\n* KSTOP (input) INTEGER\n* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n* are to be computed. 1 <= KSTART <= KSTOP <= K.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (delation may result in N > K).\n*\n* D (output) REAL array, dimension (N)\n* D(I) contains the updated eigenvalues\n* for KSTART <= I <= KSTOP.\n*\n* Q (workspace) REAL array, dimension (LDQ,N)\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* RHO (input) REAL\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input) REAL array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* W (input) REAL array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector.\n*\n* S (output) REAL array, dimension (LDS, K)\n* Will contain the eigenvectors of the repaired matrix which\n* will be stored for subsequent Z vector calculation and\n* multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL TEMP\n* ..\n* .. External Functions ..\n REAL SLAMC3, SNRM2\n EXTERNAL SLAMC3, SNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SLAED4, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, SIGN, SQRT\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, s, info = NumRu::Lapack.slaed9( kstart, kstop, n, rho, dlamda, w, [: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_kstart = argv[0];
+ rblapack_kstop = argv[1];
+ rblapack_n = argv[2];
+ rblapack_rho = argv[3];
+ rblapack_dlamda = argv[4];
+ rblapack_w = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kstart = NUM2INT(rblapack_kstart);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_dlamda))
+ rb_raise(rb_eArgError, "dlamda (5th argument) must be NArray");
+ if (NA_RANK(rblapack_dlamda) != 1)
+ rb_raise(rb_eArgError, "rank of dlamda (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_dlamda);
+ if (NA_TYPE(rblapack_dlamda) != NA_SFLOAT)
+ rblapack_dlamda = na_change_type(rblapack_dlamda, NA_SFLOAT);
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
+ ldq = MAX( 1, n );
+ kstop = NUM2INT(rblapack_kstop);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (6th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ lds = MAX( 1, k );
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[2];
+ shape[0] = lds;
+ shape[1] = k;
+ rblapack_s = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ q = ALLOC_N(real, (ldq)*(MAX(1,n)));
+
+ slaed9_(&k, &kstart, &kstop, &n, d, q, &ldq, &rho, dlamda, w, s, &lds, &info);
+
+ free(q);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_d, rblapack_s, rblapack_info);
+}
+
+void
+init_lapack_slaed9(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaed9", rblapack_slaed9, -1);
+}
diff --git a/ext/slaeda.c b/ext/slaeda.c
new file mode 100644
index 0000000..147863f
--- /dev/null
+++ b/ext/slaeda.c
@@ -0,0 +1,160 @@
+#include "rb_lapack.h"
+
+extern VOID slaeda_(integer* n, integer* tlvls, integer* curlvl, integer* curpbm, integer* prmptr, integer* perm, integer* givptr, integer* givcol, real* givnum, real* q, integer* qptr, real* z, real* ztemp, integer* info);
+
+
+static VALUE
+rblapack_slaeda(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_tlvls;
+ integer tlvls;
+ VALUE rblapack_curlvl;
+ integer curlvl;
+ VALUE rblapack_curpbm;
+ integer curpbm;
+ VALUE rblapack_prmptr;
+ integer *prmptr;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_qptr;
+ integer *qptr;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ real *ztemp;
+
+ integer ldqptr;
+ 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 z, info = NumRu::Lapack.slaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n* Purpose\n* =======\n*\n* SLAEDA computes the Z vector corresponding to the merge step in the\n* CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n* problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and incidentally the\n* size of the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) REAL array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* Q (input) REAL array, dimension (N**2)\n* Contains the square eigenblocks from previous levels, the\n* starting positions for blocks are given by QPTR.\n*\n* QPTR (input) INTEGER array, dimension (N+2)\n* Contains a list of pointers which indicate where in Q an\n* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates\n* the size of the block.\n*\n* Z (output) REAL array, dimension (N)\n* On output this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n*\n* ZTEMP (workspace) REAL 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, info = NumRu::Lapack.slaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_tlvls = argv[0];
+ rblapack_curlvl = argv[1];
+ rblapack_curpbm = argv[2];
+ rblapack_prmptr = argv[3];
+ rblapack_perm = argv[4];
+ rblapack_givptr = argv[5];
+ rblapack_givcol = argv[6];
+ rblapack_givnum = argv[7];
+ rblapack_q = argv[8];
+ rblapack_qptr = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ tlvls = NUM2INT(rblapack_tlvls);
+ curpbm = NUM2INT(rblapack_curpbm);
+ if (!NA_IsNArray(rblapack_qptr))
+ rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_qptr) != 1)
+ rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
+ ldqptr = NA_SHAPE0(rblapack_qptr);
+ if (NA_TYPE(rblapack_qptr) != NA_LINT)
+ rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
+ qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
+ curlvl = NUM2INT(rblapack_curlvl);
+ n = ldqptr-2;
+ if (!NA_IsNArray(rblapack_prmptr))
+ rb_raise(rb_eArgError, "prmptr (4th argument) must be NArray");
+ if (NA_RANK(rblapack_prmptr) != 1)
+ rb_raise(rb_eArgError, "rank of prmptr (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_prmptr) != NA_LINT)
+ rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
+ prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (8th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
+ if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (5th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (9th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 1)
+ rb_raise(rb_eArgError, "rank of q (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_q) != (pow(n,2)))
+ rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", pow(n,2));
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (7th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
+ if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ ztemp = ALLOC_N(real, (n));
+
+ slaeda_(&n, &tlvls, &curlvl, &curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, &info);
+
+ free(ztemp);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_z, rblapack_info);
+}
+
+void
+init_lapack_slaeda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaeda", rblapack_slaeda, -1);
+}
diff --git a/ext/slaein.c b/ext/slaein.c
new file mode 100644
index 0000000..148df51
--- /dev/null
+++ b/ext/slaein.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID slaein_(logical* rightv, logical* noinit, integer* n, real* h, integer* ldh, real* wr, real* wi, real* vr, real* vi, real* b, integer* ldb, real* work, real* eps3, real* smlnum, real* bignum, integer* info);
+
+
+static VALUE
+rblapack_slaein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_rightv;
+ logical rightv;
+ VALUE rblapack_noinit;
+ logical noinit;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_wr;
+ real wr;
+ VALUE rblapack_wi;
+ real wi;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_vi;
+ real *vi;
+ VALUE rblapack_eps3;
+ real eps3;
+ VALUE rblapack_smlnum;
+ real smlnum;
+ VALUE rblapack_bignum;
+ real bignum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_vr_out__;
+ real *vr_out__;
+ VALUE rblapack_vi_out__;
+ real *vi_out__;
+ real *b;
+ real *work;
+
+ integer ldh;
+ integer n;
+ integer ldb;
+
+ 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, vr, vi = NumRu::Lapack.slaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n* Purpose\n* =======\n*\n* SLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in (VR,VI).\n* = .FALSE.: initial vector supplied in (VR,VI).\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) REAL array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input) REAL\n* WI (input) REAL\n* The real and imaginary parts of the eigenvalue of H whose\n* corresponding right or left eigenvector is to be computed.\n*\n* VR (input/output) REAL array, dimension (N)\n* VI (input/output) REAL array, dimension (N)\n* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n* a real starting vector for inverse iteration using the real\n* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n* must contain the real and imaginary parts of a complex\n* starting vector for inverse iteration using the complex\n* eigenvalue (WR,WI); otherwise VR and VI need not be set.\n* On exit, if WI = 0.0 (real eigenvalue), VR contains the\n* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n* VR and VI contain the real and imaginary parts of the\n* computed complex eigenvector. The eigenvector is normalized\n* so that the component of largest magnitude has magnitude 1;\n* here the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n* VI is not referenced if WI = 0.0.\n*\n* B (workspace) REAL array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= N+1.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* EPS3 (input) REAL\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) REAL\n* A machine-dependent value close to the underflow threshold.\n*\n* BIGNUM (input) REAL\n* A machine-dependent value close to the overflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; VR is set to the\n* last iterate, and so is VI if WI.ne.0.0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, vr, vi = NumRu::Lapack.slaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_rightv = argv[0];
+ rblapack_noinit = argv[1];
+ rblapack_h = argv[2];
+ rblapack_wr = argv[3];
+ rblapack_wi = argv[4];
+ rblapack_vr = argv[5];
+ rblapack_vi = argv[6];
+ rblapack_eps3 = argv[7];
+ rblapack_smlnum = argv[8];
+ rblapack_bignum = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ rightv = (rblapack_rightv == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (3th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ wi = (real)NUM2DBL(rblapack_wi);
+ if (!NA_IsNArray(rblapack_vi))
+ rb_raise(rb_eArgError, "vi (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vi) != 1)
+ rb_raise(rb_eArgError, "rank of vi (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vi) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vi must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_vi) != NA_SFLOAT)
+ rblapack_vi = na_change_type(rblapack_vi, NA_SFLOAT);
+ vi = NA_PTR_TYPE(rblapack_vi, real*);
+ smlnum = (real)NUM2DBL(rblapack_smlnum);
+ noinit = (rblapack_noinit == Qtrue);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 1)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vr must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ bignum = (real)NUM2DBL(rblapack_bignum);
+ wr = (real)NUM2DBL(rblapack_wr);
+ ldb = n+1;
+ eps3 = (real)NUM2DBL(rblapack_eps3);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
+ MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vi_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vi_out__ = NA_PTR_TYPE(rblapack_vi_out__, real*);
+ MEMCPY(vi_out__, vi, real, NA_TOTAL(rblapack_vi));
+ rblapack_vi = rblapack_vi_out__;
+ vi = vi_out__;
+ b = ALLOC_N(real, (ldb)*(n));
+ work = ALLOC_N(real, (n));
+
+ slaein_(&rightv, &noinit, &n, h, &ldh, &wr, &wi, vr, vi, b, &ldb, work, &eps3, &smlnum, &bignum, &info);
+
+ free(b);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_vr, rblapack_vi);
+}
+
+void
+init_lapack_slaein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaein", rblapack_slaein, -1);
+}
diff --git a/ext/slaev2.c b/ext/slaev2.c
new file mode 100644
index 0000000..da2d396
--- /dev/null
+++ b/ext/slaev2.c
@@ -0,0 +1,68 @@
+#include "rb_lapack.h"
+
+extern VOID slaev2_(real* a, real* b, real* c, real* rt1, real* rt2, real* cs1, real* sn1);
+
+
+static VALUE
+rblapack_slaev2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real a;
+ VALUE rblapack_b;
+ real b;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_rt1;
+ real rt1;
+ VALUE rblapack_rt2;
+ real rt2;
+ VALUE rblapack_cs1;
+ real cs1;
+ VALUE rblapack_sn1;
+ real sn1;
+
+
+ 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 rt1, rt2, cs1, sn1 = NumRu::Lapack.slaev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) REAL\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) REAL\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) REAL\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) REAL\n* SN1 (output) REAL\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.slaev2( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = (real)NUM2DBL(rblapack_a);
+ c = (real)NUM2DBL(rblapack_c);
+ b = (real)NUM2DBL(rblapack_b);
+
+ slaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
+
+ rblapack_rt1 = rb_float_new((double)rt1);
+ rblapack_rt2 = rb_float_new((double)rt2);
+ rblapack_cs1 = rb_float_new((double)cs1);
+ rblapack_sn1 = rb_float_new((double)sn1);
+ return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
+}
+
+void
+init_lapack_slaev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaev2", rblapack_slaev2, -1);
+}
diff --git a/ext/slaexc.c b/ext/slaexc.c
new file mode 100644
index 0000000..7981365
--- /dev/null
+++ b/ext/slaexc.c
@@ -0,0 +1,118 @@
+#include "rb_lapack.h"
+
+extern VOID slaexc_(logical* wantq, integer* n, real* t, integer* ldt, real* q, integer* ldq, integer* j1, integer* n1, integer* n2, real* work, integer* info);
+
+
+static VALUE
+rblapack_slaexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_j1;
+ integer j1;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ real *t_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ real *work;
+
+ integer ldt;
+ integer n;
+ integer ldq;
+
+ 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, t, q = NumRu::Lapack.slaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n* an upper quasi-triangular matrix T by an orthogonal similarity\n* transformation.\n*\n* T must be in Schur canonical form, that is, block upper triangular\n* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n* has its diagonal elemnts equal and its off-diagonal elements of\n* opposite sign.\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* = .TRUE. : accumulate the transformation in the matrix Q;\n* = .FALSE.: do not accumulate the transformation.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) REAL array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, the updated matrix T, again in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n* On exit, if WANTQ is .TRUE., the updated matrix Q.\n* If WANTQ is .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n*\n* J1 (input) INTEGER\n* The index of the first row of the first block T11.\n*\n* N1 (input) INTEGER\n* The order of the first block T11. N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block T22. N2 = 0, 1 or 2.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: the transformed matrix T would be too far from Schur\n* form; the blocks are not swapped and T and Q are\n* unchanged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.slaexc( wantq, t, q, j1, n1, n2, [: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_wantq = argv[0];
+ rblapack_t = argv[1];
+ rblapack_q = argv[2];
+ rblapack_j1 = argv[3];
+ rblapack_n1 = argv[4];
+ rblapack_n2 = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ n1 = NUM2INT(rblapack_n1);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (2th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ n2 = NUM2INT(rblapack_n2);
+ j1 = NUM2INT(rblapack_j1);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
+ MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(real, (n));
+
+ slaexc_(&wantq, &n, t, &ldt, q, &ldq, &j1, &n1, &n2, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_slaexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaexc", rblapack_slaexc, -1);
+}
diff --git a/ext/slag2.c b/ext/slag2.c
new file mode 100644
index 0000000..2f9f0f7
--- /dev/null
+++ b/ext/slag2.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID slag2_(real* a, integer* lda, real* b, integer* ldb, real* safmin, real* scale1, real* scale2, real* wr1, real* wr2, real* wi);
+
+
+static VALUE
+rblapack_slag2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_safmin;
+ real safmin;
+ VALUE rblapack_scale1;
+ real scale1;
+ VALUE rblapack_scale2;
+ real scale2;
+ VALUE rblapack_wr1;
+ real wr1;
+ VALUE rblapack_wr2;
+ real wr2;
+ VALUE rblapack_wi;
+ real wi;
+
+ integer lda;
+ integer ldb;
+
+ 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 scale1, scale2, wr1, wr2, wi = NumRu::Lapack.slag2( a, b, safmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n* Purpose\n* =======\n*\n* SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n* problem A - w B, with scaling as necessary to avoid over-/underflow.\n*\n* The scaling factor \"s\" results in a modified eigenvalue equation\n*\n* s A - w B\n*\n* where s is a non-negative scaling factor chosen so that w, w B,\n* and s A do not overflow and, if possible, do not underflow, either.\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm\n* is less than 1/SAFMIN. Entries less than\n* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= 2.\n*\n* B (input) REAL array, dimension (LDB, 2)\n* On entry, the 2 x 2 upper triangular matrix B. It is\n* assumed that the one-norm of B is less than 1/SAFMIN. The\n* diagonals should be at least sqrt(SAFMIN) times the largest\n* element of B (in absolute value); if a diagonal is smaller\n* than that, then +/- sqrt(SAFMIN) will be used instead of\n* that diagonal.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 2.\n*\n* SAFMIN (input) REAL\n* The smallest positive number s.t. 1/SAFMIN does not\n* overflow. (This should always be SLAMCH('S') -- it is an\n* argument in order to avoid having to call SLAMCH frequently.)\n*\n* SCALE1 (output) REAL\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the first eigenvalue. If\n* the eigenvalues are complex, then the eigenvalues are\n* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the\n* exponent range of the machine), SCALE1=SCALE2, and SCALE1\n* will always be positive. If the eigenvalues are real, then\n* the first (real) eigenvalue is WR1 / SCALE1 , but this may\n* overflow or underflow, and in fact, SCALE1 may be zero or\n* less than the underflow threshhold if the exact eigenvalue\n* is sufficiently large.\n*\n* SCALE2 (output) REAL\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the second eigenvalue. If\n* the eigenvalues are complex, then SCALE2=SCALE1. If the\n* eigenvalues are real, then the second (real) eigenvalue is\n* WR2 / SCALE2 , but this may overflow or underflow, and in\n* fact, SCALE2 may be zero or less than the underflow\n* threshhold if the exact eigenvalue is sufficiently large.\n*\n* WR1 (output) REAL\n* If the eigenvalue is real, then WR1 is SCALE1 times the\n* eigenvalue closest to the (2,2) element of A B**(-1). If the\n* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n* part of the eigenvalues.\n*\n* WR2 (output) REAL\n* If the eigenvalue is real, then WR2 is SCALE2 times the\n* other eigenvalue. If the eigenvalue is complex, then\n* WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n*\n* WI (output) REAL\n* If the eigenvalue is real, then WI is zero. If the\n* eigenvalue is complex, then WI is SCALE1 times the imaginary\n* part of the eigenvalues. WI will always be non-negative.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale1, scale2, wr1, wr2, wi = NumRu::Lapack.slag2( a, b, safmin, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_safmin = argv[2];
+ if (argc == 3) {
+ } 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);
+ if (NA_SHAPE1(rblapack_a) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ safmin = (real)NUM2DBL(rblapack_safmin);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+
+ slag2_(a, &lda, b, &ldb, &safmin, &scale1, &scale2, &wr1, &wr2, &wi);
+
+ rblapack_scale1 = rb_float_new((double)scale1);
+ rblapack_scale2 = rb_float_new((double)scale2);
+ rblapack_wr1 = rb_float_new((double)wr1);
+ rblapack_wr2 = rb_float_new((double)wr2);
+ rblapack_wi = rb_float_new((double)wi);
+ return rb_ary_new3(5, rblapack_scale1, rblapack_scale2, rblapack_wr1, rblapack_wr2, rblapack_wi);
+}
+
+void
+init_lapack_slag2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slag2", rblapack_slag2, -1);
+}
diff --git a/ext/slag2d.c b/ext/slag2d.c
new file mode 100644
index 0000000..40103b8
--- /dev/null
+++ b/ext/slag2d.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID slag2d_(integer* m, integer* n, real* sa, integer* ldsa, doublereal* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_slag2d(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_sa;
+ real *sa;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldsa;
+ integer n;
+ integer lda;
+
+ 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 a, info = NumRu::Lapack.slag2d( m, sa, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE\n* PRECISION matrix, A.\n*\n* Note that while it is possible to overflow while converting\n* from double to single, it is not possible to overflow when\n* converting from single to double.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* SA (input) REAL array, dimension (LDSA,N)\n* On entry, the M-by-N coefficient matrix SA.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* A (output) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.slag2d( m, sa, [: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_m = argv[0];
+ rblapack_sa = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ lda = MAX(1,m);
+ if (!NA_IsNArray(rblapack_sa))
+ rb_raise(rb_eArgError, "sa (2th argument) must be NArray");
+ if (NA_RANK(rblapack_sa) != 2)
+ rb_raise(rb_eArgError, "rank of sa (2th argument) must be %d", 2);
+ ldsa = NA_SHAPE0(rblapack_sa);
+ n = NA_SHAPE1(rblapack_sa);
+ if (NA_TYPE(rblapack_sa) != NA_SFLOAT)
+ rblapack_sa = na_change_type(rblapack_sa, NA_SFLOAT);
+ sa = NA_PTR_TYPE(rblapack_sa, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+
+ slag2d_(&m, &n, sa, &ldsa, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_slag2d(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slag2d", rblapack_slag2d, -1);
+}
diff --git a/ext/slags2.c b/ext/slags2.c
new file mode 100644
index 0000000..e58c077
--- /dev/null
+++ b/ext/slags2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID slags2_(logical* upper, real* a1, real* a2, real* a3, real* b1, real* b2, real* b3, real* csu, real* snu, real* csv, real* snv, real* csq, real* snq);
+
+
+static VALUE
+rblapack_slags2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_upper;
+ logical upper;
+ VALUE rblapack_a1;
+ real a1;
+ VALUE rblapack_a2;
+ real a2;
+ VALUE rblapack_a3;
+ real a3;
+ VALUE rblapack_b1;
+ real b1;
+ VALUE rblapack_b2;
+ real b2;
+ VALUE rblapack_b3;
+ real b3;
+ VALUE rblapack_csu;
+ real csu;
+ VALUE rblapack_snu;
+ real snu;
+ VALUE rblapack_csv;
+ real csv;
+ VALUE rblapack_snv;
+ real snv;
+ VALUE rblapack_csq;
+ real csq;
+ VALUE rblapack_snq;
+ real snq;
+
+
+ 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 csu, snu, csv, snv, csq, snq = NumRu::Lapack.slags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n*\n* The rows of the transformed A and B are parallel, where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )\n* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )\n*\n* Z' denotes the transpose of Z.\n*\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) REAL\n* A2 (input) REAL\n* A3 (input) REAL\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) REAL\n* B2 (input) REAL\n* B3 (input) REAL\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) REAL\n* SNU (output) REAL\n* The desired orthogonal matrix U.\n*\n* CSV (output) REAL\n* SNV (output) REAL\n* The desired orthogonal matrix V.\n*\n* CSQ (output) REAL\n* SNQ (output) REAL\n* The desired orthogonal matrix Q.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.slags2( upper, a1, a2, a3, b1, b2, b3, [: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_upper = argv[0];
+ rblapack_a1 = argv[1];
+ rblapack_a2 = argv[2];
+ rblapack_a3 = argv[3];
+ rblapack_b1 = argv[4];
+ rblapack_b2 = argv[5];
+ rblapack_b3 = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ upper = (rblapack_upper == Qtrue);
+ a2 = (real)NUM2DBL(rblapack_a2);
+ b1 = (real)NUM2DBL(rblapack_b1);
+ b3 = (real)NUM2DBL(rblapack_b3);
+ a1 = (real)NUM2DBL(rblapack_a1);
+ b2 = (real)NUM2DBL(rblapack_b2);
+ a3 = (real)NUM2DBL(rblapack_a3);
+
+ slags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
+
+ rblapack_csu = rb_float_new((double)csu);
+ rblapack_snu = rb_float_new((double)snu);
+ rblapack_csv = rb_float_new((double)csv);
+ rblapack_snv = rb_float_new((double)snv);
+ rblapack_csq = rb_float_new((double)csq);
+ rblapack_snq = rb_float_new((double)snq);
+ return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
+}
+
+void
+init_lapack_slags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slags2", rblapack_slags2, -1);
+}
diff --git a/ext/slagtf.c b/ext/slagtf.c
new file mode 100644
index 0000000..10ada87
--- /dev/null
+++ b/ext/slagtf.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID slagtf_(integer* n, real* a, real* lambda, real* b, real* c, real* tol, real* d, integer* in, integer* info);
+
+
+static VALUE
+rblapack_slagtf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lambda;
+ real lambda;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_tol;
+ real tol;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_in;
+ integer *in;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ 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 d, in, info, a, b, c = NumRu::Lapack.slagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n* Purpose\n* =======\n*\n* SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n* tridiagonal matrix and lambda is a scalar, as\n*\n* T - lambda*I = PLU,\n*\n* where P is a permutation matrix, L is a unit lower tridiagonal matrix\n* with at most one non-zero sub-diagonal elements per column and U is\n* an upper triangular matrix with at most two non-zero super-diagonal\n* elements per column.\n*\n* The factorization is obtained by Gaussian elimination with partial\n* pivoting and implicit row scaling.\n*\n* The parameter LAMBDA is included in the routine so that SLAGTF may\n* be used, in conjunction with SLAGTS, to obtain eigenvectors of T by\n* inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input/output) REAL array, dimension (N)\n* On entry, A must contain the diagonal elements of T.\n*\n* On exit, A is overwritten by the n diagonal elements of the\n* upper triangular matrix U of the factorization of T.\n*\n* LAMBDA (input) REAL\n* On entry, the scalar lambda.\n*\n* B (input/output) REAL array, dimension (N-1)\n* On entry, B must contain the (n-1) super-diagonal elements of\n* T.\n*\n* On exit, B is overwritten by the (n-1) super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* C (input/output) REAL array, dimension (N-1)\n* On entry, C must contain the (n-1) sub-diagonal elements of\n* T.\n*\n* On exit, C is overwritten by the (n-1) sub-diagonal elements\n* of the matrix L of the factorization of T.\n*\n* TOL (input) REAL\n* On entry, a relative tolerance used to indicate whether or\n* not the matrix (T - lambda*I) is nearly singular. TOL should\n* normally be chose as approximately the largest relative error\n* in the elements of T. For example, if the elements of T are\n* correct to about 4 significant figures, then TOL should be\n* set to about 5*10**(-4). If TOL is supplied as less than eps,\n* where eps is the relative machine precision, then the value\n* eps is used in place of TOL.\n*\n* D (output) REAL array, dimension (N-2)\n* On exit, D is overwritten by the (n-2) second super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* IN (output) INTEGER array, dimension (N)\n* On exit, IN contains details of the permutation matrix P. If\n* an interchange occurred at the kth step of the elimination,\n* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n* returns the smallest positive integer j such that\n*\n* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n*\n* where norm( A(j) ) denotes the sum of the absolute values of\n* the jth row of the matrix A. If no such j exists then IN(n)\n* is returned as zero. If IN(n) is returned as positive, then a\n* diagonal element of U is small, indicating that\n* (T - lambda*I) is singular or nearly singular,\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -k, the kth argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, in, info, a, b, c = NumRu::Lapack.slagtf( a, lambda, b, c, tol, [: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_a = argv[0];
+ rblapack_lambda = argv[1];
+ rblapack_b = argv[2];
+ rblapack_c = argv[3];
+ rblapack_tol = argv[4];
+ if (argc == 5) {
+ } 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) != 1)
+ rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 1);
+ n = NA_SHAPE0(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_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 1)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_b) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ tol = (real)NUM2DBL(rblapack_tol);
+ lambda = (real)NUM2DBL(rblapack_lambda);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_in = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ in = NA_PTR_TYPE(rblapack_in, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, 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-1;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+
+ slagtf_(&n, a, &lambda, b, c, &tol, d, in, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_in, rblapack_info, rblapack_a, rblapack_b, rblapack_c);
+}
+
+void
+init_lapack_slagtf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slagtf", rblapack_slagtf, -1);
+}
diff --git a/ext/slagtm.c b/ext/slagtm.c
new file mode 100644
index 0000000..64924e4
--- /dev/null
+++ b/ext/slagtm.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID slagtm_(char* trans, integer* n, integer* nrhs, real* alpha, real* dl, real* d, real* du, real* x, integer* ldx, real* beta, real* b, integer* ldb);
+
+
+static VALUE
+rblapack_slagtm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_dl;
+ real *dl;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_du;
+ real *du;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldx;
+ integer nrhs;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.slagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* SLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A'* X + beta * B\n* = 'C': 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 matrices X and B.\n*\n* ALPHA (input) REAL\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) REAL array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) REAL array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) REAL array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) REAL\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.slagtm( trans, alpha, dl, d, du, x, beta, b, [: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_trans = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_x = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ 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_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);
+ 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_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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*);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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*);
+ beta = (real)NUM2DBL(rblapack_beta);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ slagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_slagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slagtm", rblapack_slagtm, -1);
+}
diff --git a/ext/slagts.c b/ext/slagts.c
new file mode 100644
index 0000000..16c1df6
--- /dev/null
+++ b/ext/slagts.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID slagts_(integer* job, integer* n, real* a, real* b, real* c, real* d, integer* in, real* y, real* tol, integer* info);
+
+
+static VALUE
+rblapack_slagts(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ integer job;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_in;
+ integer *in;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_tol;
+ real tol;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+
+ 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, y, tol = NumRu::Lapack.slagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n* Purpose\n* =======\n*\n* SLAGTS may be used to solve one of the systems of equations\n*\n* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,\n*\n* where T is an n by n tridiagonal matrix, for x, following the\n* factorization of (T - lambda*I) as\n*\n* (T - lambda*I) = P*L*U ,\n*\n* by routine SLAGTF. The choice of equation to be solved is\n* controlled by the argument JOB, and in each case there is an option\n* to perturb zero or very small diagonal elements of U, this option\n* being intended for use in applications such as inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* Specifies the job to be performed by SLAGTS as follows:\n* = 1: The equations (T - lambda*I)x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -1: The equations (T - lambda*I)x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n* = 2: The equations (T - lambda*I)'x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -2: The equations (T - lambda*I)'x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input) REAL array, dimension (N)\n* On entry, A must contain the diagonal elements of U as\n* returned from SLAGTF.\n*\n* B (input) REAL array, dimension (N-1)\n* On entry, B must contain the first super-diagonal elements of\n* U as returned from SLAGTF.\n*\n* C (input) REAL array, dimension (N-1)\n* On entry, C must contain the sub-diagonal elements of L as\n* returned from SLAGTF.\n*\n* D (input) REAL array, dimension (N-2)\n* On entry, D must contain the second super-diagonal elements\n* of U as returned from SLAGTF.\n*\n* IN (input) INTEGER array, dimension (N)\n* On entry, IN must contain details of the matrix P as returned\n* from SLAGTF.\n*\n* Y (input/output) REAL array, dimension (N)\n* On entry, the right hand side vector y.\n* On exit, Y is overwritten by the solution vector x.\n*\n* TOL (input/output) REAL\n* On entry, with JOB .lt. 0, TOL should be the minimum\n* perturbation to be made to very small diagonal elements of U.\n* TOL should normally be chosen as about eps*norm(U), where eps\n* is the relative machine precision, but if TOL is supplied as\n* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n* If JOB .gt. 0 then TOL is not referenced.\n*\n* On exit, TOL is changed as described above, only if TOL is\n* non-positive on entry. Otherwise TOL is unchanged.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -i, the i-th argument had an illegal value\n* .gt. 0: overflow would occur when computing the INFO(th)\n* element of the solution vector x. This can only occur\n* when JOB is supplied as positive and either means\n* that a diagonal element of U is very small, or that\n* the elements of the right-hand side vector y are very\n* large.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, y, tol = NumRu::Lapack.slagts( job, a, b, c, d, in, y, tol, [: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_job = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_c = argv[3];
+ rblapack_d = argv[4];
+ rblapack_in = argv[5];
+ rblapack_y = argv[6];
+ rblapack_tol = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = NUM2INT(rblapack_job);
+ if (!NA_IsNArray(rblapack_in))
+ rb_raise(rb_eArgError, "in (6th argument) must be NArray");
+ if (NA_RANK(rblapack_in) != 1)
+ rb_raise(rb_eArgError, "rank of in (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_in);
+ if (NA_TYPE(rblapack_in) != NA_LINT)
+ rblapack_in = na_change_type(rblapack_in, NA_LINT);
+ in = NA_PTR_TYPE(rblapack_in, integer*);
+ tol = (real)NUM2DBL(rblapack_tol);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (2th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be the same as shape 0 of in");
+ 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_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of in");
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 1)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_b) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
+ 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_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);
+ if (NA_SHAPE0(rblapack_d) != (n-2))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", n-2);
+ 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_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ slagts_(&job, &n, a, b, c, d, in, y, &tol, &info);
+
+ rblapack_info = INT2NUM(info);
+ rblapack_tol = rb_float_new((double)tol);
+ return rb_ary_new3(3, rblapack_info, rblapack_y, rblapack_tol);
+}
+
+void
+init_lapack_slagts(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slagts", rblapack_slagts, -1);
+}
diff --git a/ext/slagv2.c b/ext/slagv2.c
new file mode 100644
index 0000000..a868f71
--- /dev/null
+++ b/ext/slagv2.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID slagv2_(real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* csl, real* snl, real* csr, real* snr);
+
+
+static VALUE
+rblapack_slagv2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_csl;
+ real csl;
+ VALUE rblapack_snl;
+ real snl;
+ VALUE rblapack_csr;
+ real csr;
+ VALUE rblapack_snr;
+ real snr;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer ldb;
+
+ 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 alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.slagv2( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n* Purpose\n* =======\n*\n* SLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n* matrix pencil (A,B) where B is upper triangular. This routine\n* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n* SNR such that\n*\n* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n* types), then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],\n*\n* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n* then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]\n*\n* where b11 >= b22 > 0.\n*\n*\n\n* Arguments\n* =========\n*\n* A (input/output) REAL array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A.\n* On exit, A is overwritten by the ``A-part'' of the\n* generalized Schur form.\n*\n* LDA (input) INTEGER\n* THe leading dimension of the array A. LDA >= 2.\n*\n* B (input/output) REAL array, dimension (LDB, 2)\n* On entry, the upper triangular 2 x 2 matrix B.\n* On exit, B is overwritten by the ``B-part'' of the\n* generalized Schur form.\n*\n* LDB (input) INTEGER\n* THe leading dimension of the array B. LDB >= 2.\n*\n* ALPHAR (output) REAL array, dimension (2)\n* ALPHAI (output) REAL array, dimension (2)\n* BETA (output) REAL array, dimension (2)\n* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may\n* be zero.\n*\n* CSL (output) REAL\n* The cosine of the left rotation matrix.\n*\n* SNL (output) REAL\n* The sine of the left rotation matrix.\n*\n* CSR (output) REAL\n* The cosine of the right rotation matrix.\n*\n* SNR (output) REAL\n* The sine of the right rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.slagv2( 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);
+ if (NA_SHAPE1(rblapack_a) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
+ 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_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);
+ if (NA_SHAPE1(rblapack_b) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = 2;
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = 2;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ slagv2_(a, &lda, b, &ldb, alphar, alphai, beta, &csl, &snl, &csr, &snr);
+
+ rblapack_csl = rb_float_new((double)csl);
+ rblapack_snl = rb_float_new((double)snl);
+ rblapack_csr = rb_float_new((double)csr);
+ rblapack_snr = rb_float_new((double)snr);
+ return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_csl, rblapack_snl, rblapack_csr, rblapack_snr, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_slagv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slagv2", rblapack_slagv2, -1);
+}
diff --git a/ext/slahqr.c b/ext/slahqr.c
new file mode 100644
index 0000000..81a249b
--- /dev/null
+++ b/ext/slahqr.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID slahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_slahqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer ldh;
+ 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 wr, wi, info, h, z = NumRu::Lapack.slahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* SLAHQR is an auxiliary routine called by SHSEQR to update the\n* eigenvalues and Schur decomposition already computed by SHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper quasi-triangular in\n* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n* ILO = 1). SLAHQR works primarily with the Hessenberg\n* submatrix in rows and columns ILO to IHI, but applies\n* transformations to all of H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n* quasi-triangular in rows and columns ILO:IHI, with any\n* 2-by-2 diagonal blocks in standard form. If INFO is zero\n* and WANTT is .FALSE., the contents of H are unspecified on\n* exit. The output state of H if INFO is nonzero is given\n* below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues ILO to IHI are stored in the corresponding\n* elements of WR and WI. If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with WR(i) = H(i,i), and, if\n* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by SHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: If INFO = i, SLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of WR and WI\n* contain those eigenvalues which have been\n* successfully computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix rows\n* and columns ILO thorugh INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of SLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, info, h, z = NumRu::Lapack.slahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_iloz = argv[5];
+ rblapack_ihiz = argv[6];
+ rblapack_z = argv[7];
+ rblapack_ldz = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = NUM2INT(rblapack_ldz);
+ wantz = (rblapack_wantz == Qtrue);
+ iloz = NUM2INT(rblapack_iloz);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? n : 0;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ slahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_wr, rblapack_wi, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slahqr", rblapack_slahqr, -1);
+}
diff --git a/ext/slahr2.c b/ext/slahr2.c
new file mode 100644
index 0000000..f27d271
--- /dev/null
+++ b/ext/slahr2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID slahr2_(integer* n, integer* k, integer* nb, real* a, integer* lda, real* tau, real* t, integer* ldt, real* y, integer* ldy);
+
+
+static VALUE
+rblapack_slahr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.slahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by SGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) REAL array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) REAL array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) REAL array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.slahr2( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ ldy = n;
+ k = NUM2INT(rblapack_k);
+ ldt = nb;
+ 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-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ 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__;
+
+ slahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_slahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slahr2", rblapack_slahr2, -1);
+}
diff --git a/ext/slahrd.c b/ext/slahrd.c
new file mode 100644
index 0000000..0c9871a
--- /dev/null
+++ b/ext/slahrd.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID slahrd_(integer* n, integer* k, integer* nb, real* a, integer* lda, real* tau, real* t, integer* ldt, real* y, integer* ldy);
+
+
+static VALUE
+rblapack_slahrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.slahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* SLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine SLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) REAL array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) REAL array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) REAL array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.slahrd( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ lda = n;
+ ldt = nb;
+ k = NUM2INT(rblapack_k);
+ ldy = n;
+ 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);
+ if (NA_SHAPE0(rblapack_a) != lda)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be n");
+ if (NA_SHAPE1(rblapack_a) != (n-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ 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__;
+
+ slahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_slahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slahrd", rblapack_slahrd, -1);
+}
diff --git a/ext/slaic1.c b/ext/slaic1.c
new file mode 100644
index 0000000..33a0ac3
--- /dev/null
+++ b/ext/slaic1.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID slaic1_(integer* job, integer* j, real* x, real* sest, real* w, real* gamma, real* sestpr, real* s, real* c);
+
+
+static VALUE
+rblapack_slaic1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ integer job;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_sest;
+ real sest;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_gamma;
+ real gamma;
+ VALUE rblapack_sestpr;
+ real sestpr;
+ VALUE rblapack_s;
+ real s;
+ VALUE rblapack_c;
+ real c;
+
+ integer j;
+
+ 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 sestpr, s, c = NumRu::Lapack.slaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* SLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then SLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]\n* [ gamma ]\n*\n* where alpha = x'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) REAL array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) REAL\n* Estimated singular value of j by j matrix L\n*\n* W (input) REAL array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) REAL\n* The diagonal element gamma.\n*\n* SESTPR (output) REAL\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) REAL\n* Sine needed in forming xhat.\n*\n* C (output) REAL\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.slaic1( job, x, sest, w, gamma, [: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_job = argv[0];
+ rblapack_x = argv[1];
+ rblapack_sest = argv[2];
+ rblapack_w = argv[3];
+ rblapack_gamma = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = NUM2INT(rblapack_job);
+ sest = (real)NUM2DBL(rblapack_sest);
+ gamma = (real)NUM2DBL(rblapack_gamma);
+ 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);
+ j = NA_SHAPE0(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_w))
+ rb_raise(rb_eArgError, "w (4th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != j)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+
+ slaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
+
+ rblapack_sestpr = rb_float_new((double)sestpr);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_c = rb_float_new((double)c);
+ return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
+}
+
+void
+init_lapack_slaic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaic1", rblapack_slaic1, -1);
+}
diff --git a/ext/slaln2.c b/ext/slaln2.c
new file mode 100644
index 0000000..4d635b4
--- /dev/null
+++ b/ext/slaln2.c
@@ -0,0 +1,120 @@
+#include "rb_lapack.h"
+
+extern VOID slaln2_(logical* ltrans, integer* na, integer* nw, real* smin, real* ca, real* a, integer* lda, real* d1, real* d2, real* b, integer* ldb, real* wr, real* wi, real* x, integer* ldx, real* scale, real* xnorm, integer* info);
+
+
+static VALUE
+rblapack_slaln2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ltrans;
+ logical ltrans;
+ VALUE rblapack_smin;
+ real smin;
+ VALUE rblapack_ca;
+ real ca;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_d1;
+ real d1;
+ VALUE rblapack_d2;
+ real d2;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_wr;
+ real wr;
+ VALUE rblapack_wi;
+ real wi;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_xnorm;
+ real xnorm;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer na;
+ integer ldb;
+ integer nw;
+ 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 x, scale, xnorm, info = NumRu::Lapack.slaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLALN2 solves a system of the form (ca A - w D ) X = s B\n* or (ca A' - w D) X = s B with possible scaling (\"s\") and\n* perturbation of A. (A' means A-transpose.)\n*\n* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n* real diagonal matrix, w is a real or complex value, and X and B are\n* NA x 1 matrices -- real if w is real, complex if w is complex. NA\n* may be 1 or 2.\n*\n* If w is complex, X and B are represented as NA x 2 matrices,\n* the first column of each being the real part and the second\n* being the imaginary part.\n*\n* \"s\" is a scaling factor (.LE. 1), computed by SLALN2, which is\n* so chosen that X can be computed without overflow. X is further\n* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n* than overflow.\n*\n* If both singular values of (ca A - w D) are less than SMIN,\n* SMIN*identity will be used instead of (ca A - w D). If only one\n* singular value is less than SMIN, one element of (ca A - w D) will be\n* perturbed enough to make the smallest singular value roughly SMIN.\n* If both singular values are at least SMIN, (ca A - w D) will not be\n* perturbed. In any case, the perturbation will be at most some small\n* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values\n* are computed by infinity-norm approximations, and thus will only be\n* correct to a factor of 2 or so.\n*\n* Note: all input quantities are assumed to be smaller than overflow\n* by a reasonable factor. (See BIGNUM.)\n*\n\n* Arguments\n* ==========\n*\n* LTRANS (input) LOGICAL\n* =.TRUE.: A-transpose will be used.\n* =.FALSE.: A will be used (not transposed.)\n*\n* NA (input) INTEGER\n* The size of the matrix A. It may (only) be 1 or 2.\n*\n* NW (input) INTEGER\n* 1 if \"w\" is real, 2 if \"w\" is complex. It may only be 1\n* or 2.\n*\n* SMIN (input) REAL\n* The desired lower bound on the singular values of A. This\n* should be a safe distance away from underflow or overflow,\n* say, between (underflow/machine precision) and (machine\n* precision * overflow ). (See BIGNUM and ULP.)\n*\n* CA (input) REAL\n* The coefficient c, which A is multiplied by.\n*\n* A (input) REAL array, dimension (LDA,NA)\n* The NA x NA matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. It must be at least NA.\n*\n* D1 (input) REAL\n* The 1,1 element in the diagonal matrix D.\n*\n* D2 (input) REAL\n* The 2,2 element in the diagonal matrix D. Not used if NW=1.\n*\n* B (input) REAL array, dimension (LDB,NW)\n* The NA x NW matrix B (right-hand side). If NW=2 (\"w\" is\n* complex), column 1 contains the real part of B and column 2\n* contains the imaginary part.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. It must be at least NA.\n*\n* WR (input) REAL\n* The real part of the scalar \"w\".\n*\n* WI (input) REAL\n* The imaginary part of the scalar \"w\". Not used if NW=1.\n*\n* X (output) REAL array, dimension (LDX,NW)\n* The NA x NW matrix X (unknowns), as computed by SLALN2.\n* If NW=2 (\"w\" is complex), on exit, column 1 will contain\n* the real part of X and column 2 will contain the imaginary\n* part.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. It must be at least NA.\n*\n* SCALE (output) REAL\n* The scale factor that B must be multiplied by to insure\n* that overflow does not occur when computing X. Thus,\n* (ca A - w D) X will be SCALE*B, not B (ignoring\n* perturbations of A.) It will be at most 1.\n*\n* XNORM (output) REAL\n* The infinity-norm of X, when X is regarded as an NA x NW\n* real matrix.\n*\n* INFO (output) INTEGER\n* An error flag. It will be set to zero if no error occurs,\n* a negative number if an argument is in error, or a positive\n* number if ca A - w D had to be perturbed.\n* The possible values are:\n* = 0: No error occurred, and (ca A - w D) did not have to be\n* perturbed.\n* = 1: (ca A - w D) had to be perturbed to make its smallest\n* (or only) singular value greater than SMIN.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, scale, xnorm, info = NumRu::Lapack.slaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_ltrans = argv[0];
+ rblapack_smin = argv[1];
+ rblapack_ca = argv[2];
+ rblapack_a = argv[3];
+ rblapack_d1 = argv[4];
+ rblapack_d2 = argv[5];
+ rblapack_b = argv[6];
+ rblapack_wr = argv[7];
+ rblapack_wi = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ltrans = (rblapack_ltrans == Qtrue);
+ ca = (real)NUM2DBL(rblapack_ca);
+ d1 = (real)NUM2DBL(rblapack_d1);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nw = 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*);
+ wi = (real)NUM2DBL(rblapack_wi);
+ smin = (real)NUM2DBL(rblapack_smin);
+ d2 = (real)NUM2DBL(rblapack_d2);
+ 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);
+ na = 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*);
+ ldx = na;
+ wr = (real)NUM2DBL(rblapack_wr);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nw;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+
+ slaln2_(<rans, &na, &nw, &smin, &ca, a, &lda, &d1, &d2, b, &ldb, &wr, &wi, x, &ldx, &scale, &xnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_xnorm = rb_float_new((double)xnorm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_x, rblapack_scale, rblapack_xnorm, rblapack_info);
+}
+
+void
+init_lapack_slaln2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaln2", rblapack_slaln2, -1);
+}
diff --git a/ext/slals0.c b/ext/slals0.c
new file mode 100644
index 0000000..8cd8479
--- /dev/null
+++ b/ext/slals0.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID slals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, real* b, integer* ldb, real* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* poles, real* difl, real* difr, real* z, integer* k, real* c, real* s, real* work, integer* info);
+
+
+static VALUE
+rblapack_slals0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_poles;
+ real *poles;
+ VALUE rblapack_difl;
+ real *difl;
+ VALUE rblapack_difr;
+ real *difr;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_s;
+ real s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *bx;
+ real *work;
+
+ integer ldb;
+ integer nrhs;
+ integer n;
+ integer ldgcol;
+ integer ldgnum;
+ integer k;
+ integer ldbx;
+
+ 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, b = NumRu::Lapack.slals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) REAL array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) REAL array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) REAL array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) REAL array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) REAL array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) REAL array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) REAL array, dimension ( K )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.slals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_b = argv[4];
+ rblapack_perm = argv[5];
+ rblapack_givptr = argv[6];
+ rblapack_givcol = argv[7];
+ rblapack_givnum = argv[8];
+ rblapack_poles = argv[9];
+ rblapack_difl = argv[10];
+ rblapack_difr = argv[11];
+ rblapack_z = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ 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*);
+ givptr = NUM2INT(rblapack_givptr);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
+ ldgnum = NA_SHAPE0(rblapack_givnum);
+ if (NA_SHAPE1(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
+ if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 1)
+ rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_difl);
+ if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, real*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (13th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ s = (real)NUM2DBL(rblapack_s);
+ nl = NUM2INT(rblapack_nl);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_perm);
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_poles) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
+ if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, real*);
+ c = (real)NUM2DBL(rblapack_c);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_difr) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
+ if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, real*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_givcol);
+ if (NA_SHAPE1(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ ldbx = n;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ bx = ALLOC_N(real, (ldbx)*(nrhs));
+ work = ALLOC_N(real, (k));
+
+ slals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, &info);
+
+ free(bx);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_slals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slals0", rblapack_slals0, -1);
+}
diff --git a/ext/slalsa.c b/ext/slalsa.c
new file mode 100644
index 0000000..71503ef
--- /dev/null
+++ b/ext/slalsa.c
@@ -0,0 +1,270 @@
+#include "rb_lapack.h"
+
+extern VOID slalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, real* b, integer* ldb, real* bx, integer* ldbx, real* u, integer* ldu, real* vt, integer* k, real* difl, real* difr, real* z, real* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, real* givnum, real* c, real* s, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slalsa(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_difl;
+ real *difl;
+ VALUE rblapack_difr;
+ real *difr;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_poles;
+ real *poles;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_bx;
+ real *bx;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *work;
+ integer *iwork;
+
+ integer ldb;
+ integer nrhs;
+ integer ldu;
+ integer smlsiz;
+ integer n;
+ integer nlvl;
+ integer ldgcol;
+ integer ldbx;
+
+ 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 bx, info, b = NumRu::Lapack.slalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, SLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by SLALSA.\n*\n\n* Arguments\n* =========\n*\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) REAL array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) REAL array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) REAL array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) REAL array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) REAL array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) REAL array.\n* The dimension must be at least N.\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.slalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_b = argv[1];
+ rblapack_u = argv[2];
+ rblapack_vt = argv[3];
+ rblapack_k = argv[4];
+ rblapack_difl = argv[5];
+ rblapack_difr = argv[6];
+ rblapack_z = argv[7];
+ rblapack_poles = argv[8];
+ rblapack_givptr = argv[9];
+ rblapack_givcol = argv[10];
+ rblapack_perm = argv[11];
+ rblapack_givnum = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (3th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ smlsiz = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (5th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (14th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
+ 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_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);
+ 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*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (15th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_vt) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
+ if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, real*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, real*);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 2)
+ rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_perm);
+ if (NA_SHAPE1(rblapack_perm) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ ldbx = n;
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 2)
+ rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difl) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difl) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, real*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != ldgcol)
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
+ if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_z) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ {
+ int shape[2];
+ shape[0] = ldbx;
+ shape[1] = nrhs;
+ rblapack_bx = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ bx = NA_PTR_TYPE(rblapack_bx, real*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (n));
+ iwork = ALLOC_N(integer, (3 * n));
+
+ slalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_slalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slalsa", rblapack_slalsa, -1);
+}
diff --git a/ext/slalsd.c b/ext/slalsd.c
new file mode 100644
index 0000000..16ff1ff
--- /dev/null
+++ b/ext/slalsd.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern VOID slalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb, real* rcond, integer* rank, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slalsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer nlvl;
+
+ 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 rank, info, d, e, b = NumRu::Lapack.slalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) REAL array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) REAL\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) REAL array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n*\n* IWORK (workspace) INTEGER array, dimension at least\n* (3*N*NLVL + 11*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.slalsd( uplo, smlsiz, d, e, b, rcond, [: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_smlsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_b = argv[4];
+ rblapack_rcond = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_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 (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*);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ rcond = (real)NUM2DBL(rblapack_rcond);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ nlvl = MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2)));
+ iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
+
+ slalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_slalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slalsd", rblapack_slalsd, -1);
+}
diff --git a/ext/slamrg.c b/ext/slamrg.c
new file mode 100644
index 0000000..ec64618
--- /dev/null
+++ b/ext/slamrg.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID slamrg_(integer* n1, integer* n2, real* a, integer* strd1, integer* strd2, integer* index);
+
+
+static VALUE
+rblapack_slamrg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_strd1;
+ integer strd1;
+ VALUE rblapack_strd2;
+ integer strd2;
+ VALUE rblapack_index;
+ integer *index;
+
+
+ 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 index = NumRu::Lapack.slamrg( n1, n2, a, strd1, strd2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )\n\n* Purpose\n* =======\n*\n* SLAMRG will create a permutation list which will merge the elements\n* of A (which is composed of two independently sorted sets) into a\n* single set which is sorted in ascending order.\n*\n\n* Arguments\n* =========\n*\n* N1 (input) INTEGER\n* N2 (input) INTEGER\n* These arguements contain the respective lengths of the two\n* sorted lists to be merged.\n*\n* A (input) REAL array, dimension (N1+N2)\n* The first N1 elements of A contain a list of numbers which\n* are sorted in either ascending or descending order. Likewise\n* for the final N2 elements.\n*\n* STRD1 (input) INTEGER\n* STRD2 (input) INTEGER\n* These are the strides to be taken through the array A.\n* Allowable strides are 1 and -1. They indicate whether a\n* subset of A is sorted in ascending (STRDx = 1) or descending\n* (STRDx = -1) order.\n*\n* INDEX (output) INTEGER array, dimension (N1+N2)\n* On exit this array will contain a permutation such that\n* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n* sorted in ascending order.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IND1, IND2, N1SV, N2SV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n index = NumRu::Lapack.slamrg( n1, n2, a, strd1, strd2, [: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_n1 = argv[0];
+ rblapack_n2 = argv[1];
+ rblapack_a = argv[2];
+ rblapack_strd1 = argv[3];
+ rblapack_strd2 = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n1 = NUM2INT(rblapack_n1);
+ strd1 = NUM2INT(rblapack_strd1);
+ n2 = NUM2INT(rblapack_n2);
+ strd2 = NUM2INT(rblapack_strd2);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (3th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n1+n2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n1+n2);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n1+n2;
+ rblapack_index = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ index = NA_PTR_TYPE(rblapack_index, integer*);
+
+ slamrg_(&n1, &n2, a, &strd1, &strd2, index);
+
+ return rblapack_index;
+}
+
+void
+init_lapack_slamrg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slamrg", rblapack_slamrg, -1);
+}
diff --git a/ext/slaneg.c b/ext/slaneg.c
new file mode 100644
index 0000000..9ea36d0
--- /dev/null
+++ b/ext/slaneg.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern integer slaneg_(integer* n, real* d, real* lld, real* sigma, real* pivmin, integer* r);
+
+
+static VALUE
+rblapack_slaneg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_lld;
+ real *lld;
+ VALUE rblapack_sigma;
+ real sigma;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_r;
+ integer r;
+ VALUE rblapack___out__;
+ integer __out__;
+
+ 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 __out__ = NumRu::Lapack.slaneg( d, lld, sigma, pivmin, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n* Purpose\n* =======\n*\n* SLANEG computes the Sturm count, the number of negative pivots\n* encountered while factoring tridiagonal T - sigma I = L D L^T.\n* This implementation works directly on the factors without forming\n* the tridiagonal matrix T. The Sturm count is also the number of\n* eigenvalues of T less than sigma.\n*\n* This routine is called from SLARRB.\n*\n* The current routine does not use the PIVMIN parameter but rather\n* requires IEEE-754 propagation of Infinities and NaNs. This\n* routine also has no input range restrictions but does require\n* default exception handling such that x/0 produces Inf when x is\n* non-zero, and Inf/Inf produces NaN. For more information, see:\n*\n* Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n* Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624\n* (Tech report version in LAWN 172 with the same title.)\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) REAL array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* SIGMA (input) REAL \n* Shift amount in T - sigma I = L D L^T.\n*\n* PIVMIN (input) REAL \n* The minimum pivot in the Sturm sequence. May be used\n* when zero pivots are encountered on non-IEEE-754\n* architectures.\n*\n* R (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, University of California, Berkeley, USA\n* Jason Riedy, 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 __out__ = NumRu::Lapack.slaneg( d, lld, sigma, pivmin, r, [: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_d = argv[0];
+ rblapack_lld = argv[1];
+ rblapack_sigma = argv[2];
+ rblapack_pivmin = argv[3];
+ rblapack_r = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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*);
+ sigma = (real)NUM2DBL(rblapack_sigma);
+ r = NUM2INT(rblapack_r);
+ if (!NA_IsNArray(rblapack_lld))
+ rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
+ if (NA_RANK(rblapack_lld) != 1)
+ rb_raise(rb_eArgError, "rank of lld (2th 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_SFLOAT)
+ rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
+ lld = NA_PTR_TYPE(rblapack_lld, real*);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+
+ __out__ = slaneg_(&n, d, lld, &sigma, &pivmin, &r);
+
+ rblapack___out__ = INT2NUM(__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slaneg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaneg", rblapack_slaneg, -1);
+}
diff --git a/ext/slangb.c b/ext/slangb.c
new file mode 100644
index 0000000..c837816
--- /dev/null
+++ b/ext/slangb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern real slangb_(char* norm, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* work);
+
+
+static VALUE
+rblapack_slangb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* SLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* SLANGB returns the value\n*\n* SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slangb( norm, kl, ku, ab, [: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_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slangb", rblapack_slangb, -1);
+}
diff --git a/ext/slange.c b/ext/slange.c
new file mode 100644
index 0000000..94cb738
--- /dev/null
+++ b/ext/slange.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern real slange_(char* norm, integer* m, integer* n, real* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_slange(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real matrix A.\n*\n* Description\n* ===========\n*\n* SLANGE returns the value\n*\n* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* SLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* SLANGE is set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slange( norm, m, a, [: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_norm = argv[0];
+ rblapack_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = 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*);
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slange_(&norm, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slange", rblapack_slange, -1);
+}
diff --git a/ext/slangt.c b/ext/slangt.c
new file mode 100644
index 0000000..b94ddae
--- /dev/null
+++ b/ext/slangt.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern real slangt_(char* norm, integer* n, real* dl, real* d, real* du);
+
+
+static VALUE
+rblapack_slangt(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___out__;
+ real __out__;
+
+ 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 __out__ = NumRu::Lapack.slangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* SLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* SLANGT returns the value\n*\n* SLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANGT is\n* set to zero.\n*\n* DL (input) REAL array, dimension (N-1)\n* The (n-1) sub-diagonal 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) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slangt( norm, dl, d, du, [: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_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ if (argc == 4) {
+ } 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_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_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*);
+
+ __out__ = slangt_(&norm, &n, dl, d, du);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slangt", rblapack_slangt, -1);
+}
diff --git a/ext/slanhs.c b/ext/slanhs.c
new file mode 100644
index 0000000..f73dc3c
--- /dev/null
+++ b/ext/slanhs.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern real slanhs_(char* norm, integer* n, real* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_slanhs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* SLANHS returns the value\n*\n* SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANHS is\n* set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slanhs( norm, 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_norm = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slanhs_(&norm, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slanhs", rblapack_slanhs, -1);
+}
diff --git a/ext/slansb.c b/ext/slansb.c
new file mode 100644
index 0000000..0bdbd50
--- /dev/null
+++ b/ext/slansb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern real slansb_(char* norm, char* uplo, integer* n, integer* k, real* ab, integer* ldab, real* work);
+
+
+static VALUE
+rblapack_slansb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* SLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* SLANSB returns the value\n*\n* SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansb( norm, uplo, k, ab, [: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_k = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ k = NUM2INT(rblapack_k);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slansb", rblapack_slansb, -1);
+}
diff --git a/ext/slansf.c b/ext/slansf.c
new file mode 100644
index 0000000..45c44b3
--- /dev/null
+++ b/ext/slansf.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern real slansf_(char* norm, char* transr, char* uplo, integer* n, real* a, real* work);
+
+
+static VALUE
+rblapack_slansf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+
+ 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 __out__ = NumRu::Lapack.slansf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* SLANSF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* SLANSF returns the value\n*\n* SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSF as described\n* above.\n*\n* TRANSR (input) CHARACTER*1\n* Specifies whether the RFP format of A is normal or\n* transposed format.\n* = 'N': RFP format is Normal;\n* = 'T': RFP format is Transpose.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* = 'U': RFP A came from an upper triangular matrix;\n* = 'L': RFP A came from a lower triangular matrix.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSF is\n* set to zero.\n*\n* A (input) REAL array, dimension ( N*(N+1)/2 );\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* part of the symmetric matrix A stored in RFP format. See the\n* \"Notes\" below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansf( norm, transr, uplo, n, a, [: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_norm = argv[0];
+ rblapack_transr = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));
+
+ __out__ = slansf_(&norm, &transr, &uplo, &n, a, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slansf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slansf", rblapack_slansf, -1);
+}
diff --git a/ext/slansp.c b/ext/slansp.c
new file mode 100644
index 0000000..35f7bb3
--- /dev/null
+++ b/ext/slansp.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern real slansp_(char* norm, char* uplo, integer* n, real* ap, real* work);
+
+
+static VALUE
+rblapack_slansp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* SLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* SLANSP returns the value\n*\n* SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSP is\n* set to zero.\n*\n* AP (input) REAL array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansp( norm, uplo, 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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 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);
+ 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*);
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slansp_(&norm, &uplo, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slansp", rblapack_slansp, -1);
+}
diff --git a/ext/slanst.c b/ext/slanst.c
new file mode 100644
index 0000000..639aaa7
--- /dev/null
+++ b/ext/slanst.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern real slanst_(char* norm, integer* n, real* d, real* e);
+
+
+static VALUE
+rblapack_slanst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack___out__;
+ real __out__;
+
+ 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 __out__ = NumRu::Lapack.slanst( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANST( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* SLANST returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* SLANST returns the value\n*\n* SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANST as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANST is\n* set to zero.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slanst( norm, d, e, [: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_norm = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+
+ __out__ = slanst_(&norm, &n, d, e);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slanst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slanst", rblapack_slanst, -1);
+}
diff --git a/ext/slansy.c b/ext/slansy.c
new file mode 100644
index 0000000..f61d5c0
--- /dev/null
+++ b/ext/slansy.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern real slansy_(char* norm, char* uplo, integer* n, real* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_slansy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A.\n*\n* Description\n* ===========\n*\n* SLANSY returns the value\n*\n* SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSY is\n* set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansy( norm, uplo, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slansy_(&norm, &uplo, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slansy", rblapack_slansy, -1);
+}
diff --git a/ext/slantb.c b/ext/slantb.c
new file mode 100644
index 0000000..4c76370
--- /dev/null
+++ b/ext/slantb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern real slantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, real* ab, integer* ldab, real* work);
+
+
+static VALUE
+rblapack_slantb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* SLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* SLANTB returns the value\n*\n* SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slantb( norm, uplo, diag, k, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_k = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = lsame_(&norm,"I") ? n : 0;
+ k = NUM2INT(rblapack_k);
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slantb", rblapack_slantb, -1);
+}
diff --git a/ext/slantp.c b/ext/slantp.c
new file mode 100644
index 0000000..63db191
--- /dev/null
+++ b/ext/slantp.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern real slantp_(char* norm, char* uplo, char* diag, integer* n, real* ap, real* work);
+
+
+static VALUE
+rblapack_slantp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* SLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* SLANTP returns the value\n*\n* SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANTP is\n* set to zero.\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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slantp( norm, uplo, diag, n, ap, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_ap = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ 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) != (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*);
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slantp_(&norm, &uplo, &diag, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slantp", rblapack_slantp, -1);
+}
diff --git a/ext/slantr.c b/ext/slantr.c
new file mode 100644
index 0000000..ff6fa13
--- /dev/null
+++ b/ext/slantr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern real slantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, real* a, integer* lda, real* work);
+
+
+static VALUE
+rblapack_slantr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack___out__;
+ real __out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.slantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* SLANTR returns the value\n*\n* SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slantr( norm, uplo, diag, m, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_m = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ __out__ = slantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slantr", rblapack_slantr, -1);
+}
diff --git a/ext/slanv2.c b/ext/slanv2.c
new file mode 100644
index 0000000..8fc56f3
--- /dev/null
+++ b/ext/slanv2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID slanv2_(real* a, real* b, real* c, real* d, real* rt1r, real* rt1i, real* rt2r, real* rt2i, real* cs, real* sn);
+
+
+static VALUE
+rblapack_slanv2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real a;
+ VALUE rblapack_b;
+ real b;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_d;
+ real d;
+ VALUE rblapack_rt1r;
+ real rt1r;
+ VALUE rblapack_rt1i;
+ real rt1i;
+ VALUE rblapack_rt2r;
+ real rt2r;
+ VALUE rblapack_rt2i;
+ real rt2i;
+ VALUE rblapack_cs;
+ real cs;
+ VALUE rblapack_sn;
+ real sn;
+
+
+ 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 rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.slanv2( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n* Purpose\n* =======\n*\n* SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n* matrix in standard form:\n*\n* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]\n* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]\n*\n* where either\n* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n* conjugate eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* A (input/output) REAL \n* B (input/output) REAL \n* C (input/output) REAL \n* D (input/output) REAL \n* On entry, the elements of the input matrix.\n* On exit, they are overwritten by the elements of the\n* standardised Schur form.\n*\n* RT1R (output) REAL \n* RT1I (output) REAL \n* RT2R (output) REAL \n* RT2I (output) REAL \n* The real and imaginary parts of the eigenvalues. If the\n* eigenvalues are a complex conjugate pair, RT1I > 0.\n*\n* CS (output) REAL \n* SN (output) REAL \n* Parameters of the rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Modified by V. Sima, Research Institute for Informatics, Bucharest,\n* Romania, to reduce the risk of cancellation errors,\n* when computing real eigenvalues, and to ensure, if possible, that\n* abs(RT1R) >= abs(RT2R).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.slanv2( a, b, c, d, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a = (real)NUM2DBL(rblapack_a);
+ c = (real)NUM2DBL(rblapack_c);
+ b = (real)NUM2DBL(rblapack_b);
+ d = (real)NUM2DBL(rblapack_d);
+
+ slanv2_(&a, &b, &c, &d, &rt1r, &rt1i, &rt2r, &rt2i, &cs, &sn);
+
+ rblapack_rt1r = rb_float_new((double)rt1r);
+ rblapack_rt1i = rb_float_new((double)rt1i);
+ rblapack_rt2r = rb_float_new((double)rt2r);
+ rblapack_rt2i = rb_float_new((double)rt2i);
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ rblapack_a = rb_float_new((double)a);
+ rblapack_b = rb_float_new((double)b);
+ rblapack_c = rb_float_new((double)c);
+ rblapack_d = rb_float_new((double)d);
+ return rb_ary_new3(10, rblapack_rt1r, rblapack_rt1i, rblapack_rt2r, rblapack_rt2i, rblapack_cs, rblapack_sn, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
+}
+
+void
+init_lapack_slanv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slanv2", rblapack_slanv2, -1);
+}
diff --git a/ext/slapll.c b/ext/slapll.c
new file mode 100644
index 0000000..7e3a03b
--- /dev/null
+++ b/ext/slapll.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID slapll_(integer* n, real* x, integer* incx, real* y, integer* incy, real* ssmin);
+
+
+static VALUE
+rblapack_slapll(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_ssmin;
+ real ssmin;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_y_out__;
+ real *y_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 ssmin, x, y = NumRu::Lapack.slapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) REAL array,\n* dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) REAL\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.slapll( n, x, incx, y, incy, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ slapll_(&n, x, &incx, y, &incy, &ssmin);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_slapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slapll", rblapack_slapll, -1);
+}
diff --git a/ext/slapmr.c b/ext/slapmr.c
new file mode 100644
index 0000000..d9873bf
--- /dev/null
+++ b/ext/slapmr.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID slapmr_(logical* forwrd, integer* m, integer* n, real* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_slapmr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ integer ldx;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.slapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* SLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n REAL TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.slapmr( forwrd, x, k, [: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_forwrd = argv[0];
+ rblapack_x = argv[1];
+ rblapack_k = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (3th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ slapmr_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_slapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slapmr", rblapack_slapmr, -1);
+}
diff --git a/ext/slapmt.c b/ext/slapmt.c
new file mode 100644
index 0000000..57f1b11
--- /dev/null
+++ b/ext/slapmt.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID slapmt_(logical* forwrd, integer* m, integer* n, real* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_slapmt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ 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 x, k = NumRu::Lapack.slapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* SLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, J, IN\n REAL TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.slapmt( forwrd, m, x, k, [: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_forwrd = argv[0];
+ rblapack_m = argv[1];
+ rblapack_x = argv[2];
+ rblapack_k = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = 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*);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (4th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_k) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ slapmt_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_slapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slapmt", rblapack_slapmt, -1);
+}
diff --git a/ext/slapy2.c b/ext/slapy2.c
new file mode 100644
index 0000000..618d23e
--- /dev/null
+++ b/ext/slapy2.c
@@ -0,0 +1,55 @@
+#include "rb_lapack.h"
+
+extern real slapy2_(real* x, real* y);
+
+
+static VALUE
+rblapack_slapy2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ real x;
+ VALUE rblapack_y;
+ real y;
+ VALUE rblapack___out__;
+ real __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 __out__ = NumRu::Lapack.slapy2( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLAPY2( X, Y )\n\n* Purpose\n* =======\n*\n* SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n* overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) REAL\n* Y (input) REAL\n* X and Y specify the values x and y.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slapy2( x, y, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x = (real)NUM2DBL(rblapack_x);
+ y = (real)NUM2DBL(rblapack_y);
+
+ __out__ = slapy2_(&x, &y);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slapy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slapy2", rblapack_slapy2, -1);
+}
diff --git a/ext/slapy3.c b/ext/slapy3.c
new file mode 100644
index 0000000..6983ca5
--- /dev/null
+++ b/ext/slapy3.c
@@ -0,0 +1,59 @@
+#include "rb_lapack.h"
+
+extern real slapy3_(real* x, real* y, real* z);
+
+
+static VALUE
+rblapack_slapy3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ real x;
+ VALUE rblapack_y;
+ real y;
+ VALUE rblapack_z;
+ real z;
+ VALUE rblapack___out__;
+ real __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 __out__ = NumRu::Lapack.slapy3( x, y, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLAPY3( X, Y, Z )\n\n* Purpose\n* =======\n*\n* SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n* unnecessary overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) REAL\n* Y (input) REAL\n* Z (input) REAL\n* X, Y and Z specify the values x, y and z.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slapy3( x, y, z, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_z = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x = (real)NUM2DBL(rblapack_x);
+ z = (real)NUM2DBL(rblapack_z);
+ y = (real)NUM2DBL(rblapack_y);
+
+ __out__ = slapy3_(&x, &y, &z);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_slapy3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slapy3", rblapack_slapy3, -1);
+}
diff --git a/ext/slaqgb.c b/ext/slaqgb.c
new file mode 100644
index 0000000..2f73267
--- /dev/null
+++ b/ext/slaqgb.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID slaqgb_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);
+
+
+static VALUE
+rblapack_slaqgb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.slaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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, ab = NumRu::Lapack.slaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_r = argv[3];
+ rblapack_c = argv[4];
+ rblapack_rowcnd = argv[5];
+ rblapack_colcnd = argv[6];
+ rblapack_amax = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ colcnd = (real)NUM2DBL(rblapack_colcnd);
+ ku = NUM2INT(rblapack_ku);
+ rowcnd = (real)NUM2DBL(rblapack_rowcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (4th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ slaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_slaqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqgb", rblapack_slaqgb, -1);
+}
diff --git a/ext/slaqge.c b/ext/slaqge.c
new file mode 100644
index 0000000..52547c1
--- /dev/null
+++ b/ext/slaqge.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID slaqge_(integer* m, integer* n, real* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);
+
+
+static VALUE
+rblapack_slaqge(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_r;
+ real *r;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_rowcnd;
+ real rowcnd;
+ VALUE rblapack_colcnd;
+ real colcnd;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.slaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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.slaqge( a, r, c, rowcnd, colcnd, amax, [: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_a = argv[0];
+ rblapack_r = argv[1];
+ rblapack_c = argv[2];
+ rblapack_rowcnd = argv[3];
+ rblapack_colcnd = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } 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);
+ n = 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 (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ colcnd = (real)NUM2DBL(rblapack_colcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (2th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_SFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, real*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ rowcnd = (real)NUM2DBL(rblapack_rowcnd);
+ {
+ 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__;
+
+ slaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_a);
+}
+
+void
+init_lapack_slaqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqge", rblapack_slaqge, -1);
+}
diff --git a/ext/slaqp2.c b/ext/slaqp2.c
new file mode 100644
index 0000000..6d643bb
--- /dev/null
+++ b/ext/slaqp2.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID slaqp2_(integer* m, integer* n, integer* offset, real* a, integer* lda, integer* jpvt, real* tau, real* vn1, real* vn2, real* work);
+
+
+static VALUE
+rblapack_slaqp2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ real *vn1;
+ VALUE rblapack_vn2;
+ real *vn2;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ real *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ real *vn2_out__;
+ real *work;
+
+ 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 tau, a, jpvt, vn1, vn2 = NumRu::Lapack.slaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* SLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n* the triangular factor obtained; the elements in block \n* A(OFFSET+1:M,1:N) below the diagonal, together with the \n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.slaqp2( m, offset, a, jpvt, vn1, vn2, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = 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_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
+ MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
+ MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ work = ALLOC_N(real, (n));
+
+ slaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
+
+ free(work);
+ return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
+}
+
+void
+init_lapack_slaqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqp2", rblapack_slaqp2, -1);
+}
diff --git a/ext/slaqps.c b/ext/slaqps.c
new file mode 100644
index 0000000..2f14ba9
--- /dev/null
+++ b/ext/slaqps.c
@@ -0,0 +1,208 @@
+#include "rb_lapack.h"
+
+extern VOID slaqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, real* a, integer* lda, integer* jpvt, real* tau, real* vn1, real* vn2, real* auxv, real* f, integer* ldf);
+
+
+static VALUE
+rblapack_slaqps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ real *vn1;
+ VALUE rblapack_vn2;
+ real *vn2;
+ VALUE rblapack_auxv;
+ real *auxv;
+ VALUE rblapack_f;
+ real *f;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ real *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ real *vn2_out__;
+ VALUE rblapack_auxv_out__;
+ real *auxv_out__;
+ VALUE rblapack_f_out__;
+ real *f_out__;
+
+ integer lda;
+ integer n;
+ integer nb;
+ 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 kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.slaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* SLAQPS computes a step of QR factorization with column pivoting\n* of a real M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) REAL array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) REAL array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) REAL array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.slaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ rblapack_auxv = argv[6];
+ rblapack_f = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = 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_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
+ if (!NA_IsNArray(rblapack_auxv))
+ rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_auxv) != 1)
+ rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
+ nb = NA_SHAPE0(rblapack_auxv);
+ if (NA_TYPE(rblapack_auxv) != NA_SFLOAT)
+ rblapack_auxv = na_change_type(rblapack_auxv, NA_SFLOAT);
+ auxv = NA_PTR_TYPE(rblapack_auxv, real*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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) != nb)
+ rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
+ if (NA_TYPE(rblapack_f) != NA_SFLOAT)
+ rblapack_f = na_change_type(rblapack_f, NA_SFLOAT);
+ f = NA_PTR_TYPE(rblapack_f, real*);
+ kb = nb;
+ {
+ int shape[1];
+ shape[0] = kb;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
+ MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
+ MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ {
+ int shape[1];
+ shape[0] = nb;
+ rblapack_auxv_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, real*);
+ MEMCPY(auxv_out__, auxv, real, NA_TOTAL(rblapack_auxv));
+ rblapack_auxv = rblapack_auxv_out__;
+ auxv = auxv_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = nb;
+ 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__;
+
+ slaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
+
+ rblapack_kb = INT2NUM(kb);
+ return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
+}
+
+void
+init_lapack_slaqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqps", rblapack_slaqps, -1);
+}
diff --git a/ext/slaqr0.c b/ext/slaqr0.c
new file mode 100644
index 0000000..4f3df2f
--- /dev/null
+++ b/ext/slaqr0.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, integer* iloz, integer* ihiz, real* z, integer* ldz, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_slaqr0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ihi;
+
+ 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 wr, wi, work, info, h, z = NumRu::Lapack.slaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to SGEBAL, and then passed to SGEHRD when the\n* matrix output by SGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) REAL array, dimension (IHI)\n* WI (output) REAL array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) REAL array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then SLAQR0 does a workspace query.\n* In this case, SLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, SLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.slaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [: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_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_h = argv[3];
+ rblapack_iloz = argv[4];
+ rblapack_ihiz = argv[5];
+ rblapack_z = 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;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ ihi = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ wantz = (rblapack_wantz == Qtrue);
+ ihiz = NUM2INT(rblapack_ihiz);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = ihi;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ slaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqr0", rblapack_slaqr0, -1);
+}
diff --git a/ext/slaqr1.c b/ext/slaqr1.c
new file mode 100644
index 0000000..bc59a4a
--- /dev/null
+++ b/ext/slaqr1.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr1_(integer* n, real* h, integer* ldh, real* sr1, real* si1, real* sr2, real* si2, real* v);
+
+
+static VALUE
+rblapack_slaqr1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_sr1;
+ real sr1;
+ VALUE rblapack_si1;
+ real si1;
+ VALUE rblapack_sr2;
+ real sr2;
+ VALUE rblapack_si2;
+ real si2;
+ VALUE rblapack_v;
+ real *v;
+
+ integer ldh;
+ 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 v = NumRu::Lapack.slaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n*\n* scaling to avoid overflows and most underflows. It\n* is assumed that either\n*\n* 1) sr1 = sr2 and si1 = -si2\n* or\n* 2) si1 = si2 = 0.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) REAL array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* SR1 (input) REAL\n* SI1 The shifts in (*).\n* SR2\n* SI2\n*\n* V (output) REAL array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n v = NumRu::Lapack.slaqr1( h, sr1, si1, sr2, si2, [: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_h = argv[0];
+ rblapack_sr1 = argv[1];
+ rblapack_si1 = argv[2];
+ rblapack_sr2 = argv[3];
+ rblapack_si2 = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (1th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ si1 = (real)NUM2DBL(rblapack_si1);
+ si2 = (real)NUM2DBL(rblapack_si2);
+ sr1 = (real)NUM2DBL(rblapack_sr1);
+ sr2 = (real)NUM2DBL(rblapack_sr2);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_v = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, real*);
+
+ slaqr1_(&n, h, &ldh, &sr1, &si1, &sr2, &si2, v);
+
+ return rblapack_v;
+}
+
+void
+init_lapack_slaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqr1", rblapack_slaqr1, -1);
+}
diff --git a/ext/slaqr2.c b/ext/slaqr2.c
new file mode 100644
index 0000000..fa4439c
--- /dev/null
+++ b/ext/slaqr2.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* ns, integer* nd, real* sr, real* si, real* v, integer* ldv, integer* nh, real* t, integer* ldt, integer* nv, real* wv, integer* ldwv, real* work, integer* lwork);
+
+
+static VALUE
+rblapack_slaqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sr;
+ real *sr;
+ VALUE rblapack_si;
+ real *si;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *v;
+ real *t;
+ real *wv;
+ real *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldt;
+ integer ldwv;
+
+ 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 ns, nd, sr, si, h, z = NumRu::Lapack.slaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to SLAQR3 except that it avoids\n* recursion by calling SLAHQR instead of SLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) REAL array, dimension KBOT\n* SI (output) REAL array, dimension KBOT\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) REAL array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) REAL array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) REAL array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) REAL array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; SLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.slaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sr = NA_PTR_TYPE(rblapack_sr, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ si = NA_PTR_TYPE(rblapack_si, real*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
+ wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ slaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqr2", rblapack_slaqr2, -1);
+}
diff --git a/ext/slaqr3.c b/ext/slaqr3.c
new file mode 100644
index 0000000..bfcc217
--- /dev/null
+++ b/ext/slaqr3.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* ns, integer* nd, real* sr, real* si, real* v, integer* ldv, integer* nh, real* t, integer* ldt, integer* nv, real* wv, integer* ldwv, real* work, integer* lwork);
+
+
+static VALUE
+rblapack_slaqr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sr;
+ real *sr;
+ VALUE rblapack_si;
+ real *si;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *v;
+ real *t;
+ real *wv;
+ real *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldt;
+ integer ldwv;
+
+ 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 ns, nd, sr, si, h, z = NumRu::Lapack.slaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) REAL array, dimension KBOT\n* SI (output) REAL array, dimension KBOT\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) REAL array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) REAL array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) REAL array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) REAL array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; SLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.slaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sr = NA_PTR_TYPE(rblapack_sr, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ si = NA_PTR_TYPE(rblapack_si, real*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
+ wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ slaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqr3", rblapack_slaqr3, -1);
+}
diff --git a/ext/slaqr4.c b/ext/slaqr4.c
new file mode 100644
index 0000000..176a8dc
--- /dev/null
+++ b/ext/slaqr4.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, integer* iloz, integer* ihiz, real* z, integer* ldz, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_slaqr4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ihi;
+
+ 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 wr, wi, work, info, h, z = NumRu::Lapack.slaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to SGEBAL, and then passed to SGEHRD when the\n* matrix output by SGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) REAL array, dimension (IHI)\n* WI (output) REAL array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) REAL array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then SLAQR4 does a workspace query.\n* In this case, SLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, SLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.slaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [: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_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_h = argv[3];
+ rblapack_iloz = argv[4];
+ rblapack_ihiz = argv[5];
+ rblapack_z = 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;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ ihi = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ wantz = (rblapack_wantz == Qtrue);
+ ihiz = NUM2INT(rblapack_ihiz);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = ihi;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = ihi;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ slaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqr4", rblapack_slaqr4, -1);
+}
diff --git a/ext/slaqr5.c b/ext/slaqr5.c
new file mode 100644
index 0000000..460cf16
--- /dev/null
+++ b/ext/slaqr5.c
@@ -0,0 +1,200 @@
+#include "rb_lapack.h"
+
+extern VOID slaqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, real* sr, real* si, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, real* v, integer* ldv, real* u, integer* ldu, integer* nv, real* wv, integer* ldwv, integer* nh, real* wh, integer* ldwh);
+
+
+static VALUE
+rblapack_slaqr5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_kacc22;
+ integer kacc22;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_sr;
+ real *sr;
+ VALUE rblapack_si;
+ real *si;
+ VALUE rblapack_h;
+ real *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_sr_out__;
+ real *sr_out__;
+ VALUE rblapack_si_out__;
+ real *si_out__;
+ VALUE rblapack_h_out__;
+ real *h_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *v;
+ real *u;
+ real *wv;
+ real *wh;
+
+ integer nshfts;
+ integer ldh;
+ integer n;
+ integer ldv;
+ integer ldu;
+ integer ldwv;
+ integer ldwh;
+ integer ldz;
+
+ 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 sr, si, h, z = NumRu::Lapack.slaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by SLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the quasi-triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the orthogonal Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: SLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: SLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: SLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* SR (input/output) REAL array of size (NSHFTS)\n* SI (input/output) REAL array of size (NSHFTS)\n* SR contains the real parts and SI contains the imaginary\n* parts of the NSHFTS shifts of origin that define the\n* multi-shift QR sweep. On output SR and SI may be\n* reordered.\n*\n* H (input/output) REAL array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) REAL array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep orthogonal\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) REAL array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) REAL array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) REAL array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) REAL array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sr, si, h, z = NumRu::Lapack.slaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_kacc22 = argv[2];
+ rblapack_ktop = argv[3];
+ rblapack_kbot = argv[4];
+ rblapack_sr = argv[5];
+ rblapack_si = argv[6];
+ rblapack_h = argv[7];
+ rblapack_iloz = argv[8];
+ rblapack_ihiz = argv[9];
+ rblapack_z = argv[10];
+ rblapack_nv = argv[11];
+ rblapack_nh = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ kacc22 = NUM2INT(rblapack_kacc22);
+ kbot = NUM2INT(rblapack_kbot);
+ if (!NA_IsNArray(rblapack_si))
+ rb_raise(rb_eArgError, "si (7th argument) must be NArray");
+ if (NA_RANK(rblapack_si) != 1)
+ rb_raise(rb_eArgError, "rank of si (7th argument) must be %d", 1);
+ nshfts = NA_SHAPE0(rblapack_si);
+ if (NA_TYPE(rblapack_si) != NA_SFLOAT)
+ rblapack_si = na_change_type(rblapack_si, NA_SFLOAT);
+ si = NA_PTR_TYPE(rblapack_si, real*);
+ iloz = NUM2INT(rblapack_iloz);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nv;
+ ldv = 3;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_sr))
+ rb_raise(rb_eArgError, "sr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_sr) != 1)
+ rb_raise(rb_eArgError, "rank of sr (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_sr) != nshfts)
+ rb_raise(rb_eRuntimeError, "shape 0 of sr must be the same as shape 0 of si");
+ if (NA_TYPE(rblapack_sr) != NA_SFLOAT)
+ rblapack_sr = na_change_type(rblapack_sr, NA_SFLOAT);
+ sr = NA_PTR_TYPE(rblapack_sr, real*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ nh = NUM2INT(rblapack_nh);
+ ldu = 3*nshfts-3;
+ ktop = NUM2INT(rblapack_ktop);
+ ldwh = 3*nshfts-3;
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (8th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (8th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_SFLOAT)
+ rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
+ h = NA_PTR_TYPE(rblapack_h, real*);
+ ldz = n;
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (11th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = nshfts;
+ rblapack_sr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sr_out__ = NA_PTR_TYPE(rblapack_sr_out__, real*);
+ MEMCPY(sr_out__, sr, real, NA_TOTAL(rblapack_sr));
+ rblapack_sr = rblapack_sr_out__;
+ sr = sr_out__;
+ {
+ int shape[1];
+ shape[0] = nshfts;
+ rblapack_si_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ si_out__ = NA_PTR_TYPE(rblapack_si_out__, real*);
+ MEMCPY(si_out__, si, real, NA_TOTAL(rblapack_si));
+ rblapack_si = rblapack_si_out__;
+ si = si_out__;
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
+ MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? ihiz : 0;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ v = ALLOC_N(real, (ldv)*(nshfts/2));
+ u = ALLOC_N(real, (ldu)*(3*nshfts-3));
+ wv = ALLOC_N(real, (ldwv)*(3*nshfts-3));
+ wh = ALLOC_N(real, (ldwh)*(MAX(1,nh)));
+
+ slaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, sr, si, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
+
+ free(v);
+ free(u);
+ free(wv);
+ free(wh);
+ return rb_ary_new3(4, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_slaqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqr5", rblapack_slaqr5, -1);
+}
diff --git a/ext/slaqsb.c b/ext/slaqsb.c
new file mode 100644
index 0000000..265fa6c
--- /dev/null
+++ b/ext/slaqsb.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID slaqsb_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_slaqsb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.slaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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, ab = NumRu::Lapack.slaqsb( uplo, kd, ab, s, scond, amax, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_s = argv[3];
+ rblapack_scond = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ kd = NUM2INT(rblapack_kd);
+ amax = (real)NUM2DBL(rblapack_amax);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ slaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_slaqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqsb", rblapack_slaqsb, -1);
+}
diff --git a/ext/slaqsp.c b/ext/slaqsp.c
new file mode 100644
index 0000000..0367366
--- /dev/null
+++ b/ext/slaqsp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID slaqsp_(char* uplo, integer* n, real* ap, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_slaqsp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+
+ 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, ap = NumRu::Lapack.slaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQSP 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* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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, ap = NumRu::Lapack.slaqsp( uplo, ap, 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_ap = 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ amax = (real)NUM2DBL(rblapack_amax);
+ 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);
+ 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*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ {
+ int 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__;
+
+ slaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ap);
+}
+
+void
+init_lapack_slaqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqsp", rblapack_slaqsp, -1);
+}
diff --git a/ext/slaqsy.c b/ext/slaqsy.c
new file mode 100644
index 0000000..1beb571
--- /dev/null
+++ b/ext/slaqsy.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID slaqsy_(char* uplo, integer* n, real* a, integer* lda, real* s, real* scond, real* amax, char* equed);
+
+
+static VALUE
+rblapack_slaqsy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a_out__;
+ real *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.slaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQSY 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) REAL 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) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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.slaqsy( 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ amax = (real)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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ scond = (real)NUM2DBL(rblapack_scond);
+ {
+ 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__;
+
+ slaqsy_(&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_slaqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqsy", rblapack_slaqsy, -1);
+}
diff --git a/ext/slaqtr.c b/ext/slaqtr.c
new file mode 100644
index 0000000..56238c0
--- /dev/null
+++ b/ext/slaqtr.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID slaqtr_(logical* ltran, logical* lreal, integer* n, real* t, integer* ldt, real* b, real* w, real* scale, real* x, real* work, integer* info);
+
+
+static VALUE
+rblapack_slaqtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ltran;
+ logical ltran;
+ VALUE rblapack_lreal;
+ logical lreal;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_w;
+ real w;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ real *work;
+
+ integer ldt;
+ 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 scale, info, x = NumRu::Lapack.slaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAQTR solves the real quasi-triangular system\n*\n* op(T)*p = scale*c, if LREAL = .TRUE.\n*\n* or the complex quasi-triangular systems\n*\n* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.\n*\n* in real arithmetic, where T is upper quasi-triangular.\n* If LREAL = .FALSE., then the first diagonal block of T must be\n* 1 by 1, B is the specially structured matrix\n*\n* B = [ b(1) b(2) ... b(n) ]\n* [ w ]\n* [ w ]\n* [ . ]\n* [ w ]\n*\n* op(A) = A or A', A' denotes the conjugate transpose of\n* matrix A.\n*\n* On input, X = [ c ]. On output, X = [ p ].\n* [ d ] [ q ]\n*\n* This subroutine is designed for the condition number estimation\n* in routine STRSNA.\n*\n\n* Arguments\n* =========\n*\n* LTRAN (input) LOGICAL\n* On entry, LTRAN specifies the option of conjugate transpose:\n* = .FALSE., op(T+i*B) = T+i*B,\n* = .TRUE., op(T+i*B) = (T+i*B)'.\n*\n* LREAL (input) LOGICAL\n* On entry, LREAL specifies the input matrix structure:\n* = .FALSE., the input is complex\n* = .TRUE., the input is real\n*\n* N (input) INTEGER\n* On entry, N specifies the order of T+i*B. N >= 0.\n*\n* T (input) REAL array, dimension (LDT,N)\n* On entry, T contains a matrix in Schur canonical form.\n* If LREAL = .FALSE., then the first diagonal block of T must\n* be 1 by 1.\n*\n* LDT (input) INTEGER\n* The leading dimension of the matrix T. LDT >= max(1,N).\n*\n* B (input) REAL array, dimension (N)\n* On entry, B contains the elements to form the matrix\n* B as described above.\n* If LREAL = .TRUE., B is not referenced.\n*\n* W (input) REAL\n* On entry, W is the diagonal element of the matrix B.\n* If LREAL = .TRUE., W is not referenced.\n*\n* SCALE (output) REAL\n* On exit, SCALE is the scale factor.\n*\n* X (input/output) REAL array, dimension (2*N)\n* On entry, X contains the right hand side of the system.\n* On exit, X is overwritten by the solution.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: the some diagonal 1 by 1 block has been perturbed by\n* a small number SMIN to keep nonsingularity.\n* 2: the some diagonal 2 by 2 block has been perturbed by\n* a small number in SLALN2 to keep nonsingularity.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x = NumRu::Lapack.slaqtr( ltran, lreal, t, b, w, 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_ltran = argv[0];
+ rblapack_lreal = argv[1];
+ rblapack_t = argv[2];
+ rblapack_b = argv[3];
+ rblapack_w = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ltran = (rblapack_ltran == Qtrue);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (3th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (3th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ n = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ w = (real)NUM2DBL(rblapack_w);
+ lreal = (rblapack_lreal == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (4th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 1)
+ rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 1 of t");
+ 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_x))
+ rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 2*n);
+ if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = 2*n;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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, (n));
+
+ slaqtr_(<ran, &lreal, &n, t, &ldt, b, &w, &scale, x, work, &info);
+
+ free(work);
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_slaqtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaqtr", rblapack_slaqtr, -1);
+}
diff --git a/ext/slar1v.c b/ext/slar1v.c
new file mode 100644
index 0000000..a74c83a
--- /dev/null
+++ b/ext/slar1v.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID slar1v_(integer* n, integer* b1, integer* bn, real* lambda, real* d, real* l, real* ld, real* lld, real* pivmin, real* gaptol, real* z, logical* wantnc, integer* negcnt, real* ztz, real* mingma, integer* r, integer* isuppz, real* nrminv, real* resid, real* rqcorr, real* work);
+
+
+static VALUE
+rblapack_slar1v(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_b1;
+ integer b1;
+ VALUE rblapack_bn;
+ integer bn;
+ VALUE rblapack_lambda;
+ real lambda;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_l;
+ real *l;
+ VALUE rblapack_ld;
+ real *ld;
+ VALUE rblapack_lld;
+ real *lld;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_gaptol;
+ real gaptol;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_wantnc;
+ logical wantnc;
+ VALUE rblapack_r;
+ integer r;
+ VALUE rblapack_negcnt;
+ integer negcnt;
+ VALUE rblapack_ztz;
+ real ztz;
+ VALUE rblapack_mingma;
+ real mingma;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_nrminv;
+ real nrminv;
+ VALUE rblapack_resid;
+ real resid;
+ VALUE rblapack_rqcorr;
+ real rqcorr;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *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.slar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAR1V( 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* SLAR1V 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) REAL \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) REAL 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) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D.\n*\n* LD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*D(i).\n*\n* LLD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*L(i)*D(i).\n*\n* PIVMIN (input) REAL \n* The minimum pivot in the Sturm sequence.\n*\n* GAPTOL (input) REAL \n* Tolerance that indicates when eigenvector entries are negligible\n* w.r.t. their contribution to the residual.\n*\n* Z (input/output) REAL 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) REAL \n* The square of the 2-norm of Z.\n*\n* MINGMA (output) REAL \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) REAL \n* NRMINV = 1/SQRT( ZTZ )\n*\n* RESID (output) REAL \n* The residual of the FP vector.\n* RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n* RQCORR (output) REAL \n* The Rayleigh Quotient correction to LAMBDA.\n* RQCORR = MINGMA*TMP\n*\n* WORK (workspace) REAL 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.slar1v( 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 = (real)NUM2DBL(rblapack_lambda);
+ pivmin = (real)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_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ r = NUM2INT(rblapack_r);
+ bn = NUM2INT(rblapack_bn);
+ gaptol = (real)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_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ 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_SFLOAT)
+ rblapack_ld = na_change_type(rblapack_ld, NA_SFLOAT);
+ ld = NA_PTR_TYPE(rblapack_ld, real*);
+ 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_SFLOAT)
+ rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
+ l = NA_PTR_TYPE(rblapack_l, real*);
+ 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_SFLOAT)
+ rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
+ lld = NA_PTR_TYPE(rblapack_lld, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(real, (4*n));
+
+ slar1v_(&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_slar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slar1v", rblapack_slar1v, -1);
+}
diff --git a/ext/slar2v.c b/ext/slar2v.c
new file mode 100644
index 0000000..6bdf3e8
--- /dev/null
+++ b/ext/slar2v.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID slar2v_(integer* n, real* x, real* y, real* z, integer* incx, real* c, real* s, integer* incc);
+
+
+static VALUE
+rblapack_slar2v(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_y_out__;
+ real *y_out__;
+ VALUE rblapack_z_out__;
+ real *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.slar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n* Purpose\n* =======\n*\n* SLAR2V applies a vector of real plane rotations from both sides to\n* a sequence of 2-by-2 real symmetric matrices, defined by the elements\n* of the vectors x, y and z. For i = 1,2,...,n\n*\n* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )\n* ( z(i) y(i) ) ( -s(i) c(i) ) ( 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) REAL array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCX)\n* The vector y.\n*\n* Z (input/output) REAL array,\n* 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) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) REAL 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 REAL CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.slar2v( 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_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ 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_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ 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_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ 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_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ slar2v_(&n, x, y, z, &incx, c, s, &incc);
+
+ return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
+}
+
+void
+init_lapack_slar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slar2v", rblapack_slar2v, -1);
+}
diff --git a/ext/slarf.c b/ext/slarf.c
new file mode 100644
index 0000000..47a7410
--- /dev/null
+++ b/ext/slarf.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID slarf_(char* side, integer* m, integer* n, real* v, integer* incv, real* tau, real* c, integer* ldc, real* work);
+
+
+static VALUE
+rblapack_slarf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *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 c = NumRu::Lapack.slarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* SLARF applies a real elementary reflector H to a real m by n matrix\n* C, from either the left or the right. H is represented in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) REAL array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) REAL\n* The value tau in the representation of H.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarf( side, m, v, incv, tau, c, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_v = argv[2];
+ rblapack_incv = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ m = NUM2INT(rblapack_m);
+ tau = (real)NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (3th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ 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] = 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ slarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_slarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarf", rblapack_slarf, -1);
+}
diff --git a/ext/slarfb.c b/ext/slarfb.c
new file mode 100644
index 0000000..1e89128
--- /dev/null
+++ b/ext/slarfb.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID slarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, real* v, integer* ldv, real* t, integer* ldt, real* c, integer* ldc, real* work, integer* ldwork);
+
+
+static VALUE
+rblapack_slarfb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.slarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* SLARFB applies a real block reflector H or its transpose H' to a\n* real m by n matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'T': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) REAL array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) REAL array, dimension (LDT,K)\n* The triangular k by k matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarfb( side, trans, direct, storev, m, v, t, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_v = argv[5];
+ rblapack_t = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th 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*);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ {
+ int 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__;
+ work = ALLOC_N(real, (ldwork)*(k));
+
+ slarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_slarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarfb", rblapack_slarfb, -1);
+}
diff --git a/ext/slarfg.c b/ext/slarfg.c
new file mode 100644
index 0000000..11bf64a
--- /dev/null
+++ b/ext/slarfg.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID slarfg_(integer* n, real* alpha, real* x, integer* incx, real* tau);
+
+
+static VALUE
+rblapack_slarfg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_x_out__;
+ real *x_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 tau, alpha, x = NumRu::Lapack.slarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* SLARFG generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, and x is an (n-1)-element real\n* vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n* Otherwise 1 <= tau <= 2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) REAL\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) REAL array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) REAL\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.slarfg( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(incx);
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+
+ slarfg_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_alpha = rb_float_new((double)alpha);
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_slarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarfg", rblapack_slarfg, -1);
+}
diff --git a/ext/slarfgp.c b/ext/slarfgp.c
new file mode 100644
index 0000000..379eafa
--- /dev/null
+++ b/ext/slarfgp.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID slarfgp_(integer* n, real* alpha, real* x, integer* incx, real* tau);
+
+
+static VALUE
+rblapack_slarfgp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_x_out__;
+ real *x_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 tau, alpha, x = NumRu::Lapack.slarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* SLARFGP generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is non-negative, and x is\n* an (n-1)-element real vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) REAL\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) REAL array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) REAL\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.slarfgp( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(incx);
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+
+ slarfgp_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_alpha = rb_float_new((double)alpha);
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_slarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarfgp", rblapack_slarfgp, -1);
+}
diff --git a/ext/slarft.c b/ext/slarft.c
new file mode 100644
index 0000000..1f77438
--- /dev/null
+++ b/ext/slarft.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID slarft_(char* direct, char* storev, integer* n, integer* k, real* v, integer* ldv, real* tau, real* t, integer* ldt);
+
+
+static VALUE
+rblapack_slarft(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_v_out__;
+ real *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.slarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* SLARFT forms the triangular factor T of a real block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) REAL array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) REAL array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.slarft( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ 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] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ 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__;
+
+ slarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_slarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarft", rblapack_slarft, -1);
+}
diff --git a/ext/slarfx.c b/ext/slarfx.c
new file mode 100644
index 0000000..ba16e2e
--- /dev/null
+++ b/ext/slarfx.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID slarfx_(char* side, integer* m, integer* n, real* v, real* tau, real* c, integer* ldc, real* work);
+
+
+static VALUE
+rblapack_slarfx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer m;
+ 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 c = NumRu::Lapack.slarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* SLARFX applies a real elementary reflector H to a real m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) REAL array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) REAL\n* The value tau in the representation of H.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= (1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarfx( side, v, tau, c, [: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_side = argv[0];
+ rblapack_v = argv[1];
+ rblapack_tau = argv[2];
+ rblapack_c = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ tau = (real)NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (2th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (4th 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*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ slarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_slarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarfx", rblapack_slarfx, -1);
+}
diff --git a/ext/slargv.c b/ext/slargv.c
new file mode 100644
index 0000000..f7a431a
--- /dev/null
+++ b/ext/slargv.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID slargv_(integer* n, real* x, integer* incx, real* y, integer* incy, real* c, integer* incc);
+
+
+static VALUE
+rblapack_slargv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_y_out__;
+ real *y_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 c, x, y = NumRu::Lapack.slargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* SLARGV generates a vector of real plane rotations, determined by\n* elements of the real vectors x and y. For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( a(i) )\n* ( -s(i) c(i) ) ( y(i) ) = ( 0 )\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) REAL array,\n* dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.slargv( n, x, incx, y, incy, incc, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ rblapack_incc = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ incc = NUM2INT(rblapack_incc);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incc;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ slargv_(&n, x, &incx, y, &incy, c, &incc);
+
+ return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_slargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slargv", rblapack_slargv, -1);
+}
diff --git a/ext/slarnv.c b/ext/slarnv.c
new file mode 100644
index 0000000..4041e14
--- /dev/null
+++ b/ext/slarnv.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID slarnv_(integer* idist, integer* iseed, integer* n, real* x);
+
+
+static VALUE
+rblapack_slarnv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_idist;
+ integer idist;
+ VALUE rblapack_iseed;
+ integer *iseed;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_iseed_out__;
+ integer *iseed_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, iseed = NumRu::Lapack.slarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* SLARNV returns a vector of n random real numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: uniform (0,1)\n* = 2: uniform (-1,1)\n* = 3: normal (0,1)\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) REAL array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine SLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.slarnv( idist, iseed, n, [: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_idist = argv[0];
+ rblapack_iseed = argv[1];
+ rblapack_n = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ idist = NUM2INT(rblapack_idist);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_iseed))
+ rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
+ if (NA_RANK(rblapack_iseed) != 1)
+ rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iseed) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
+ if (NA_TYPE(rblapack_iseed) != NA_LINT)
+ rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
+ iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = 4;
+ rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
+ MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
+ rblapack_iseed = rblapack_iseed_out__;
+ iseed = iseed_out__;
+
+ slarnv_(&idist, iseed, &n, x);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_iseed);
+}
+
+void
+init_lapack_slarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarnv", rblapack_slarnv, -1);
+}
diff --git a/ext/slarra.c b/ext/slarra.c
new file mode 100644
index 0000000..87dedb6
--- /dev/null
+++ b/ext/slarra.c
@@ -0,0 +1,124 @@
+#include "rb_lapack.h"
+
+extern VOID slarra_(integer* n, real* d, real* e, real* e2, real* spltol, real* tnrm, integer* nsplit, integer* isplit, integer* info);
+
+
+static VALUE
+rblapack_slarra(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_e2;
+ real *e2;
+ VALUE rblapack_spltol;
+ real spltol;
+ VALUE rblapack_tnrm;
+ real tnrm;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_e2_out__;
+ real *e2_out__;
+
+ 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 nsplit, isplit, info, e, e2 = NumRu::Lapack.slarra( d, e, e2, spltol, tnrm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n* Purpose\n* =======\n*\n* Compute the splitting points with threshold SPLTOL.\n* SLARRA sets any \"small\" off-diagonal elements to zero.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n* are set to zero, the other entries of E are untouched.\n*\n* E2 (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* SPLTOL (input) REAL \n* The threshold for splitting. Two criteria can be used:\n* SPLTOL<0 : criterion based on absolute off-diagonal value\n* SPLTOL>0 : criterion that preserves relative accuracy\n*\n* TNRM (input) REAL \n* The norm of the matrix.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\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 nsplit, isplit, info, e, e2 = NumRu::Lapack.slarra( d, e, e2, spltol, tnrm, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_e2 = argv[2];
+ rblapack_spltol = argv[3];
+ rblapack_tnrm = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_e2))
+ rb_raise(rb_eArgError, "e2 (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, real*);
+ tnrm = (real)NUM2DBL(rblapack_tnrm);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ spltol = (real)NUM2DBL(rblapack_spltol);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, real*);
+ MEMCPY(e2_out__, e2, real, NA_TOTAL(rblapack_e2));
+ rblapack_e2 = rblapack_e2_out__;
+ e2 = e2_out__;
+
+ slarra_(&n, d, e, e2, &spltol, &tnrm, &nsplit, isplit, &info);
+
+ rblapack_nsplit = INT2NUM(nsplit);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_nsplit, rblapack_isplit, rblapack_info, rblapack_e, rblapack_e2);
+}
+
+void
+init_lapack_slarra(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarra", rblapack_slarra, -1);
+}
diff --git a/ext/slarrb.c b/ext/slarrb.c
new file mode 100644
index 0000000..5cf8638
--- /dev/null
+++ b/ext/slarrb.c
@@ -0,0 +1,178 @@
+#include "rb_lapack.h"
+
+extern VOID slarrb_(integer* n, real* d, real* lld, integer* ifirst, integer* ilast, real* rtol1, real* rtol2, integer* offset, real* w, real* wgap, real* werr, real* work, integer* iwork, real* pivmin, real* spdiam, integer* twist, integer* info);
+
+
+static VALUE
+rblapack_slarrb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_lld;
+ real *lld;
+ VALUE rblapack_ifirst;
+ integer ifirst;
+ VALUE rblapack_ilast;
+ integer ilast;
+ VALUE rblapack_rtol1;
+ real rtol1;
+ VALUE rblapack_rtol2;
+ real rtol2;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_wgap;
+ real *wgap;
+ VALUE rblapack_werr;
+ real *werr;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_spdiam;
+ real spdiam;
+ VALUE rblapack_twist;
+ integer twist;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_w_out__;
+ real *w_out__;
+ VALUE rblapack_wgap_out__;
+ real *wgap_out__;
+ VALUE rblapack_werr_out__;
+ real *werr_out__;
+ 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 info, w, wgap, werr = NumRu::Lapack.slarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n* Purpose\n* =======\n*\n* Given the relatively robust representation(RRR) L D L^T, SLARRB\n* does \"limited\" bisection to refine the eigenvalues of L D L^T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses and their gaps are input in WERR\n* and WGAP, respectively. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) REAL array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n* where GAP is the (estimated) distance to the nearest\n* eigenvalue.\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) REAL array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST throug\n* ILAST.\n* On output, these estimates are refined.\n*\n* WGAP (input/output) REAL array, dimension (N-1)\n* On input, the (estimated) gaps between consecutive\n* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n* then WGAP(IFIRST-OFFSET) must be set to ZERO.\n* On output, these gaps are refined.\n*\n* WERR (input/output) REAL array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) REAL\n* The minimum pivot in the Sturm sequence.\n*\n* SPDIAM (input) REAL\n* The spectral diameter of the matrix.\n*\n* TWIST (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n*\n* INFO (output) INTEGER\n* Error flag.\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 info, w, wgap, werr = NumRu::Lapack.slarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_d = argv[0];
+ rblapack_lld = argv[1];
+ rblapack_ifirst = argv[2];
+ rblapack_ilast = argv[3];
+ rblapack_rtol1 = argv[4];
+ rblapack_rtol2 = argv[5];
+ rblapack_offset = argv[6];
+ rblapack_w = argv[7];
+ rblapack_wgap = argv[8];
+ rblapack_werr = argv[9];
+ rblapack_pivmin = argv[10];
+ rblapack_spdiam = argv[11];
+ rblapack_twist = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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*);
+ ifirst = NUM2INT(rblapack_ifirst);
+ rtol1 = (real)NUM2DBL(rblapack_rtol1);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, real*);
+ spdiam = (real)NUM2DBL(rblapack_spdiam);
+ ilast = NUM2INT(rblapack_ilast);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (8th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_lld))
+ rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
+ if (NA_RANK(rblapack_lld) != 1)
+ rb_raise(rb_eArgError, "rank of lld (2th 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_SFLOAT)
+ rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
+ lld = NA_PTR_TYPE(rblapack_lld, real*);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (9th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", n-1);
+ if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, real*);
+ rtol2 = (real)NUM2DBL(rblapack_rtol2);
+ twist = NUM2INT(rblapack_twist);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
+ MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
+ MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
+ MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ work = ALLOC_N(real, (2*n));
+ iwork = ALLOC_N(integer, (2*n));
+
+ slarrb_(&n, d, lld, &ifirst, &ilast, &rtol1, &rtol2, &offset, w, wgap, werr, work, iwork, &pivmin, &spdiam, &twist, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_w, rblapack_wgap, rblapack_werr);
+}
+
+void
+init_lapack_slarrb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrb", rblapack_slarrb, -1);
+}
diff --git a/ext/slarrc.c b/ext/slarrc.c
new file mode 100644
index 0000000..35fd1da
--- /dev/null
+++ b/ext/slarrc.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID slarrc_(char* jobt, integer* n, real* vl, real* vu, real* d, real* e, real* pivmin, integer* eigcnt, integer* lcnt, integer* rcnt, integer* info);
+
+
+static VALUE
+rblapack_slarrc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobt;
+ char jobt;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_eigcnt;
+ integer eigcnt;
+ VALUE rblapack_lcnt;
+ integer lcnt;
+ VALUE rblapack_rcnt;
+ integer rcnt;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 eigcnt, lcnt, rcnt, info = NumRu::Lapack.slarrc( jobt, vl, vu, d, e, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n* Purpose\n* =======\n*\n* Find the number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n* if JOBT = 'L'.\n*\n\n* Arguments\n* =========\n*\n* JOBT (input) CHARACTER*1\n* = 'T': Compute Sturm count for matrix T.\n* = 'L': Compute Sturm count for matrix L D L^T.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* The lower and upper bounds for the eigenvalues.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n* JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n*\n* E (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n*\n* PIVMIN (input) REAL\n* The minimum pivot in the Sturm sequence for T.\n*\n* EIGCNT (output) INTEGER\n* The number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU]\n*\n* LCNT (output) INTEGER\n* RCNT (output) INTEGER\n* The left and right negcounts of the interval.\n*\n* INFO (output) INTEGER\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 eigcnt, lcnt, rcnt, info = NumRu::Lapack.slarrc( jobt, vl, vu, d, e, pivmin, [: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_jobt = argv[0];
+ rblapack_vl = argv[1];
+ rblapack_vu = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e = argv[4];
+ rblapack_pivmin = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobt = StringValueCStr(rblapack_jobt)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_e);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ 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 e");
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+
+ slarrc_(&jobt, &n, &vl, &vu, d, e, &pivmin, &eigcnt, &lcnt, &rcnt, &info);
+
+ rblapack_eigcnt = INT2NUM(eigcnt);
+ rblapack_lcnt = INT2NUM(lcnt);
+ rblapack_rcnt = INT2NUM(rcnt);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_eigcnt, rblapack_lcnt, rblapack_rcnt, rblapack_info);
+}
+
+void
+init_lapack_slarrc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrc", rblapack_slarrc, -1);
+}
diff --git a/ext/slarrd.c b/ext/slarrd.c
new file mode 100644
index 0000000..cc74299
--- /dev/null
+++ b/ext/slarrd.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID slarrd_(char* range, char* order, integer* n, real* vl, real* vu, integer* il, integer* iu, real* gers, real* reltol, real* d, real* e, real* e2, real* pivmin, integer* nsplit, integer* isplit, integer* m, real* w, real* werr, real* wl, real* wu, integer* iblock, integer* indexw, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slarrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_order;
+ char order;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_gers;
+ real *gers;
+ VALUE rblapack_reltol;
+ real reltol;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_e2;
+ real *e2;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_werr;
+ real *werr;
+ VALUE rblapack_wl;
+ real wl;
+ VALUE rblapack_wu;
+ real wu;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ 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 m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.slarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLARRD computes the eigenvalues of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from SSTEMR.\n* The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) REAL \n* VU (input) REAL \n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* GERS (input) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* RELTOL (input) REAL \n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) REAL array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) REAL \n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* NSPLIT (input) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* W (output) REAL array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalue approximations. SLARRD computes an interval\n* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n* approximation is given as the interval midpoint\n* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n* WERR(j) = abs( a_j - b_j)/2\n*\n* WERR (output) REAL array, dimension (N)\n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* WL (output) REAL \n* WU (output) REAL \n* The interval (WL, WU] contains all the wanted eigenvalues.\n* If RANGE='V', then WL=VL and WU=VU.\n* If RANGE='A', then WL and WU are the global Gerschgorin bounds\n* on the spectrum.\n* If RANGE='I', then WL and WU are computed by SLAEBZ from the\n* index range specified.\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (SLARRD may use the remaining N-M elements as\n* workspace.)\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n* i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE REAL , default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n* Based on contributions by\n* W. Kahan, University of California, Berkeley, USA\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\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.slarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 14 && argc != 14)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
+ rblapack_range = argv[0];
+ rblapack_order = argv[1];
+ rblapack_vl = argv[2];
+ rblapack_vu = argv[3];
+ rblapack_il = argv[4];
+ rblapack_iu = argv[5];
+ rblapack_gers = argv[6];
+ rblapack_reltol = argv[7];
+ rblapack_d = argv[8];
+ rblapack_e = argv[9];
+ rblapack_e2 = argv[10];
+ rblapack_pivmin = argv[11];
+ rblapack_nsplit = argv[12];
+ rblapack_isplit = argv[13];
+ if (argc == 14) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ range = StringValueCStr(rblapack_range)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ reltol = (real)NUM2DBL(rblapack_reltol);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (14th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (14th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_isplit);
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ order = StringValueCStr(rblapack_order)[0];
+ iu = NUM2INT(rblapack_iu);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (9th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (9th 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 isplit");
+ 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_e2))
+ rb_raise(rb_eArgError, "e2 (11th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
+ if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, real*);
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (10th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (!NA_IsNArray(rblapack_gers))
+ rb_raise(rb_eArgError, "gers (7th argument) must be NArray");
+ if (NA_RANK(rblapack_gers) != 1)
+ rb_raise(rb_eArgError, "rank of gers (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_gers) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
+ if (NA_TYPE(rblapack_gers) != NA_SFLOAT)
+ rblapack_gers = na_change_type(rblapack_gers, NA_SFLOAT);
+ gers = NA_PTR_TYPE(rblapack_gers, real*);
+ nsplit = NUM2INT(rblapack_nsplit);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ werr = NA_PTR_TYPE(rblapack_werr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (3*n));
+
+ slarrd_(&range, &order, &n, &vl, &vu, &il, &iu, gers, &reltol, d, e, e2, &pivmin, &nsplit, isplit, &m, w, werr, &wl, &wu, iblock, indexw, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_wl = rb_float_new((double)wl);
+ rblapack_wu = rb_float_new((double)wu);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_werr, rblapack_wl, rblapack_wu, rblapack_iblock, rblapack_indexw, rblapack_info);
+}
+
+void
+init_lapack_slarrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrd", rblapack_slarrd, -1);
+}
diff --git a/ext/slarre.c b/ext/slarre.c
new file mode 100644
index 0000000..25e2538
--- /dev/null
+++ b/ext/slarre.c
@@ -0,0 +1,221 @@
+#include "rb_lapack.h"
+
+extern VOID slarre_(char* range, integer* n, real* vl, real* vu, integer* il, integer* iu, real* d, real* e, real* e2, real* rtol1, real* rtol2, real* spltol, integer* nsplit, integer* isplit, integer* m, real* w, real* werr, real* wgap, integer* iblock, integer* indexw, real* gers, real* pivmin, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slarre(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_e2;
+ real *e2;
+ VALUE rblapack_rtol1;
+ real rtol1;
+ VALUE rblapack_rtol2;
+ real rtol2;
+ VALUE rblapack_spltol;
+ real spltol;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_werr;
+ real *werr;
+ VALUE rblapack_wgap;
+ real *wgap;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ VALUE rblapack_gers;
+ real *gers;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_e2_out__;
+ real *e2_out__;
+ 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 nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.slarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* To find the desired eigenvalues of a given real symmetric\n* tridiagonal matrix T, SLARRE sets any \"small\" off-diagonal\n* elements to zero, and for each unreduced block T_i, it finds\n* (a) a suitable shift at one end of the block's spectrum,\n* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n* (c) eigenvalues of each L_i D_i L_i^T.\n* The representations and eigenvalues found are then used by\n* SSTEMR to compute the eigenvectors of T.\n* The accuracy varies depending on whether bisection is used to\n* find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to\n* conpute all and then discard any unwanted one.\n* As an added benefit, SLARRE also outputs the n\n* Gerschgorin intervals for the matrices L_i D_i L_i^T.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input/output) REAL \n* VU (input/output) REAL \n* If RANGE='V', the lower and upper bounds for the eigenvalues.\n* Eigenvalues less than or equal to VL, or greater than VU,\n* will not be returned. VL < VU.\n* If RANGE='I' or ='A', SLARRE computes bounds on the desired\n* part of the spectrum.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n* On exit, the N diagonal elements of the diagonal\n* matrices D_i.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, E contains the subdiagonal elements of the unit\n* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, contain the base points sigma_i on output.\n*\n* E2 (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* SPLTOL (input) REAL \n* The threshold for splitting.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n* M (output) INTEGER\n* The total number of eigenvalues (of all L_i D_i L_i^T)\n* found.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the eigenvalues. The\n* eigenvalues of each of the blocks, L_i D_i L_i^T, are\n* sorted in ascending order ( SLARRE may use the\n* remaining N-M elements as workspace).\n*\n* WERR (output) REAL array, dimension (N)\n* The error bound on the corresponding eigenvalue in W.\n*\n* WGAP (output) REAL array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n* The gap is only with respect to the eigenvalues of the same block\n* as each block has its own representation tree.\n* Exception: at the right end of a block we store the left gap\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n*\n* GERS (output) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* PIVMIN (output) REAL\n* The minimum pivot in the Sturm sequence for T.\n*\n* WORK (workspace) REAL array, dimension (6*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: A problem occured in SLARRE.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in SLARRD.\n* = 2: No base representation could be found in MAXTRY iterations.\n* Increasing MAXTRY and recompilation might be a remedy.\n* =-3: Problem in SLARRB when computing the refined root\n* representation for SLASQ2.\n* =-4: Problem in SLARRB when preforming bisection on the\n* desired part of the spectrum.\n* =-5: Problem in SLASQ2.\n* =-6: Problem in SLASQ2.\n*\n\n* Further Details\n* The base representations are required to suffer very little\n* element growth and consequently define all their eigenvalues to\n* high relative accuracy.\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 nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.slarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [: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_range = argv[0];
+ rblapack_vl = argv[1];
+ rblapack_vu = argv[2];
+ rblapack_il = argv[3];
+ rblapack_iu = argv[4];
+ rblapack_d = argv[5];
+ rblapack_e = argv[6];
+ rblapack_e2 = argv[7];
+ rblapack_rtol1 = argv[8];
+ rblapack_rtol2 = argv[9];
+ rblapack_spltol = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (7th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_e);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ rtol1 = (real)NUM2DBL(rblapack_rtol1);
+ spltol = (real)NUM2DBL(rblapack_spltol);
+ vl = (real)NUM2DBL(rblapack_vl);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (6th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (6th 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 e");
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ rtol2 = (real)NUM2DBL(rblapack_rtol2);
+ il = NUM2INT(rblapack_il);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
+ if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ werr = NA_PTR_TYPE(rblapack_werr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wgap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wgap = NA_PTR_TYPE(rblapack_wgap, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ {
+ int shape[1];
+ shape[0] = 2*n;
+ rblapack_gers = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ gers = NA_PTR_TYPE(rblapack_gers, real*);
+ {
+ 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_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, real*);
+ MEMCPY(e2_out__, e2, real, NA_TOTAL(rblapack_e2));
+ rblapack_e2 = rblapack_e2_out__;
+ e2 = e2_out__;
+ work = ALLOC_N(real, (6*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ slarre_(&range, &n, &vl, &vu, &il, &iu, d, e, e2, &rtol1, &rtol2, &spltol, &nsplit, isplit, &m, w, werr, wgap, iblock, indexw, gers, &pivmin, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_nsplit = INT2NUM(nsplit);
+ rblapack_m = INT2NUM(m);
+ rblapack_pivmin = rb_float_new((double)pivmin);
+ rblapack_info = INT2NUM(info);
+ rblapack_vl = rb_float_new((double)vl);
+ rblapack_vu = rb_float_new((double)vu);
+ return rb_ary_new3(16, rblapack_nsplit, rblapack_isplit, rblapack_m, rblapack_w, rblapack_werr, rblapack_wgap, rblapack_iblock, rblapack_indexw, rblapack_gers, rblapack_pivmin, rblapack_info, rblapack_vl, rblapack_vu, rblapack_d, rblapack_e, rblapack_e2);
+}
+
+void
+init_lapack_slarre(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarre", rblapack_slarre, -1);
+}
diff --git a/ext/slarrf.c b/ext/slarrf.c
new file mode 100644
index 0000000..4b7f3e9
--- /dev/null
+++ b/ext/slarrf.c
@@ -0,0 +1,176 @@
+#include "rb_lapack.h"
+
+extern VOID slarrf_(integer* n, real* d, real* l, real* ld, integer* clstrt, integer* clend, real* w, real* wgap, real* werr, real* spdiam, real* clgapl, real* clgapr, real* pivmin, real* sigma, real* dplus, real* lplus, real* work, integer* info);
+
+
+static VALUE
+rblapack_slarrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_l;
+ real *l;
+ VALUE rblapack_ld;
+ real *ld;
+ VALUE rblapack_clstrt;
+ integer clstrt;
+ VALUE rblapack_clend;
+ integer clend;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_wgap;
+ real *wgap;
+ VALUE rblapack_werr;
+ real *werr;
+ VALUE rblapack_spdiam;
+ real spdiam;
+ VALUE rblapack_clgapl;
+ real clgapl;
+ VALUE rblapack_clgapr;
+ real clgapr;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_sigma;
+ real sigma;
+ VALUE rblapack_dplus;
+ real *dplus;
+ VALUE rblapack_lplus;
+ real *lplus;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_wgap_out__;
+ real *wgap_out__;
+ real *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 sigma, dplus, lplus, info, wgap = NumRu::Lapack.slarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial representation L D L^T and its cluster of close\n* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n* W( CLEND ), SLARRF finds a new relatively robust representation\n* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix (subblock, if the matrix splitted).\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* L (input) REAL array, dimension (N-1)\n* The (N-1) subdiagonal elements of the unit bidiagonal\n* matrix L.\n*\n* LD (input) REAL array, dimension (N-1)\n* The (N-1) elements L(i)*D(i).\n*\n* CLSTRT (input) INTEGER\n* The index of the first eigenvalue in the cluster.\n*\n* CLEND (input) INTEGER\n* The index of the last eigenvalue in the cluster.\n*\n* W (input) REAL array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n* W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n* close eigenalues.\n*\n* WGAP (input/output) REAL array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The separation from the right neighbor eigenvalue in W.\n*\n* WERR (input) REAL array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* WERR contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue APPROXIMATION in W\n*\n* SPDIAM (input) REAL\n* estimate of the spectral diameter obtained from the\n* Gerschgorin intervals\n*\n* CLGAPL (input) REAL\n*\n* CLGAPR (input) REAL\n* absolute gap on each end of the cluster.\n* Set by the calling routine to protect against shifts too close\n* to eigenvalues outside the cluster.\n*\n* PIVMIN (input) REAL\n* The minimum pivot allowed in the Sturm sequence.\n*\n* SIGMA (output) REAL \n* The shift used to form L(+) D(+) L(+)^T.\n*\n* DPLUS (output) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D(+).\n*\n* LPLUS (output) REAL array, dimension (N-1)\n* The first (N-1) elements of LPLUS contain the subdiagonal\n* elements of the unit bidiagonal matrix L(+).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Workspace.\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 sigma, dplus, lplus, info, wgap = NumRu::Lapack.slarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [: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_d = argv[0];
+ rblapack_l = argv[1];
+ rblapack_ld = argv[2];
+ rblapack_clstrt = argv[3];
+ rblapack_clend = argv[4];
+ rblapack_w = argv[5];
+ rblapack_wgap = argv[6];
+ rblapack_werr = argv[7];
+ rblapack_spdiam = argv[8];
+ rblapack_clgapl = argv[9];
+ rblapack_clgapr = argv[10];
+ rblapack_pivmin = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_ld))
+ rb_raise(rb_eArgError, "ld (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ld) != 1)
+ rb_raise(rb_eArgError, "rank of ld (3th 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_SFLOAT)
+ rblapack_ld = na_change_type(rblapack_ld, NA_SFLOAT);
+ ld = NA_PTR_TYPE(rblapack_ld, real*);
+ clend = NUM2INT(rblapack_clend);
+ spdiam = (real)NUM2DBL(rblapack_spdiam);
+ clgapr = (real)NUM2DBL(rblapack_clgapr);
+ if (!NA_IsNArray(rblapack_l))
+ rb_raise(rb_eArgError, "l (2th argument) must be NArray");
+ if (NA_RANK(rblapack_l) != 1)
+ rb_raise(rb_eArgError, "rank of l (2th 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_SFLOAT)
+ rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
+ l = NA_PTR_TYPE(rblapack_l, real*);
+ clgapl = (real)NUM2DBL(rblapack_clgapl);
+ clstrt = NUM2INT(rblapack_clstrt);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (7th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != (clend-clstrt+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", clend-clstrt+1);
+ if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, real*);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (6th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != (clend-clstrt+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be %d", clend-clstrt+1);
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != (clend-clstrt+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be %d", clend-clstrt+1);
+ if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dplus = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dplus = NA_PTR_TYPE(rblapack_dplus, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_lplus = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ lplus = NA_PTR_TYPE(rblapack_lplus, real*);
+ {
+ int shape[1];
+ shape[0] = clend-clstrt+1;
+ rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
+ MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ work = ALLOC_N(real, (2*n));
+
+ slarrf_(&n, d, l, ld, &clstrt, &clend, w, wgap, werr, &spdiam, &clgapl, &clgapr, &pivmin, &sigma, dplus, lplus, work, &info);
+
+ free(work);
+ rblapack_sigma = rb_float_new((double)sigma);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_sigma, rblapack_dplus, rblapack_lplus, rblapack_info, rblapack_wgap);
+}
+
+void
+init_lapack_slarrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrf", rblapack_slarrf, -1);
+}
diff --git a/ext/slarrj.c b/ext/slarrj.c
new file mode 100644
index 0000000..d67e4cc
--- /dev/null
+++ b/ext/slarrj.c
@@ -0,0 +1,147 @@
+#include "rb_lapack.h"
+
+extern VOID slarrj_(integer* n, real* d, real* e2, integer* ifirst, integer* ilast, real* rtol, integer* offset, real* w, real* werr, real* work, integer* iwork, real* pivmin, real* spdiam, integer* info);
+
+
+static VALUE
+rblapack_slarrj(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e2;
+ real *e2;
+ VALUE rblapack_ifirst;
+ integer ifirst;
+ VALUE rblapack_ilast;
+ integer ilast;
+ VALUE rblapack_rtol;
+ real rtol;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_werr;
+ real *werr;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_spdiam;
+ real spdiam;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_w_out__;
+ real *w_out__;
+ VALUE rblapack_werr_out__;
+ real *werr_out__;
+ 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 info, w, werr = NumRu::Lapack.slarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial eigenvalue approximations of T, SLARRJ\n* does bisection to refine the eigenvalues of T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses in WERR. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of T.\n*\n* E2 (input) REAL array, dimension (N-1)\n* The Squares of the (N-1) subdiagonal elements of T.\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL (input) REAL \n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) REAL array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST through\n* ILAST.\n* On output, these estimates are refined.\n*\n* WERR (input/output) REAL array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) REAL\n* The minimum pivot in the Sturm sequence for T.\n*\n* SPDIAM (input) REAL\n* The spectral diameter of T.\n*\n* INFO (output) INTEGER\n* Error flag.\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 info, w, werr = NumRu::Lapack.slarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_d = argv[0];
+ rblapack_e2 = argv[1];
+ rblapack_ifirst = argv[2];
+ rblapack_ilast = argv[3];
+ rblapack_rtol = argv[4];
+ rblapack_offset = argv[5];
+ rblapack_w = argv[6];
+ rblapack_werr = argv[7];
+ rblapack_pivmin = argv[8];
+ rblapack_spdiam = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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*);
+ ifirst = NUM2INT(rblapack_ifirst);
+ rtol = (real)NUM2DBL(rblapack_rtol);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (7th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ ilast = NUM2INT(rblapack_ilast);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, real*);
+ if (!NA_IsNArray(rblapack_e2))
+ rb_raise(rb_eArgError, "e2 (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
+ if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, real*);
+ spdiam = (real)NUM2DBL(rblapack_spdiam);
+ offset = NUM2INT(rblapack_offset);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
+ MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
+ MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ work = ALLOC_N(real, (2*n));
+ iwork = ALLOC_N(integer, (2*n));
+
+ slarrj_(&n, d, e2, &ifirst, &ilast, &rtol, &offset, w, werr, work, iwork, &pivmin, &spdiam, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_w, rblapack_werr);
+}
+
+void
+init_lapack_slarrj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrj", rblapack_slarrj, -1);
+}
diff --git a/ext/slarrk.c b/ext/slarrk.c
new file mode 100644
index 0000000..4208af1
--- /dev/null
+++ b/ext/slarrk.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID slarrk_(integer* n, integer* iw, real* gl, real* gu, real* d, real* e2, real* pivmin, real* reltol, real* w, real* werr, integer* info);
+
+
+static VALUE
+rblapack_slarrk(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_iw;
+ integer iw;
+ VALUE rblapack_gl;
+ real gl;
+ VALUE rblapack_gu;
+ real gu;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e2;
+ real *e2;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_reltol;
+ real reltol;
+ VALUE rblapack_w;
+ real w;
+ VALUE rblapack_werr;
+ real werr;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 w, werr, info = NumRu::Lapack.slarrk( iw, gl, gu, d, e2, pivmin, reltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n* Purpose\n* =======\n*\n* SLARRK computes one eigenvalue of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from SSTEMR.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* IW (input) INTEGER\n* The index of the eigenvalues to be returned.\n*\n* GL (input) REAL \n* GU (input) REAL \n* An upper and a lower bound on the eigenvalue.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) REAL array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) REAL \n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* RELTOL (input) REAL \n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* W (output) REAL \n*\n* WERR (output) REAL \n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* INFO (output) INTEGER\n* = 0: Eigenvalue converged\n* = -1: Eigenvalue did NOT converge\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE REAL , default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, werr, info = NumRu::Lapack.slarrk( iw, gl, gu, d, e2, pivmin, reltol, [: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_iw = argv[0];
+ rblapack_gl = argv[1];
+ rblapack_gu = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e2 = argv[4];
+ rblapack_pivmin = argv[5];
+ rblapack_reltol = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ iw = NUM2INT(rblapack_iw);
+ gu = (real)NUM2DBL(rblapack_gu);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ gl = (real)NUM2DBL(rblapack_gl);
+ reltol = (real)NUM2DBL(rblapack_reltol);
+ 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);
+ 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_e2))
+ rb_raise(rb_eArgError, "e2 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e2) != 1)
+ rb_raise(rb_eArgError, "rank of e2 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e2) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
+ if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
+ rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
+ e2 = NA_PTR_TYPE(rblapack_e2, real*);
+
+ slarrk_(&n, &iw, &gl, &gu, d, e2, &pivmin, &reltol, &w, &werr, &info);
+
+ rblapack_w = rb_float_new((double)w);
+ rblapack_werr = rb_float_new((double)werr);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_w, rblapack_werr, rblapack_info);
+}
+
+void
+init_lapack_slarrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrk", rblapack_slarrk, -1);
+}
diff --git a/ext/slarrr.c b/ext/slarrr.c
new file mode 100644
index 0000000..474b3ae
--- /dev/null
+++ b/ext/slarrr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID slarrr_(integer* n, real* d, real* e, integer* info);
+
+
+static VALUE
+rblapack_slarrr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ 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, e = NumRu::Lapack.slarrr( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRR( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* Perform tests to decide whether the symmetric tridiagonal matrix T\n* warrants expensive computations which guarantee high relative accuracy\n* in the eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the tridiagonal matrix T.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) is set to ZERO.\n*\n* INFO (output) INTEGER\n* INFO = 0(default) : the matrix warrants computations preserving\n* relative accuracy.\n* INFO = 1 : the matrix warrants computations guaranteeing\n* only absolute accuracy.\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 info, e = NumRu::Lapack.slarrr( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ slarrr_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_e);
+}
+
+void
+init_lapack_slarrr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrr", rblapack_slarrr, -1);
+}
diff --git a/ext/slarrv.c b/ext/slarrv.c
new file mode 100644
index 0000000..cf1e9d3
--- /dev/null
+++ b/ext/slarrv.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID slarrv_(integer* n, real* vl, real* vu, real* d, real* l, real* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, real* minrgp, real* rtol1, real* rtol2, real* w, real* werr, real* wgap, integer* iblock, integer* indexw, real* gers, real* z, integer* ldz, integer* isuppz, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slarrv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_l;
+ real *l;
+ VALUE rblapack_pivmin;
+ real pivmin;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_dol;
+ integer dol;
+ VALUE rblapack_dou;
+ integer dou;
+ VALUE rblapack_minrgp;
+ real minrgp;
+ VALUE rblapack_rtol1;
+ real rtol1;
+ VALUE rblapack_rtol2;
+ real rtol2;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_werr;
+ real *werr;
+ VALUE rblapack_wgap;
+ real *wgap;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ VALUE rblapack_gers;
+ real *gers;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_l_out__;
+ real *l_out__;
+ VALUE rblapack_w_out__;
+ real *w_out__;
+ VALUE rblapack_werr_out__;
+ real *werr_out__;
+ VALUE rblapack_wgap_out__;
+ real *wgap_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+
+ 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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.slarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by SLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) REAL \n* VU (input) REAL \n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by SLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (input) REAL\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) REAL \n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) REAL array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from SLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) REAL array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) REAL array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) REAL array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in SLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in SLARRB when refining a child's eigenvalues.\n* =-2: Problem in SLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in SLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.slarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 18 && argc != 18)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
+ rblapack_vl = argv[0];
+ rblapack_vu = argv[1];
+ rblapack_d = argv[2];
+ rblapack_l = argv[3];
+ rblapack_pivmin = argv[4];
+ rblapack_isplit = argv[5];
+ rblapack_m = argv[6];
+ rblapack_dol = argv[7];
+ rblapack_dou = argv[8];
+ rblapack_minrgp = argv[9];
+ rblapack_rtol1 = argv[10];
+ rblapack_rtol2 = argv[11];
+ rblapack_w = argv[12];
+ rblapack_werr = argv[13];
+ rblapack_wgap = argv[14];
+ rblapack_iblock = argv[15];
+ rblapack_indexw = argv[16];
+ rblapack_gers = argv[17];
+ if (argc == 18) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vl = (real)NUM2DBL(rblapack_vl);
+ 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*);
+ pivmin = (real)NUM2DBL(rblapack_pivmin);
+ m = NUM2INT(rblapack_m);
+ dou = NUM2INT(rblapack_dou);
+ rtol1 = (real)NUM2DBL(rblapack_rtol1);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (13th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, real*);
+ if (!NA_IsNArray(rblapack_indexw))
+ rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
+ if (NA_RANK(rblapack_indexw) != 1)
+ rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indexw) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indexw) != NA_LINT)
+ rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ minrgp = (real)NUM2DBL(rblapack_minrgp);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, real*);
+ if (!NA_IsNArray(rblapack_l))
+ rb_raise(rb_eArgError, "l (4th argument) must be NArray");
+ if (NA_RANK(rblapack_l) != 1)
+ rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_l) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_l) != NA_SFLOAT)
+ rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
+ l = NA_PTR_TYPE(rblapack_l, real*);
+ rtol2 = (real)NUM2DBL(rblapack_rtol2);
+ dol = NUM2INT(rblapack_dol);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ ldz = n;
+ if (!NA_IsNArray(rblapack_gers))
+ rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
+ if (NA_RANK(rblapack_gers) != 1)
+ rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_gers) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
+ if (NA_TYPE(rblapack_gers) != NA_SFLOAT)
+ rblapack_gers = na_change_type(rblapack_gers, NA_SFLOAT);
+ gers = NA_PTR_TYPE(rblapack_gers, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ 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_l_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ l_out__ = NA_PTR_TYPE(rblapack_l_out__, real*);
+ MEMCPY(l_out__, l, real, NA_TOTAL(rblapack_l));
+ rblapack_l = rblapack_l_out__;
+ l = l_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
+ MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
+ MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
+ MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ work = ALLOC_N(real, (12*n));
+ iwork = ALLOC_N(integer, (7*n));
+
+ slarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
+}
+
+void
+init_lapack_slarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarrv", rblapack_slarrv, -1);
+}
diff --git a/ext/slarscl2.c b/ext/slarscl2.c
new file mode 100644
index 0000000..7210533
--- /dev/null
+++ b/ext/slarscl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID slarscl2_(integer* m, integer* n, real* d, real* x, integer* ldx);
+
+
+static VALUE
+rblapack_slarscl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.slarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* SLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.slarscl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = 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_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ 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__;
+
+ slarscl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_slarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarscl2", rblapack_slarscl2, -1);
+}
diff --git a/ext/slartg.c b/ext/slartg.c
new file mode 100644
index 0000000..7738c77
--- /dev/null
+++ b/ext/slartg.c
@@ -0,0 +1,61 @@
+#include "rb_lapack.h"
+
+extern VOID slartg_(real* f, real* g, real* cs, real* sn, real* r);
+
+
+static VALUE
+rblapack_slartg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ real f;
+ VALUE rblapack_g;
+ real g;
+ VALUE rblapack_cs;
+ real cs;
+ VALUE rblapack_sn;
+ real sn;
+ VALUE rblapack_r;
+ real r;
+
+
+ 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 cs, sn, r = NumRu::Lapack.slartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* SLARTG generate a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the BLAS1 routine SROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n* floating point operations (saves work in SBDSQR when\n* there are zeros on the diagonal).\n*\n* If F exceeds G in magnitude, CS will be positive.\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The first component of vector to be rotated.\n*\n* G (input) REAL\n* The second component of vector to be rotated.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) REAL\n* The sine of the rotation.\n*\n* R (output) REAL\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.slartg( f, g, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = (real)NUM2DBL(rblapack_f);
+ g = (real)NUM2DBL(rblapack_g);
+
+ slartg_(&f, &g, &cs, &sn, &r);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ rblapack_r = rb_float_new((double)r);
+ return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
+}
+
+void
+init_lapack_slartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slartg", rblapack_slartg, -1);
+}
diff --git a/ext/slartgp.c b/ext/slartgp.c
new file mode 100644
index 0000000..d485d39
--- /dev/null
+++ b/ext/slartgp.c
@@ -0,0 +1,61 @@
+#include "rb_lapack.h"
+
+extern VOID slartgp_(real* f, real* g, real* cs, real* sn, real* r);
+
+
+static VALUE
+rblapack_slartgp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ real f;
+ VALUE rblapack_g;
+ real g;
+ VALUE rblapack_cs;
+ real cs;
+ VALUE rblapack_sn;
+ real sn;
+ VALUE rblapack_r;
+ real r;
+
+
+ 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 cs, sn, r = NumRu::Lapack.slartgp( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTGP( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* SLARTGP generates a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the Level 1 BLAS routine SROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=(+/-)1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n*\n* The sign is chosen so that R >= 0.\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The first component of vector to be rotated.\n*\n* G (input) REAL\n* The second component of vector to be rotated.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) REAL\n* The sine of the rotation.\n*\n* R (output) REAL\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.slartgp( f, g, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = (real)NUM2DBL(rblapack_f);
+ g = (real)NUM2DBL(rblapack_g);
+
+ slartgp_(&f, &g, &cs, &sn, &r);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ rblapack_r = rb_float_new((double)r);
+ return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
+}
+
+void
+init_lapack_slartgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slartgp", rblapack_slartgp, -1);
+}
diff --git a/ext/slartgs.c b/ext/slartgs.c
new file mode 100644
index 0000000..217efb1
--- /dev/null
+++ b/ext/slartgs.c
@@ -0,0 +1,62 @@
+#include "rb_lapack.h"
+
+extern VOID slartgs_(real* x, real* y, real* sigma, real* cs, real* sn);
+
+
+static VALUE
+rblapack_slartgs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ real x;
+ VALUE rblapack_y;
+ real y;
+ VALUE rblapack_sigma;
+ real sigma;
+ VALUE rblapack_cs;
+ real cs;
+ VALUE rblapack_sn;
+ real sn;
+
+
+ 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 cs, sn = NumRu::Lapack.slartgs( x, y, sigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN )\n\n* Purpose\n* =======\n*\n* SLARTGS generates a plane rotation designed to introduce a bulge in\n* Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n* problem. X and Y are the top-row entries, and SIGMA is the shift.\n* The computed CS and SN define a plane rotation satisfying\n*\n* [ CS SN ] . [ X^2 - SIGMA ] = [ R ],\n* [ -SN CS ] [ X * Y ] [ 0 ]\n*\n* with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the\n* rotation is by PI/2.\n*\n\n* Arguments\n* =========\n*\n* X (input) REAL\n* The (1,1) entry of an upper bidiagonal matrix.\n*\n* Y (input) REAL\n* The (1,2) entry of an upper bidiagonal matrix.\n*\n* SIGMA (input) REAL\n* The shift.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) REAL\n* The sine of the rotation.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn = NumRu::Lapack.slartgs( x, y, sigma, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_sigma = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x = (real)NUM2DBL(rblapack_x);
+ sigma = (real)NUM2DBL(rblapack_sigma);
+ y = (real)NUM2DBL(rblapack_y);
+
+ slartgs_(&x, &y, &sigma, &cs, &sn);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_float_new((double)sn);
+ return rb_ary_new3(2, rblapack_cs, rblapack_sn);
+}
+
+void
+init_lapack_slartgs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slartgs", rblapack_slartgs, -1);
+}
diff --git a/ext/slartv.c b/ext/slartv.c
new file mode 100644
index 0000000..b74f8d8
--- /dev/null
+++ b/ext/slartv.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID slartv_(integer* n, real* x, integer* incx, real* y, integer* incy, real* c, real* s, integer* incc);
+
+
+static VALUE
+rblapack_slartv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ real *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_y_out__;
+ real *y_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 = NumRu::Lapack.slartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* SLARTV applies a vector of real plane rotations to elements of the\n* real vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -s(i) c(i) ) ( y(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) REAL array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (input) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) REAL 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, IY\n REAL XI, YI\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.slartv( n, x, incx, y, incy, 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_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = 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);
+ incy = NUM2INT(rblapack_incy);
+ 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_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ 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_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_SFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, real*);
+ 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_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incx;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
+ MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ slartv_(&n, x, &incx, y, &incy, c, s, &incc);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_slartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slartv", rblapack_slartv, -1);
+}
diff --git a/ext/slaruv.c b/ext/slaruv.c
new file mode 100644
index 0000000..f137091
--- /dev/null
+++ b/ext/slaruv.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID slaruv_(integer* iseed, integer* n, real* x);
+
+
+static VALUE
+rblapack_slaruv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_iseed;
+ integer *iseed;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_iseed_out__;
+ integer *iseed_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, iseed = NumRu::Lapack.slaruv( iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARUV( ISEED, N, X )\n\n* Purpose\n* =======\n*\n* SLARUV returns a vector of n random real numbers from a uniform (0,1)\n* distribution (n <= 128).\n*\n* This is an auxiliary routine called by SLARNV and CLARNV.\n*\n\n* Arguments\n* =========\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated. N <= 128.\n*\n* X (output) REAL array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine uses a multiplicative congruential method with modulus\n* 2**48 and multiplier 33952834046453 (see G.S.Fishman,\n* 'Multiplicative congruential random number generators with modulus\n* 2**b: an exhaustive analysis for b = 32 and a partial analysis for\n* b = 48', Math. Comp. 189, pp 331-344, 1990).\n*\n* 48-bit integers are stored in 4 integer array elements with 12 bits\n* per element. Hence the routine is portable across machines with\n* integers of 32 bits or more.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.slaruv( iseed, n, [: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_iseed = argv[0];
+ rblapack_n = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_iseed))
+ rb_raise(rb_eArgError, "iseed (1th argument) must be NArray");
+ if (NA_RANK(rblapack_iseed) != 1)
+ rb_raise(rb_eArgError, "rank of iseed (1th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iseed) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
+ if (NA_TYPE(rblapack_iseed) != NA_LINT)
+ rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
+ iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
+ n = NUM2INT(rblapack_n);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[1];
+ shape[0] = 4;
+ rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
+ MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
+ rblapack_iseed = rblapack_iseed_out__;
+ iseed = iseed_out__;
+
+ slaruv_(iseed, &n, x);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_iseed);
+}
+
+void
+init_lapack_slaruv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaruv", rblapack_slaruv, -1);
+}
diff --git a/ext/slarz.c b/ext/slarz.c
new file mode 100644
index 0000000..337e982
--- /dev/null
+++ b/ext/slarz.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID slarz_(char* side, integer* m, integer* n, integer* l, real* v, integer* incv, real* tau, real* c, integer* ldc, real* work);
+
+
+static VALUE
+rblapack_slarz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *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 c = NumRu::Lapack.slarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* SLARZ applies a real elementary reflector H to a real M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n*\n* H is a product of k elementary reflectors as returned by STZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) REAL array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* STZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) REAL\n* The value tau in the representation of H.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarz( side, m, l, v, incv, 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_m = argv[1];
+ rblapack_l = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ incv = NUM2INT(rblapack_incv);
+ 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_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ m = NUM2INT(rblapack_m);
+ tau = (real)NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
+ 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] = 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ slarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_slarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarz", rblapack_slarz, -1);
+}
diff --git a/ext/slarzb.c b/ext/slarzb.c
new file mode 100644
index 0000000..9574d58
--- /dev/null
+++ b/ext/slarzb.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID slarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, real* v, integer* ldv, real* t, integer* ldt, real* c, integer* ldc, real* work, integer* ldwork);
+
+
+static VALUE
+rblapack_slarzb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer ldv;
+ integer nv;
+ integer ldt;
+ integer k;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.slarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* SLARZB applies a real block reflector H or its transpose H**T to\n* a real distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) REAL array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) REAL array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_l = argv[5];
+ rblapack_v = argv[6];
+ rblapack_t = argv[7];
+ rblapack_c = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ nv = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (9th 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ l = NUM2INT(rblapack_l);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (8th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (ldwork)*(k));
+
+ slarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_slarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarzb", rblapack_slarzb, -1);
+}
diff --git a/ext/slarzt.c b/ext/slarzt.c
new file mode 100644
index 0000000..36d480e
--- /dev/null
+++ b/ext/slarzt.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID slarzt_(char* direct, char* storev, integer* n, integer* k, real* v, integer* ldv, real* tau, real* t, integer* ldt);
+
+
+static VALUE
+rblapack_slarzt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_v_out__;
+ real *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.slarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* SLARZT forms the triangular factor T of a real block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) REAL array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) REAL array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.slarzt( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ 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] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ 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__;
+
+ slarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_slarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slarzt", rblapack_slarzt, -1);
+}
diff --git a/ext/slas2.c b/ext/slas2.c
new file mode 100644
index 0000000..d8e042f
--- /dev/null
+++ b/ext/slas2.c
@@ -0,0 +1,62 @@
+#include "rb_lapack.h"
+
+extern VOID slas2_(real* f, real* g, real* h, real* ssmin, real* ssmax);
+
+
+static VALUE
+rblapack_slas2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ real f;
+ VALUE rblapack_g;
+ real g;
+ VALUE rblapack_h;
+ real h;
+ VALUE rblapack_ssmin;
+ real ssmin;
+ VALUE rblapack_ssmax;
+ real ssmax;
+
+
+ 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 ssmin, ssmax = NumRu::Lapack.slas2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )\n\n* Purpose\n* =======\n*\n* SLAS2 computes the singular values of the 2-by-2 matrix\n* [ F G ]\n* [ 0 H ].\n* On return, SSMIN is the smaller singular value and SSMAX is the\n* larger singular value.\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) REAL\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) REAL\n* The smaller singular value.\n*\n* SSMAX (output) REAL\n* The larger singular value.\n*\n\n* Further Details\n* ===============\n*\n* Barring over/underflow, all output quantities are correct to within\n* a few units in the last place (ulps), even in the absence of a guard\n* digit in addition/subtraction.\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows, or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* ====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, ssmax = NumRu::Lapack.slas2( f, g, h, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ rblapack_h = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = (real)NUM2DBL(rblapack_f);
+ h = (real)NUM2DBL(rblapack_h);
+ g = (real)NUM2DBL(rblapack_g);
+
+ slas2_(&f, &g, &h, &ssmin, &ssmax);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ rblapack_ssmax = rb_float_new((double)ssmax);
+ return rb_ary_new3(2, rblapack_ssmin, rblapack_ssmax);
+}
+
+void
+init_lapack_slas2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slas2", rblapack_slas2, -1);
+}
diff --git a/ext/slascl.c b/ext/slascl.c
new file mode 100644
index 0000000..b04826e
--- /dev/null
+++ b/ext/slascl.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID slascl_(char* type, integer* kl, integer* ku, real* cfrom, real* cto, integer* m, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_slascl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_type;
+ char type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_cfrom;
+ real cfrom;
+ VALUE rblapack_cto;
+ real cto;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.slascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLASCL multiplies the M by N real matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See SGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) REAL\n* CTO (input) REAL\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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, a = NumRu::Lapack.slascl( type, kl, ku, cfrom, cto, m, a, [: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_type = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_cfrom = argv[3];
+ rblapack_cto = argv[4];
+ rblapack_m = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ type = StringValueCStr(rblapack_type)[0];
+ ku = NUM2INT(rblapack_ku);
+ cto = (real)NUM2DBL(rblapack_cto);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ kl = NUM2INT(rblapack_kl);
+ m = NUM2INT(rblapack_m);
+ cfrom = (real)NUM2DBL(rblapack_cfrom);
+ {
+ 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__;
+
+ slascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_slascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slascl", rblapack_slascl, -1);
+}
diff --git a/ext/slascl2.c b/ext/slascl2.c
new file mode 100644
index 0000000..7dd7497
--- /dev/null
+++ b/ext/slascl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID slascl2_(integer* m, integer* n, real* d, real* x, integer* ldx);
+
+
+static VALUE
+rblapack_slascl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.slascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* SLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.slascl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = 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_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ 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__;
+
+ slascl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_slascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slascl2", rblapack_slascl2, -1);
+}
diff --git a/ext/slasd0.c b/ext/slasd0.c
new file mode 100644
index 0000000..d00a8af
--- /dev/null
+++ b/ext/slasd0.c
@@ -0,0 +1,120 @@
+#include "rb_lapack.h"
+
+extern VOID slasd0_(integer* n, integer* sqre, real* d, real* e, real* u, integer* ldu, real* vt, integer* ldvt, integer* smlsiz, integer* iwork, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasd0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ integer *iwork;
+ real *work;
+
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, info, d = NumRu::Lapack.slasd0( sqre, d, e, smlsiz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, SLASD0 computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M\n* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n* The algorithm computes orthogonal matrices U and VT such that\n* B = U * S * VT. The singular values S are overwritten on D.\n*\n* A related subroutine, SLASDA, computes only the singular values,\n* and optionally, the singular vectors in compact form.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the row dimension of the upper bidiagonal matrix.\n* This is also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N+1;\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix.\n* On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) REAL array, dimension (M-1)\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) REAL array, dimension at least (LDQ, N)\n* On exit, U contains the left singular vectors.\n*\n* LDU (input) INTEGER\n* On entry, leading dimension of U.\n*\n* VT (output) REAL array, dimension at least (LDVT, M)\n* On exit, VT' contains the right singular vectors.\n*\n* LDVT (input) INTEGER\n* On entry, leading dimension of VT.\n*\n* SMLSIZ (input) INTEGER\n* On entry, maximum size of the subproblems at the\n* bottom of the computation tree.\n*\n* IWORK (workspace) INTEGER array, dimension (8*N)\n*\n* WORK (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n REAL ALPHA, BETA\n* ..\n* .. External Subroutines ..\n EXTERNAL SLASD1, SLASDQ, SLASDT, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, info, d = NumRu::Lapack.slasd0( sqre, d, e, smlsiz, [: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_sqre = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_smlsiz = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ sqre = NUM2INT(rblapack_sqre);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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*);
+ m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
+ ldu = n;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ ldvt = m;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ {
+ 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__;
+ iwork = ALLOC_N(integer, (8*n));
+ work = ALLOC_N(real, (3*pow(m,2)+2*m));
+
+ slasd0_(&n, &sqre, d, e, u, &ldu, vt, &ldvt, &smlsiz, iwork, work, &info);
+
+ free(iwork);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_u, rblapack_vt, rblapack_info, rblapack_d);
+}
+
+void
+init_lapack_slasd0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd0", rblapack_slasd0, -1);
+}
diff --git a/ext/slasd1.c b/ext/slasd1.c
new file mode 100644
index 0000000..28da4a7
--- /dev/null
+++ b/ext/slasd1.c
@@ -0,0 +1,160 @@
+#include "rb_lapack.h"
+
+extern VOID slasd1_(integer* nl, integer* nr, integer* sqre, real* d, real* alpha, real* beta, real* u, integer* ldu, real* vt, integer* ldvt, integer* idxq, integer* iwork, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasd1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_u_out__;
+ real *u_out__;
+ VALUE rblapack_vt_out__;
+ real *vt_out__;
+ integer *iwork;
+ real *work;
+
+ integer ldu;
+ integer n;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.slasd1( nl, nr, sqre, d, alpha, beta, u, vt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n* where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.\n*\n* A related subroutine SLASD7 handles the case in which the singular\n* values (and the singular vectors in factored form) are desired.\n*\n* SLASD1 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The left singular vectors of the original matrix are stored in U, and\n* the transpose of the right singular vectors are stored in VT, and the\n* singular values are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or when there are zeros in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLASD2.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the square roots of the\n* roots of the secular equation via the routine SLASD4 (as called\n* by SLASD3). This routine also calculates the singular vectors of\n* the current problem.\n*\n* The final stage consists of computing the updated singular vectors\n* directly using the updated singular values. The singular vectors\n* for the current problem are multiplied with the singular vectors\n* from the overall problem.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) REAL array, dimension (NL+NR+1).\n* N = NL+NR+1\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block; and D(NL+2:N) contains the singular values of\n* the lower block. On exit D(1:N) contains the singular values\n* of the modified matrix.\n*\n* ALPHA (input/output) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) REAL array, dimension (LDU,N)\n* On entry U(1:NL, 1:NL) contains the left singular vectors of\n* the upper block; U(NL+2:N, NL+2:N) contains the left singular\n* vectors of the lower block. On exit U contains the left\n* singular vectors of the bidiagonal matrix.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max( 1, N ).\n*\n* VT (input/output) REAL array, dimension (LDVT,M)\n* where M = N + SQRE.\n* On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n* the right singular vectors of the lower block. On exit\n* VT' contains the right singular vectors of the\n* bidiagonal matrix.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= max( 1, M ).\n*\n* IDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* WORK (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.slasd1( nl, nr, sqre, d, alpha, beta, u, vt, [: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_nl = argv[0];
+ rblapack_nr = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_d = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_u = argv[6];
+ rblapack_vt = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nl = NUM2INT(rblapack_nl);
+ sqre = NUM2INT(rblapack_sqre);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (7th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ n = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ m = n + sqre;
+ nr = NUM2INT(rblapack_nr);
+ beta = (real)NUM2DBL(rblapack_beta);
+ 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) != (nl+nr+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
+ 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_vt))
+ rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ if (NA_SHAPE1(rblapack_vt) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vt must be n + sqre");
+ if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ {
+ int shape[1];
+ shape[0] = nl+nr+1;
+ 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[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
+ MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
+ MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ iwork = ALLOC_N(integer, (4*n));
+ work = ALLOC_N(real, (3*pow(m,2)+2*m));
+
+ slasd1_(&nl, &nr, &sqre, d, &alpha, &beta, u, &ldu, vt, &ldvt, idxq, iwork, work, &info);
+
+ free(iwork);
+ free(work);
+ rblapack_info = INT2NUM(info);
+ rblapack_alpha = rb_float_new((double)alpha);
+ rblapack_beta = rb_float_new((double)beta);
+ return rb_ary_new3(7, rblapack_idxq, rblapack_info, rblapack_d, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_vt);
+}
+
+void
+init_lapack_slasd1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd1", rblapack_slasd1, -1);
+}
diff --git a/ext/slasd2.c b/ext/slasd2.c
new file mode 100644
index 0000000..cbd0855
--- /dev/null
+++ b/ext/slasd2.c
@@ -0,0 +1,228 @@
+#include "rb_lapack.h"
+
+extern VOID slasd2_(integer* nl, integer* nr, integer* sqre, integer* k, real* d, real* z, real* alpha, real* beta, real* u, integer* ldu, real* vt, integer* ldvt, real* dsigma, real* u2, integer* ldu2, real* vt2, integer* ldvt2, integer* idxp, integer* idx, integer* idxc, integer* idxq, integer* coltyp, integer* info);
+
+
+static VALUE
+rblapack_slasd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_dsigma;
+ real *dsigma;
+ VALUE rblapack_u2;
+ real *u2;
+ VALUE rblapack_vt2;
+ real *vt2;
+ VALUE rblapack_idxc;
+ integer *idxc;
+ VALUE rblapack_coltyp;
+ integer *coltyp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_u_out__;
+ real *u_out__;
+ VALUE rblapack_vt_out__;
+ real *vt_out__;
+ VALUE rblapack_idxq_out__;
+ integer *idxq_out__;
+ integer *idxp;
+ integer *idx;
+
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+ integer ldu2;
+ integer ldvt2;
+
+ 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 k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.slasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* SLASD2 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* singular values are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n* SLASD2 is called from SLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) REAL array, dimension (N)\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ALPHA (input) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) REAL array, dimension (LDU,N)\n* On entry U contains the left singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL, NL), and (NL+2, NL+2), (N,N).\n* On exit U contains the trailing (N-K) updated left singular\n* vectors (those which were deflated) in its last N-K columns.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* VT (input/output) REAL array, dimension (LDVT,M)\n* On entry VT' contains the right singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n* On exit VT' contains the trailing (N-K) updated right singular\n* vectors (those which were deflated) in its last N-K columns.\n* In case SQRE =1, the last row of VT spans the right null\n* space.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= M.\n*\n* DSIGMA (output) REAL array, dimension (N)\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* U2 (output) REAL array, dimension (LDU2,N)\n* Contains a copy of the first K-1 left singular vectors which\n* will be used by SLASD3 in a matrix multiply (SGEMM) to solve\n* for the new left singular vectors. U2 is arranged into four\n* blocks. The first block contains a column with 1 at NL+1 and\n* zero everywhere else; the second block contains non-zero\n* entries only at and above NL; the third contains non-zero\n* entries only below NL+1; and the fourth is dense.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT2 (output) REAL array, dimension (LDVT2,N)\n* VT2' contains a copy of the first K right singular vectors\n* which will be used by SLASD3 in a matrix multiply (SGEMM) to\n* solve for the new right singular vectors. VT2 is arranged into\n* three blocks. The first block contains a row that corresponds\n* to the special 0 diagonal element in SIGMA; the second block\n* contains non-zeros only at and before NL +1; the third block\n* contains non-zeros only at and after NL +2.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= M.\n*\n* IDXP (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDX (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXC (output) INTEGER array, dimension (N)\n* This will contain the permutation used to arrange the columns\n* of the deflated U matrix into three groups: the first group\n* contains non-zero entries only at and above NL, the second\n* contains non-zero entries only below NL+2, and the third is\n* dense.\n*\n* IDXQ (input/output) INTEGER array, dimension (N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first hlaf of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* COLTYP (workspace/output) INTEGER array, dimension (N)\n* As workspace, this will contain a label which will indicate\n* which of the following types a column in the U2 matrix or a\n* row in the VT2 matrix is:\n* 1 : non-zero in the upper half only\n* 2 : non-zero in the lower half only\n* 3 : dense\n* 4 : deflated\n*\n* On exit, it is an array of dimension 4, with COLTYP(I) being\n* the dimension of the I-th type columns.\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* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.slasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_nl = argv[0];
+ rblapack_nr = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_d = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_u = argv[6];
+ rblapack_vt = argv[7];
+ rblapack_idxq = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nl = NUM2INT(rblapack_nl);
+ sqre = NUM2INT(rblapack_sqre);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (7th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ n = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ if (!NA_IsNArray(rblapack_idxq))
+ rb_raise(rb_eArgError, "idxq (9th argument) must be NArray");
+ if (NA_RANK(rblapack_idxq) != 1)
+ rb_raise(rb_eArgError, "rank of idxq (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_idxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 1 of u");
+ if (NA_TYPE(rblapack_idxq) != NA_LINT)
+ rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ nr = NUM2INT(rblapack_nr);
+ beta = (real)NUM2DBL(rblapack_beta);
+ 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 1 of u");
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ ldu2 = n;
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ m = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ ldvt2 = m;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
+ {
+ int shape[2];
+ shape[0] = ldu2;
+ shape[1] = n;
+ rblapack_u2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u2 = NA_PTR_TYPE(rblapack_u2, real*);
+ {
+ int shape[2];
+ shape[0] = ldvt2;
+ shape[1] = n;
+ rblapack_vt2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt2 = NA_PTR_TYPE(rblapack_vt2, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxc = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
+ {
+ 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[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
+ MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
+ MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxq_out__ = NA_PTR_TYPE(rblapack_idxq_out__, integer*);
+ MEMCPY(idxq_out__, idxq, integer, NA_TOTAL(rblapack_idxq));
+ rblapack_idxq = rblapack_idxq_out__;
+ idxq = idxq_out__;
+ idxp = ALLOC_N(integer, (n));
+ idx = ALLOC_N(integer, (n));
+
+ slasd2_(&nl, &nr, &sqre, &k, d, z, &alpha, &beta, u, &ldu, vt, &ldvt, dsigma, u2, &ldu2, vt2, &ldvt2, idxp, idx, idxc, idxq, coltyp, &info);
+
+ free(idxp);
+ free(idx);
+ rblapack_k = INT2NUM(k);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_u2, rblapack_vt2, rblapack_idxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_u, rblapack_vt, rblapack_idxq);
+}
+
+void
+init_lapack_slasd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd2", rblapack_slasd2, -1);
+}
diff --git a/ext/slasd3.c b/ext/slasd3.c
new file mode 100644
index 0000000..55e047f
--- /dev/null
+++ b/ext/slasd3.c
@@ -0,0 +1,212 @@
+#include "rb_lapack.h"
+
+extern VOID slasd3_(integer* nl, integer* nr, integer* sqre, integer* k, real* d, real* q, integer* ldq, real* dsigma, real* u, integer* ldu, real* u2, integer* ldu2, real* vt, integer* ldvt, real* vt2, integer* ldvt2, integer* idxc, integer* ctot, real* z, integer* info);
+
+
+static VALUE
+rblapack_slasd3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_dsigma;
+ real *dsigma;
+ VALUE rblapack_u2;
+ real *u2;
+ VALUE rblapack_vt2;
+ real *vt2;
+ VALUE rblapack_idxc;
+ integer *idxc;
+ VALUE rblapack_ctot;
+ integer *ctot;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dsigma_out__;
+ real *dsigma_out__;
+ VALUE rblapack_vt2_out__;
+ real *vt2_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *q;
+
+ integer k;
+ integer ldu2;
+ integer n;
+ integer ldvt2;
+ integer ldu;
+ integer ldvt;
+ integer m;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, u, vt, info, dsigma, vt2, z = NumRu::Lapack.slasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n* Purpose\n* =======\n*\n* SLASD3 finds all the square roots of the roots of the secular\n* equation, as defined by the values in D and Z. It makes the\n* appropriate calls to SLASD4 and then updates the singular\n* vectors by matrix multiplication.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* SLASD3 is called from SLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (input) INTEGER\n* The size of the secular equation, 1 =< K = < N.\n*\n* D (output) REAL array, dimension(K)\n* On exit the square roots of the roots of the secular equation,\n* in ascending order.\n*\n* Q (workspace) REAL array,\n* dimension at least (LDQ,K).\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= K.\n*\n* DSIGMA (input/output) REAL array, dimension(K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* U (output) REAL array, dimension (LDU, N)\n* The last N - K columns of this matrix contain the deflated\n* left singular vectors.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* U2 (input) REAL array, dimension (LDU2, N)\n* The first K columns of this matrix contain the non-deflated\n* left singular vectors for the split problem.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT (output) REAL array, dimension (LDVT, M)\n* The last M - K columns of VT' contain the deflated\n* right singular vectors.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= N.\n*\n* VT2 (input/output) REAL array, dimension (LDVT2, N)\n* The first K columns of VT2' contain the non-deflated\n* right singular vectors for the split problem.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= N.\n*\n* IDXC (input) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of U (and rows of\n* VT) into three groups: the first group contains non-zero\n* entries only at and above (or before) NL +1; the second\n* contains non-zero entries only at and below (or after) NL+2;\n* and the third is dense. The first column of U and the row of\n* VT are treated separately, however.\n*\n* The rows of the singular vectors found by SLASD4\n* must be likewise permuted before the matrix multiplies can\n* take place.\n*\n* CTOT (input) INTEGER array, dimension (4)\n* A count of the total number of the various types of columns\n* in U (or rows in VT), as described in IDXC. The fourth column\n* type is any column which has been deflated.\n*\n* Z (input/output) REAL array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, u, vt, info, dsigma, vt2, z = NumRu::Lapack.slasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_nl = argv[0];
+ rblapack_nr = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_dsigma = argv[3];
+ rblapack_u2 = argv[4];
+ rblapack_vt2 = argv[5];
+ rblapack_idxc = argv[6];
+ rblapack_ctot = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nl = NUM2INT(rblapack_nl);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_ctot))
+ rb_raise(rb_eArgError, "ctot (8th argument) must be NArray");
+ if (NA_RANK(rblapack_ctot) != 1)
+ rb_raise(rb_eArgError, "rank of ctot (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ctot) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
+ if (NA_TYPE(rblapack_ctot) != NA_LINT)
+ rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
+ ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
+ nr = NUM2INT(rblapack_nr);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ n = nl + nr + 1;
+ ldvt = n;
+ ldu = n;
+ if (!NA_IsNArray(rblapack_dsigma))
+ rb_raise(rb_eArgError, "dsigma (4th argument) must be NArray");
+ if (NA_RANK(rblapack_dsigma) != 1)
+ rb_raise(rb_eArgError, "rank of dsigma (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dsigma) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of z");
+ if (NA_TYPE(rblapack_dsigma) != NA_SFLOAT)
+ rblapack_dsigma = na_change_type(rblapack_dsigma, NA_SFLOAT);
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
+ if (!NA_IsNArray(rblapack_idxc))
+ rb_raise(rb_eArgError, "idxc (7th argument) must be NArray");
+ if (NA_RANK(rblapack_idxc) != 1)
+ rb_raise(rb_eArgError, "rank of idxc (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_idxc) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of idxc must be nl + nr + 1");
+ if (NA_TYPE(rblapack_idxc) != NA_LINT)
+ rblapack_idxc = na_change_type(rblapack_idxc, NA_LINT);
+ idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
+ ldq = k;
+ ldvt2 = n;
+ if (!NA_IsNArray(rblapack_vt2))
+ rb_raise(rb_eArgError, "vt2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vt2) != 2)
+ rb_raise(rb_eArgError, "rank of vt2 (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_vt2) != ldvt2)
+ rb_raise(rb_eRuntimeError, "shape 0 of vt2 must be n");
+ if (NA_SHAPE1(rblapack_vt2) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of vt2 must be nl + nr + 1");
+ if (NA_TYPE(rblapack_vt2) != NA_SFLOAT)
+ rblapack_vt2 = na_change_type(rblapack_vt2, NA_SFLOAT);
+ vt2 = NA_PTR_TYPE(rblapack_vt2, real*);
+ ldu2 = n;
+ if (!NA_IsNArray(rblapack_u2))
+ rb_raise(rb_eArgError, "u2 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_u2) != 2)
+ rb_raise(rb_eArgError, "rank of u2 (5th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_u2) != ldu2)
+ rb_raise(rb_eRuntimeError, "shape 0 of u2 must be n");
+ if (NA_SHAPE1(rblapack_u2) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of u2 must be nl + nr + 1");
+ if (NA_TYPE(rblapack_u2) != NA_SFLOAT)
+ rblapack_u2 = na_change_type(rblapack_u2, NA_SFLOAT);
+ u2 = NA_PTR_TYPE(rblapack_u2, real*);
+ m = n+sqre;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = m;
+ rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_dsigma_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dsigma_out__ = NA_PTR_TYPE(rblapack_dsigma_out__, real*);
+ MEMCPY(dsigma_out__, dsigma, real, NA_TOTAL(rblapack_dsigma));
+ rblapack_dsigma = rblapack_dsigma_out__;
+ dsigma = dsigma_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt2;
+ shape[1] = n;
+ rblapack_vt2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt2_out__ = NA_PTR_TYPE(rblapack_vt2_out__, real*);
+ MEMCPY(vt2_out__, vt2, real, NA_TOTAL(rblapack_vt2));
+ rblapack_vt2 = rblapack_vt2_out__;
+ vt2 = vt2_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ q = ALLOC_N(real, (ldq)*(k));
+
+ slasd3_(&nl, &nr, &sqre, &k, d, q, &ldq, dsigma, u, &ldu, u2, &ldu2, vt, &ldvt, vt2, &ldvt2, idxc, ctot, z, &info);
+
+ free(q);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_u, rblapack_vt, rblapack_info, rblapack_dsigma, rblapack_vt2, rblapack_z);
+}
+
+void
+init_lapack_slasd3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd3", rblapack_slasd3, -1);
+}
diff --git a/ext/slasd4.c b/ext/slasd4.c
new file mode 100644
index 0000000..7f55a4e
--- /dev/null
+++ b/ext/slasd4.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID slasd4_(integer* n, integer* i, real* d, real* z, real* delta, real* rho, real* sigma, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasd4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_delta;
+ real *delta;
+ VALUE rblapack_sigma;
+ real sigma;
+ VALUE rblapack_info;
+ integer info;
+ real *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 delta, sigma, info = NumRu::Lapack.slasd4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th updated\n* eigenvalue of a positive symmetric rank-one modification to\n* a positive diagonal matrix whose entries are given as the squares\n* of the corresponding entries in the array d, and that\n*\n* 0 <= D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) * diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) REAL array, dimension ( N )\n* The original eigenvalues. It is assumed that they are in\n* order, 0 <= D(I) < D(J) for I < J.\n*\n* Z (input) REAL array, dimension (N)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (N)\n* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. The vector DELTA\n* contains the information necessary to construct the\n* (singular) eigenvectors.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* SIGMA (output) REAL\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) REAL array, dimension (N)\n* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th\n* component. If N = 1, then WORK( 1 ) = 1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, sigma, info = NumRu::Lapack.slasd4( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, real*);
+ work = ALLOC_N(real, (n));
+
+ slasd4_(&n, &i, d, z, delta, &rho, &sigma, work, &info);
+
+ free(work);
+ rblapack_sigma = rb_float_new((double)sigma);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_delta, rblapack_sigma, rblapack_info);
+}
+
+void
+init_lapack_slasd4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd4", rblapack_slasd4, -1);
+}
diff --git a/ext/slasd5.c b/ext/slasd5.c
new file mode 100644
index 0000000..0a62d11
--- /dev/null
+++ b/ext/slasd5.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID slasd5_(integer* i, real* d, real* z, real* delta, real* rho, real* dsigma, real* work);
+
+
+static VALUE
+rblapack_slasd5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i;
+ integer i;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_rho;
+ real rho;
+ VALUE rblapack_delta;
+ real *delta;
+ VALUE rblapack_dsigma;
+ real dsigma;
+ real *work;
+
+
+ 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 delta, dsigma = NumRu::Lapack.slasd5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th eigenvalue\n* of a positive symmetric rank-one modification of a 2-by-2 diagonal\n* matrix\n*\n* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal entries in the array D are assumed to satisfy\n*\n* 0 <= D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) REAL array, dimension (2)\n* The original eigenvalues. We assume 0 <= D(1) < D(2).\n*\n* Z (input) REAL array, dimension (2)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (2)\n* Contains (D(j) - sigma_I) in its j-th component.\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* DSIGMA (output) REAL\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) REAL array, dimension (2)\n* WORK contains (D(j) + sigma_I) in its j-th component.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n delta, dsigma = NumRu::Lapack.slasd5( i, d, z, rho, [: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_i = argv[0];
+ rblapack_d = argv[1];
+ rblapack_z = argv[2];
+ rblapack_rho = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i = NUM2INT(rblapack_i);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_d) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ rho = (real)NUM2DBL(rblapack_rho);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ delta = NA_PTR_TYPE(rblapack_delta, real*);
+ work = ALLOC_N(real, (2));
+
+ slasd5_(&i, d, z, delta, &rho, &dsigma, work);
+
+ free(work);
+ rblapack_dsigma = rb_float_new((double)dsigma);
+ return rb_ary_new3(2, rblapack_delta, rblapack_dsigma);
+}
+
+void
+init_lapack_slasd5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd5", rblapack_slasd5, -1);
+}
diff --git a/ext/slasd6.c b/ext/slasd6.c
new file mode 100644
index 0000000..187fac8
--- /dev/null
+++ b/ext/slasd6.c
@@ -0,0 +1,236 @@
+#include "rb_lapack.h"
+
+extern VOID slasd6_(integer* icompq, integer* nl, integer* nr, integer* sqre, real* d, real* vf, real* vl, real* alpha, real* beta, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* poles, real* difl, real* difr, real* z, integer* k, real* c, real* s, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slasd6(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_vf;
+ real *vf;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_poles;
+ real *poles;
+ VALUE rblapack_difl;
+ real *difl;
+ VALUE rblapack_difr;
+ real *difr;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_s;
+ real s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_vf_out__;
+ real *vf_out__;
+ VALUE rblapack_vl_out__;
+ real *vl_out__;
+ real *work;
+ integer *iwork;
+
+ integer m;
+ integer n;
+ integer ldgcol;
+ integer ldgnum;
+
+ 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 idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASD6 computes the SVD of an updated upper bidiagonal matrix B\n* obtained by merging two smaller ones by appending a row. This\n* routine is used only for the problem which requires all singular\n* values and optionally singular vector matrices in factored form.\n* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n* A related subroutine, SLASD1, handles the case in which all singular\n* values and singular vectors of the bidiagonal matrix are desired.\n*\n* SLASD6 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The singular values of B can be computed using D1, D2, the first\n* components of all the right singular vectors of the lower block, and\n* the last components of all the right singular vectors of the upper\n* block. These components are stored and updated in VF and VL,\n* respectively, in SLASD6. Hence U and VT are not explicitly\n* referenced.\n*\n* The singular values are stored in D. The algorithm consists of two\n* stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or if there is a zero\n* in the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLASD7.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the roots of the\n* secular equation via the routine SLASD4 (as called by SLASD8).\n* This routine also updates VF and VL and computes the distances\n* between the updated singular values and the old singular\n* values.\n*\n* SLASD6 is called from SLASDA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) REAL array, dimension (NL+NR+1).\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block, and D(NL+2:N) contains the singular values\n* of the lower block. On exit D(1:N) contains the singular\n* values of the modified matrix.\n*\n* VF (input/output) REAL array, dimension (M)\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VL (input/output) REAL array, dimension (M)\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors of\n* the lower block. On exit, VL contains the last components of\n* all right singular vectors of the bidiagonal matrix.\n*\n* ALPHA (input/output) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* IDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM and POLES, must be at least N.\n*\n* POLES (output) REAL array, dimension ( LDGNUM, 2 )\n* On exit, POLES(1,*) is an array containing the new singular\n* values obtained from solving the secular equation, and\n* POLES(2,*) is an array containing the poles in the secular\n* equation. Not referenced if ICOMPQ = 0.\n*\n* DIFL (output) REAL array, dimension ( N )\n* On exit, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (output) REAL array,\n* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* On exit, DIFR(I, 1) is the distance between I-th updated\n* (undeflated) singular value and the I+1-th (undeflated) old\n* singular value.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* See SLASD8 for details on DIFL and DIFR.\n*\n* Z (output) REAL array, dimension ( M )\n* The first elements of this array contain the components\n* of the deflation-adjusted updating row vector.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (output) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) REAL array, dimension ( 4 * M )\n*\n* IWORK (workspace) INTEGER array, dimension ( 3 * N )\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_d = argv[4];
+ rblapack_vf = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_alpha = argv[7];
+ rblapack_beta = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ nl = NUM2INT(rblapack_nl);
+ 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);
+ if (NA_SHAPE0(rblapack_d) != (nl+nr+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ beta = (real)NUM2DBL(rblapack_beta);
+ n = nl + nr + 1;
+ ldgcol = n;
+ sqre = NUM2INT(rblapack_sqre);
+ m = n + sqre;
+ if (!NA_IsNArray(rblapack_vf))
+ rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vf) != 1)
+ rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vf) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of vf must be n + sqre");
+ if (NA_TYPE(rblapack_vf) != NA_SFLOAT)
+ rblapack_vf = na_change_type(rblapack_vf, NA_SFLOAT);
+ vf = NA_PTR_TYPE(rblapack_vf, real*);
+ ldgnum = n;
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 1)
+ rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vl) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of vl must be n + sqre");
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = 2;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgnum;
+ shape[1] = 2;
+ rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ {
+ int shape[2];
+ shape[0] = ldgnum;
+ shape[1] = 2;
+ rblapack_poles = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ poles = NA_PTR_TYPE(rblapack_poles, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ difl = NA_PTR_TYPE(rblapack_difl, real*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? ldgnum : icompq == 0 ? n : 0;
+ shape[1] = icompq == 1 ? 2 : 0;
+ rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ difr = NA_PTR_TYPE(rblapack_difr, real*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = nl+nr+1;
+ 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] = m;
+ rblapack_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, real*);
+ MEMCPY(vf_out__, vf, real, NA_TOTAL(rblapack_vf));
+ rblapack_vf = rblapack_vf_out__;
+ vf = vf_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
+ MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ work = ALLOC_N(real, (4 * m));
+ iwork = ALLOC_N(integer, (3 * n));
+
+ slasd6_(&icompq, &nl, &nr, &sqre, d, vf, vl, &alpha, &beta, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_k = INT2NUM(k);
+ rblapack_c = rb_float_new((double)c);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_info = INT2NUM(info);
+ rblapack_alpha = rb_float_new((double)alpha);
+ rblapack_beta = rb_float_new((double)beta);
+ return rb_ary_new3(18, rblapack_idxq, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_poles, rblapack_difl, rblapack_difr, rblapack_z, rblapack_k, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl, rblapack_alpha, rblapack_beta);
+}
+
+void
+init_lapack_slasd6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd6", rblapack_slasd6, -1);
+}
diff --git a/ext/slasd7.c b/ext/slasd7.c
new file mode 100644
index 0000000..b7b22bf
--- /dev/null
+++ b/ext/slasd7.c
@@ -0,0 +1,225 @@
+#include "rb_lapack.h"
+
+extern VOID slasd7_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* k, real* d, real* z, real* zw, real* vf, real* vfw, real* vl, real* vlw, real* alpha, real* beta, real* dsigma, integer* idx, integer* idxp, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* c, real* s, integer* info);
+
+
+static VALUE
+rblapack_slasd7(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_vf;
+ real *vf;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_idxq;
+ integer *idxq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_dsigma;
+ real *dsigma;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_c;
+ real c;
+ VALUE rblapack_s;
+ real s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_vf_out__;
+ real *vf_out__;
+ VALUE rblapack_vl_out__;
+ real *vl_out__;
+ real *zw;
+ real *vfw;
+ real *vlw;
+ integer *idx;
+ integer *idxp;
+
+ integer n;
+ integer m;
+ integer ldgcol;
+ integer ldgnum;
+
+ 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 k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.slasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n* Purpose\n* =======\n*\n* SLASD7 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem. There\n* are two ways in which deflation can occur: when two or more singular\n* values are close together or if there is a tiny entry in the Z\n* vector. For each such occurrence the order of the related\n* secular equation problem is reduced by one.\n*\n* SLASD7 is called from SLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper\n* bidiagonal matrix in compact form.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix, this is\n* the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) REAL array, dimension ( N )\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) REAL array, dimension ( M )\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ZW (workspace) REAL array, dimension ( M )\n* Workspace for Z.\n*\n* VF (input/output) REAL array, dimension ( M )\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VFW (workspace) REAL array, dimension ( M )\n* Workspace for VF.\n*\n* VL (input/output) REAL array, dimension ( M )\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors\n* of the lower block. On exit, VL contains the last components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VLW (workspace) REAL array, dimension ( M )\n* Workspace for VL.\n*\n* ALPHA (input) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* DSIGMA (output) REAL array, dimension ( N )\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* IDX (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXP (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDXQ (input) INTEGER array, dimension ( N )\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first half of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each singular block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM, must be at least N.\n*\n* C (output) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.slasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_d = argv[4];
+ rblapack_vf = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_alpha = argv[7];
+ rblapack_beta = argv[8];
+ rblapack_idxq = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ 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*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 1)
+ rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ beta = (real)NUM2DBL(rblapack_beta);
+ nl = NUM2INT(rblapack_nl);
+ if (!NA_IsNArray(rblapack_vf))
+ rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vf) != 1)
+ rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vf) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
+ if (NA_TYPE(rblapack_vf) != NA_SFLOAT)
+ rblapack_vf = na_change_type(rblapack_vf, NA_SFLOAT);
+ vf = NA_PTR_TYPE(rblapack_vf, real*);
+ if (!NA_IsNArray(rblapack_idxq))
+ rb_raise(rb_eArgError, "idxq (10th argument) must be NArray");
+ if (NA_RANK(rblapack_idxq) != 1)
+ rb_raise(rb_eArgError, "rank of idxq (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_idxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_idxq) != NA_LINT)
+ rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
+ idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
+ ldgcol = n;
+ sqre = NUM2INT(rblapack_sqre);
+ ldgnum = n;
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = 2;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgnum;
+ shape[1] = 2;
+ rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ {
+ 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] = m;
+ rblapack_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, real*);
+ MEMCPY(vf_out__, vf, real, NA_TOTAL(rblapack_vf));
+ rblapack_vf = rblapack_vf_out__;
+ vf = vf_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
+ MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ zw = ALLOC_N(real, (m));
+ vfw = ALLOC_N(real, (m));
+ vlw = ALLOC_N(real, (m));
+ idx = ALLOC_N(integer, (n));
+ idxp = ALLOC_N(integer, (n));
+
+ slasd7_(&icompq, &nl, &nr, &sqre, &k, d, z, zw, vf, vfw, vl, vlw, &alpha, &beta, dsigma, idx, idxp, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, &c, &s, &info);
+
+ free(zw);
+ free(vfw);
+ free(vlw);
+ free(idx);
+ free(idxp);
+ rblapack_k = INT2NUM(k);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_c = rb_float_new((double)c);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(13, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl);
+}
+
+void
+init_lapack_slasd7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd7", rblapack_slasd7, -1);
+}
diff --git a/ext/slasd8.c b/ext/slasd8.c
new file mode 100644
index 0000000..bee7e16
--- /dev/null
+++ b/ext/slasd8.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID slasd8_(integer* icompq, integer* k, real* d, real* z, real* vf, real* vl, real* difl, real* difr, integer* lddifr, real* dsigma, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasd8(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_vf;
+ real *vf;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_dsigma;
+ real *dsigma;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_difl;
+ real *difl;
+ VALUE rblapack_difr;
+ real *difr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ VALUE rblapack_vf_out__;
+ real *vf_out__;
+ VALUE rblapack_vl_out__;
+ real *vl_out__;
+ VALUE rblapack_dsigma_out__;
+ real *dsigma_out__;
+ real *work;
+
+ integer k;
+ integer lddifr;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.slasd8( icompq, z, vf, vl, dsigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASD8 finds the square roots of the roots of the secular equation,\n* as defined by the values in DSIGMA and Z. It makes the appropriate\n* calls to SLASD4, and stores, for each element in D, the distance\n* to its two nearest poles (elements in DSIGMA). It also updates\n* the arrays VF and VL, the first and last components of all the\n* right singular vectors of the original bidiagonal matrix.\n*\n* SLASD8 is called from SLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form in the calling routine:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved\n* by SLASD4. K >= 1.\n*\n* D (output) REAL array, dimension ( K )\n* On output, D contains the updated singular values.\n*\n* Z (input/output) REAL array, dimension ( K )\n* On entry, the first K elements of this array contain the\n* components of the deflation-adjusted updating row vector.\n* On exit, Z is updated.\n*\n* VF (input/output) REAL array, dimension ( K )\n* On entry, VF contains information passed through DBEDE8.\n* On exit, VF contains the first K components of the first\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* VL (input/output) REAL array, dimension ( K )\n* On entry, VL contains information passed through DBEDE8.\n* On exit, VL contains the first K components of the last\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* DIFL (output) REAL array, dimension ( K )\n* On exit, DIFL(I) = D(I) - DSIGMA(I).\n*\n* DIFR (output) REAL array,\n* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n* dimension ( K ) if ICOMPQ = 0.\n* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n* defined and will not be referenced.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* LDDIFR (input) INTEGER\n* The leading dimension of DIFR, must be at least K.\n*\n* DSIGMA (input/output) REAL array, dimension ( K )\n* On entry, the first K elements of this array contain the old\n* roots of the deflated updating problem. These are the poles\n* of the secular equation.\n* On exit, the elements of DSIGMA may be very slightly altered\n* in value.\n*\n* WORK (workspace) REAL array, dimension at least 3 * K\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.slasd8( icompq, z, vf, vl, dsigma, [: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_icompq = argv[0];
+ rblapack_z = argv[1];
+ rblapack_vf = argv[2];
+ rblapack_vl = argv[3];
+ rblapack_dsigma = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_vf))
+ rb_raise(rb_eArgError, "vf (3th argument) must be NArray");
+ if (NA_RANK(rblapack_vf) != 1)
+ rb_raise(rb_eArgError, "rank of vf (3th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_vf);
+ if (NA_TYPE(rblapack_vf) != NA_SFLOAT)
+ rblapack_vf = na_change_type(rblapack_vf, NA_SFLOAT);
+ vf = NA_PTR_TYPE(rblapack_vf, real*);
+ if (!NA_IsNArray(rblapack_dsigma))
+ rb_raise(rb_eArgError, "dsigma (5th argument) must be NArray");
+ if (NA_RANK(rblapack_dsigma) != 1)
+ rb_raise(rb_eArgError, "rank of dsigma (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dsigma) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of vf");
+ if (NA_TYPE(rblapack_dsigma) != NA_SFLOAT)
+ rblapack_dsigma = na_change_type(rblapack_dsigma, NA_SFLOAT);
+ dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of vf");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (4th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 1)
+ rb_raise(rb_eArgError, "rank of vl (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vl) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of vl must be the same as shape 0 of vf");
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ lddifr = k;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ difl = NA_PTR_TYPE(rblapack_difl, real*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? lddifr : icompq == 0 ? k : 0;
+ shape[1] = icompq == 1 ? 2 : 0;
+ rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ difr = NA_PTR_TYPE(rblapack_difr, real*);
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, real*);
+ MEMCPY(vf_out__, vf, real, NA_TOTAL(rblapack_vf));
+ rblapack_vf = rblapack_vf_out__;
+ vf = vf_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
+ MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[1];
+ shape[0] = k;
+ rblapack_dsigma_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dsigma_out__ = NA_PTR_TYPE(rblapack_dsigma_out__, real*);
+ MEMCPY(dsigma_out__, dsigma, real, NA_TOTAL(rblapack_dsigma));
+ rblapack_dsigma = rblapack_dsigma_out__;
+ dsigma = dsigma_out__;
+ work = ALLOC_N(real, (3 * k));
+
+ slasd8_(&icompq, &k, d, z, vf, vl, difl, difr, &lddifr, dsigma, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_d, rblapack_difl, rblapack_difr, rblapack_info, rblapack_z, rblapack_vf, rblapack_vl, rblapack_dsigma);
+}
+
+void
+init_lapack_slasd8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasd8", rblapack_slasd8, -1);
+}
diff --git a/ext/slasda.c b/ext/slasda.c
new file mode 100644
index 0000000..5879b1e
--- /dev/null
+++ b/ext/slasda.c
@@ -0,0 +1,221 @@
+#include "rb_lapack.h"
+
+extern VOID slasda_(integer* icompq, integer* smlsiz, integer* n, integer* sqre, real* d, real* e, real* u, integer* ldu, real* vt, integer* k, real* difl, real* difr, real* z, real* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, real* givnum, real* c, real* s, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_slasda(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_difl;
+ real *difl;
+ VALUE rblapack_difr;
+ real *difr;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_poles;
+ real *poles;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givnum;
+ real *givnum;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldu;
+ integer nlvl;
+ integer ldgcol;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.slasda( icompq, smlsiz, sqre, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, SLASDA computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n* B with diagonal D and offdiagonal E, where M = N + SQRE. The\n* algorithm computes the singular values in the SVD B = U * S * VT.\n* The orthogonal matrices U and VT are optionally computed in\n* compact form.\n*\n* A related subroutine, SLASD0, computes the singular values and\n* the singular vectors in explicit form.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper bidiagonal\n* matrix in compact form.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row dimension of the upper bidiagonal matrix. This is\n* also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N + 1.\n*\n* D (input/output) REAL array, dimension ( N )\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) REAL array, dimension ( M-1 )\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) REAL array,\n* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n* GIVNUM, and Z.\n*\n* VT (output) REAL array,\n* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* K (output) INTEGER array, dimension ( N ) \n* if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n* secular equation on the computation tree.\n*\n* DIFL (output) REAL array, dimension ( LDU, NLVL ),\n* where NLVL = floor(log_2 (N/SMLSIZ))).\n*\n* DIFR (output) REAL array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n* record distances between singular values on the I-th\n* level and singular values on the (I -1)-th level, and\n* DIFR(1:N, 2 * I ) contains the normalizing factors for\n* the right singular vector matrix. See SLASD8 for details.\n*\n* Z (output) REAL array,\n* dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* The first K elements of Z(1, I) contain the components of\n* the deflation-adjusted updating row vector for subproblems\n* on the I-th level.\n*\n* POLES (output) REAL array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n* POLES(1, 2*I) contain the new and old singular values\n* involved in the secular equations on the I-th level.\n*\n* GIVPTR (output) INTEGER array,\n* dimension ( N ) if ICOMPQ = 1, and not referenced if\n* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n* the number of Givens rotations performed on the I-th\n* problem on the computation tree.\n*\n* GIVCOL (output) INTEGER array,\n* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n* of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (output) INTEGER array, dimension ( LDGCOL, NLVL ) \n* if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n* permutations done on the I-th level of the computation tree.\n*\n* GIVNUM (output) REAL array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n* values of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* C (output) REAL array,\n* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (output) REAL array, dimension ( N ) if\n* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n* and the I-th subproblem is not square, on exit, S( I )\n* contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) REAL array, dimension\n* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n*\n* IWORK (workspace) INTEGER array, dimension (7*N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.slasda( icompq, smlsiz, sqre, d, e, [: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_icompq = argv[0];
+ rblapack_smlsiz = argv[1];
+ rblapack_sqre = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ sqre = NUM2INT(rblapack_sqre);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ 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);
+ 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*);
+ m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
+ nlvl = floor(1.0/log(2.0)*log((double)n/smlsiz));
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ ldgcol = n;
+ ldu = n;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = MAX(1,smlsiz);
+ rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = smlsiz+1;
+ rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ {
+ int shape[1];
+ shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
+ rblapack_k = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = nlvl;
+ rblapack_difl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ difl = NA_PTR_TYPE(rblapack_difl, real*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
+ shape[1] = icompq == 1 ? 2 * nlvl : 0;
+ rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ difr = NA_PTR_TYPE(rblapack_difr, real*);
+ {
+ int shape[2];
+ shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
+ shape[1] = icompq == 1 ? nlvl : 0;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = 2 * nlvl;
+ rblapack_poles = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ poles = NA_PTR_TYPE(rblapack_poles, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_givptr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = 2 * nlvl;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = ldgcol;
+ shape[1] = nlvl;
+ rblapack_perm = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = 2 * nlvl;
+ rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, real*);
+ {
+ int shape[1];
+ shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
+ rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ {
+ int shape[1];
+ shape[0] = icompq==1 ? n : icompq==0 ? 1 : 0;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ 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__;
+ work = ALLOC_N(real, (6 * n + (smlsiz + 1)*(smlsiz + 1)));
+ iwork = ALLOC_N(integer, (7*n));
+
+ slasda_(&icompq, &smlsiz, &n, &sqre, d, e, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(15, rblapack_u, rblapack_vt, rblapack_k, rblapack_difl, rblapack_difr, rblapack_z, rblapack_poles, rblapack_givptr, rblapack_givcol, rblapack_perm, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d);
+}
+
+void
+init_lapack_slasda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasda", rblapack_slasda, -1);
+}
diff --git a/ext/slasdq.c b/ext/slasdq.c
new file mode 100644
index 0000000..3623d08
--- /dev/null
+++ b/ext/slasdq.c
@@ -0,0 +1,186 @@
+#include "rb_lapack.h"
+
+extern VOID slasdq_(char* uplo, integer* sqre, integer* n, integer* ncvt, integer* nru, integer* ncc, real* d, real* e, real* vt, integer* ldvt, real* u, integer* ldu, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasdq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_nru;
+ integer nru;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vt;
+ real *vt;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_vt_out__;
+ real *vt_out__;
+ VALUE rblapack_u_out__;
+ real *u_out__;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer n;
+ integer ldvt;
+ integer ncvt;
+ integer ldu;
+ integer ldc;
+ integer ncc;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.slasdq( uplo, sqre, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASDQ computes the singular value decomposition (SVD) of a real\n* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n* E, accumulating the transformations if desired. Letting B denote\n* the input bidiagonal matrix, the algorithm computes orthogonal\n* matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n* of P). The singular values S are overwritten on D.\n*\n* The input matrix U is changed to U * Q if desired.\n* The input matrix VT is changed to P' * VT if desired.\n* The input matrix C is changed to Q' * C if desired.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3, for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the input bidiagonal matrix\n* is upper or lower bidiagonal, and wether it is square are\n* not.\n* UPLO = 'U' or 'u' B is upper bidiagonal.\n* UPLO = 'L' or 'l' B is lower bidiagonal.\n*\n* SQRE (input) INTEGER\n* = 0: then the input matrix is N-by-N.\n* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n* (N+1)-by-N if UPLU = 'L'.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of rows and columns\n* in the matrix. N must be at least 0.\n*\n* NCVT (input) INTEGER\n* On entry, NCVT specifies the number of columns of\n* the matrix VT. NCVT must be at least 0.\n*\n* NRU (input) INTEGER\n* On entry, NRU specifies the number of rows of\n* the matrix U. NRU must be at least 0.\n*\n* NCC (input) INTEGER\n* On entry, NCC specifies the number of columns of\n* the matrix C. NCC must be at least 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the diagonal entries of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in ascending order.\n*\n* E (input/output) REAL array.\n* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n* On entry, the entries of E contain the offdiagonal entries\n* of the bidiagonal matrix whose SVD is desired. On normal\n* exit, E will contain 0. If the algorithm does not converge,\n* D and E will contain the diagonal and superdiagonal entries\n* of a bidiagonal matrix orthogonally equivalent to the one\n* given as input.\n*\n* VT (input/output) REAL array, dimension (LDVT, NCVT)\n* On entry, contains a matrix which on exit has been\n* premultiplied by P', dimension N-by-NCVT if SQRE = 0\n* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n*\n* LDVT (input) INTEGER\n* On entry, LDVT specifies the leading dimension of VT as\n* declared in the calling (sub) program. LDVT must be at\n* least 1. If NCVT is nonzero LDVT must also be at least N.\n*\n* U (input/output) REAL array, dimension (LDU, N)\n* On entry, contains a matrix which on exit has been\n* postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n*\n* LDU (input) INTEGER\n* On entry, LDU specifies the leading dimension of U as\n* declared in the calling (sub) program. LDU must be at\n* least max( 1, NRU ) .\n*\n* C (input/output) REAL array, dimension (LDC, NCC)\n* On entry, contains an N-by-NCC matrix which on exit\n* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0\n* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n*\n* LDC (input) INTEGER\n* On entry, LDC specifies the leading dimension of C as\n* declared in the calling (sub) program. LDC must be at\n* least 1. If NCC is nonzero, LDC must also be at least N.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n* Workspace. Only referenced if one of NCVT, NRU, or NCC is\n* nonzero, and if N is at least 2.\n*\n* INFO (output) INTEGER\n* On exit, a value of 0 indicates a successful exit.\n* If INFO < 0, argument number -INFO is illegal.\n* If INFO > 0, the algorithm did not converge, and INFO\n* specifies how many superdiagonals did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.slasdq( uplo, sqre, nru, d, e, vt, u, c, [: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_uplo = argv[0];
+ rblapack_sqre = argv[1];
+ rblapack_nru = argv[2];
+ rblapack_d = argv[3];
+ rblapack_e = argv[4];
+ rblapack_vt = argv[5];
+ rblapack_u = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ nru = NUM2INT(rblapack_nru);
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (6th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ ncvt = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = 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*);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (7th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ n = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ 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 1 of u");
+ 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_e))
+ rb_raise(rb_eArgError, "e (5th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (sqre==0 ? n-1 : sqre==1 ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", sqre==0 ? n-1 : sqre==1 ? n : 0);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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] = sqre==0 ? n-1 : sqre==1 ? n : 0;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = ncvt;
+ rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
+ MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
+ MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ 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__;
+ work = ALLOC_N(real, (4*n));
+
+ slasdq_(&uplo, &sqre, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
+}
+
+void
+init_lapack_slasdq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasdq", rblapack_slasdq, -1);
+}
diff --git a/ext/slasdt.c b/ext/slasdt.c
new file mode 100644
index 0000000..03a0f38
--- /dev/null
+++ b/ext/slasdt.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID slasdt_(integer* n, integer* lvl, integer* nd, integer* inode, integer* ndiml, integer* ndimr, integer* msub);
+
+
+static VALUE
+rblapack_slasdt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_msub;
+ integer msub;
+ VALUE rblapack_lvl;
+ integer lvl;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_inode;
+ integer *inode;
+ VALUE rblapack_ndiml;
+ integer *ndiml;
+ VALUE rblapack_ndimr;
+ integer *ndimr;
+
+
+ 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 lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.slasdt( n, msub, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n* Purpose\n* =======\n*\n* SLASDT creates a tree of subproblems for bidiagonal divide and\n* conquer.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the number of diagonal elements of the\n* bidiagonal matrix.\n*\n* LVL (output) INTEGER\n* On exit, the number of levels on the computation tree.\n*\n* ND (output) INTEGER\n* On exit, the number of nodes on the tree.\n*\n* INODE (output) INTEGER array, dimension ( N )\n* On exit, centers of subproblems.\n*\n* NDIML (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of left children.\n*\n* NDIMR (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of right children.\n*\n* MSUB (input) INTEGER\n* On entry, the maximum row dimension each subproblem at the\n* bottom of the tree can be of.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.slasdt( n, msub, [: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_n = argv[0];
+ rblapack_msub = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ msub = NUM2INT(rblapack_msub);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_inode = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ inode = NA_PTR_TYPE(rblapack_inode, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_ndiml = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ndiml = NA_PTR_TYPE(rblapack_ndiml, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_ndimr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ndimr = NA_PTR_TYPE(rblapack_ndimr, integer*);
+
+ slasdt_(&n, &lvl, &nd, inode, ndiml, ndimr, &msub);
+
+ rblapack_lvl = INT2NUM(lvl);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(5, rblapack_lvl, rblapack_nd, rblapack_inode, rblapack_ndiml, rblapack_ndimr);
+}
+
+void
+init_lapack_slasdt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasdt", rblapack_slasdt, -1);
+}
diff --git a/ext/slaset.c b/ext/slaset.c
new file mode 100644
index 0000000..cd1816d
--- /dev/null
+++ b/ext/slaset.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID slaset_(char* uplo, integer* m, integer* n, real* alpha, real* beta, real* a, integer* lda);
+
+
+static VALUE
+rblapack_slaset(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_a_out__;
+ real *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 a = NumRu::Lapack.slaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* SLASET initializes an m-by-n matrix A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set; the strictly lower\n* triangular part of A is not changed.\n* = 'L': Lower triangular part is set; the strictly upper\n* triangular part of A is not changed.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* ALPHA (input) REAL\n* The constant to which the offdiagonal elements are to be set.\n*\n* BETA (input) REAL\n* The constant to which the diagonal elements are to be set.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On exit, the leading m-by-n submatrix of A is set as follows:\n*\n* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n*\n* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.slaset( uplo, m, alpha, beta, a, [: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_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_beta = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ m = NUM2INT(rblapack_m);
+ beta = (real)NUM2DBL(rblapack_beta);
+ {
+ 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__;
+
+ slaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_slaset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaset", rblapack_slaset, -1);
+}
diff --git a/ext/slasq1.c b/ext/slasq1.c
new file mode 100644
index 0000000..0ceb3ae
--- /dev/null
+++ b/ext/slasq1.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID slasq1_(integer* n, real* d, real* e, real* work, integer* info);
+
+
+static VALUE
+rblapack_slasq1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ real *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 info, d, e = NumRu::Lapack.slasq1( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ1( N, D, E, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASQ1 computes the singular values of a real N-by-N bidiagonal\n* matrix with diagonal D and off-diagonal E. The singular values\n* are computed to high relative accuracy, in the absence of\n* denormalization, underflow and overflow. The algorithm was first\n* presented in\n*\n* \"Accurate singular values and differential qd algorithms\" by K. V.\n* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n* 1994,\n*\n* and the present implementation is described in \"An implementation of\n* the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the diagonal elements of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in decreasing order.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, elements E(1:N-1) contain the off-diagonal elements\n* of the bidiagonal matrix whose SVD is desired.\n* On exit, E is overwritten.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.slasq1( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(real, (4*n));
+
+ slasq1_(&n, d, e, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_slasq1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasq1", rblapack_slasq1, -1);
+}
diff --git a/ext/slasq2.c b/ext/slasq2.c
new file mode 100644
index 0000000..605e9a8
--- /dev/null
+++ b/ext/slasq2.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID slasq2_(integer* n, real* z, integer* info);
+
+
+static VALUE
+rblapack_slasq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_z_out__;
+ real *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 info, z = NumRu::Lapack.slasq2( n, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ2( N, Z, INFO )\n\n* Purpose\n* =======\n*\n* SLASQ2 computes all the eigenvalues of the symmetric positive \n* definite tridiagonal matrix associated with the qd array Z to high\n* relative accuracy are computed to high relative accuracy, in the\n* absence of denormalization, underflow and overflow.\n*\n* To see the relation of Z to the tridiagonal matrix, let L be a\n* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n* let U be an upper bidiagonal matrix with 1's above and diagonal\n* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n* symmetric tridiagonal to which it is similar.\n*\n* Note : SLASQ2 defines a logical variable, IEEE, which is true\n* on machines which follow ieee-754 floating-point standard in their\n* handling of infinities and NaNs, and false otherwise. This variable\n* is passed to SLASQ3.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* Z (input/output) REAL array, dimension ( 4*N )\n* On entry Z holds the qd array. On exit, entries 1 to N hold\n* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n* shifts that failed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if the i-th argument is a scalar and had an illegal\n* value, then INFO = -i, if the i-th argument is an\n* array and the j-entry had an illegal value, then\n* INFO = -(i*100+j)\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* Further Details\n* ===============\n* Local Variables: I0:N0 defines a current unreduced segment of Z.\n* The shifts are accumulated in SIGMA. Iteration count is in ITER.\n* Ping-pong is controlled by PP (alternates between 0 and 1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, z = NumRu::Lapack.slasq2( n, z, [: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_n = argv[0];
+ rblapack_z = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = 4*n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ slasq2_(&n, z, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_z);
+}
+
+void
+init_lapack_slasq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasq2", rblapack_slasq2, -1);
+}
diff --git a/ext/slasq3.c b/ext/slasq3.c
new file mode 100644
index 0000000..cde787b
--- /dev/null
+++ b/ext/slasq3.c
@@ -0,0 +1,138 @@
+#include "rb_lapack.h"
+
+extern VOID slasq3_(integer* i0, integer* n0, real* z, integer* pp, real* dmin, real* sigma, real* desig, real* qmax, integer* nfail, integer* iter, integer* ndiv, logical* ieee, integer* ttype, real* dmin1, real* dmin2, real* dn, real* dn1, real* dn2, real* g, real* tau);
+
+
+static VALUE
+rblapack_slasq3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_desig;
+ real desig;
+ VALUE rblapack_qmax;
+ real qmax;
+ VALUE rblapack_ieee;
+ logical ieee;
+ VALUE rblapack_ttype;
+ integer ttype;
+ VALUE rblapack_dmin1;
+ real dmin1;
+ VALUE rblapack_dmin2;
+ real dmin2;
+ VALUE rblapack_dn;
+ real dn;
+ VALUE rblapack_dn1;
+ real dn1;
+ VALUE rblapack_dn2;
+ real dn2;
+ VALUE rblapack_g;
+ real g;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_dmin;
+ real dmin;
+ VALUE rblapack_sigma;
+ real sigma;
+ VALUE rblapack_nfail;
+ integer nfail;
+ VALUE rblapack_iter;
+ integer iter;
+ VALUE rblapack_ndiv;
+ integer ndiv;
+
+
+ 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 dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.slasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n* Purpose\n* =======\n*\n* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n* In case of failure it changes shifts, and tries again until output\n* is positive.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input/output) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input/output) INTEGER\n* PP=0 for ping, PP=1 for pong.\n* PP=2 indicates that flipping was applied to the Z array \n* and that the initial tests for deflation should not be \n* performed.\n*\n* DMIN (output) REAL\n* Minimum value of d.\n*\n* SIGMA (output) REAL\n* Sum of shifts used in current segment.\n*\n* DESIG (input/output) REAL\n* Lower order part of SIGMA\n*\n* QMAX (input) REAL\n* Maximum value of q.\n*\n* NFAIL (output) INTEGER\n* Number of times shift was too big.\n*\n* ITER (output) INTEGER\n* Number of iterations.\n*\n* NDIV (output) INTEGER\n* Number of divisions.\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).\n*\n* TTYPE (input/output) INTEGER\n* Shift type.\n*\n* DMIN1 (input/output) REAL\n*\n* DMIN2 (input/output) REAL\n*\n* DN (input/output) REAL\n*\n* DN1 (input/output) REAL\n*\n* DN2 (input/output) REAL\n*\n* G (input/output) REAL\n*\n* TAU (input/output) REAL\n*\n* These are passed as arguments in order to save their values\n* between calls to SLASQ3.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.slasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ rblapack_desig = argv[4];
+ rblapack_qmax = argv[5];
+ rblapack_ieee = argv[6];
+ rblapack_ttype = argv[7];
+ rblapack_dmin1 = argv[8];
+ rblapack_dmin2 = argv[9];
+ rblapack_dn = argv[10];
+ rblapack_dn1 = argv[11];
+ rblapack_dn2 = argv[12];
+ rblapack_g = argv[13];
+ rblapack_tau = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ qmax = (real)NUM2DBL(rblapack_qmax);
+ ttype = NUM2INT(rblapack_ttype);
+ dmin2 = (real)NUM2DBL(rblapack_dmin2);
+ dn1 = (real)NUM2DBL(rblapack_dn1);
+ g = (real)NUM2DBL(rblapack_g);
+ n0 = NUM2INT(rblapack_n0);
+ desig = (real)NUM2DBL(rblapack_desig);
+ dmin1 = (real)NUM2DBL(rblapack_dmin1);
+ dn2 = (real)NUM2DBL(rblapack_dn2);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ dn = (real)NUM2DBL(rblapack_dn);
+ ieee = (rblapack_ieee == Qtrue);
+ tau = (real)NUM2DBL(rblapack_tau);
+
+ slasq3_(&i0, &n0, z, &pp, &dmin, &sigma, &desig, &qmax, &nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau);
+
+ rblapack_dmin = rb_float_new((double)dmin);
+ rblapack_sigma = rb_float_new((double)sigma);
+ rblapack_nfail = INT2NUM(nfail);
+ rblapack_iter = INT2NUM(iter);
+ rblapack_ndiv = INT2NUM(ndiv);
+ rblapack_n0 = INT2NUM(n0);
+ rblapack_pp = INT2NUM(pp);
+ rblapack_desig = rb_float_new((double)desig);
+ rblapack_ttype = INT2NUM(ttype);
+ rblapack_dmin1 = rb_float_new((double)dmin1);
+ rblapack_dmin2 = rb_float_new((double)dmin2);
+ rblapack_dn = rb_float_new((double)dn);
+ rblapack_dn1 = rb_float_new((double)dn1);
+ rblapack_dn2 = rb_float_new((double)dn2);
+ rblapack_g = rb_float_new((double)g);
+ rblapack_tau = rb_float_new((double)tau);
+ return rb_ary_new3(16, rblapack_dmin, rblapack_sigma, rblapack_nfail, rblapack_iter, rblapack_ndiv, rblapack_n0, rblapack_pp, rblapack_desig, rblapack_ttype, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dn1, rblapack_dn2, rblapack_g, rblapack_tau);
+}
+
+void
+init_lapack_slasq3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasq3", rblapack_slasq3, -1);
+}
diff --git a/ext/slasq4.c b/ext/slasq4.c
new file mode 100644
index 0000000..b1ecdd3
--- /dev/null
+++ b/ext/slasq4.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID slasq4_(integer* i0, integer* n0, real* z, integer* pp, integer* n0in, real* dmin, real* dmin1, real* dmin2, real* dn, real* dn1, real* dn2, real* tau, integer* ttype, real* g);
+
+
+static VALUE
+rblapack_slasq4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_n0in;
+ integer n0in;
+ VALUE rblapack_dmin;
+ real dmin;
+ VALUE rblapack_dmin1;
+ real dmin1;
+ VALUE rblapack_dmin2;
+ real dmin2;
+ VALUE rblapack_dn;
+ real dn;
+ VALUE rblapack_dn1;
+ real dn1;
+ VALUE rblapack_dn2;
+ real dn2;
+ VALUE rblapack_g;
+ real g;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_ttype;
+ integer ttype;
+
+
+ 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 tau, ttype, g = NumRu::Lapack.slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n* Purpose\n* =======\n*\n* SLASQ4 computes an approximation TAU to the smallest eigenvalue\n* using values of d from the previous transform.\n*\n\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* NOIN (input) INTEGER\n* The value of N0 at start of EIGTEST.\n*\n* DMIN (input) REAL\n* Minimum value of d.\n*\n* DMIN1 (input) REAL\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (input) REAL\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (input) REAL\n* d(N)\n*\n* DN1 (input) REAL\n* d(N-1)\n*\n* DN2 (input) REAL\n* d(N-2)\n*\n* TAU (output) REAL\n* This is the shift.\n*\n* TTYPE (output) INTEGER\n* Shift type.\n*\n* G (input/output) REAL\n* G is passed as an argument in order to save its value between\n* calls to SLASQ4.\n*\n\n* Further Details\n* ===============\n* CNST1 = 9/16\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, ttype, g = NumRu::Lapack.slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [: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_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ rblapack_n0in = argv[4];
+ rblapack_dmin = argv[5];
+ rblapack_dmin1 = argv[6];
+ rblapack_dmin2 = argv[7];
+ rblapack_dn = argv[8];
+ rblapack_dn1 = argv[9];
+ rblapack_dn2 = argv[10];
+ rblapack_g = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ dmin = (real)NUM2DBL(rblapack_dmin);
+ dmin2 = (real)NUM2DBL(rblapack_dmin2);
+ dn1 = (real)NUM2DBL(rblapack_dn1);
+ g = (real)NUM2DBL(rblapack_g);
+ n0 = NUM2INT(rblapack_n0);
+ n0in = NUM2INT(rblapack_n0in);
+ dn = (real)NUM2DBL(rblapack_dn);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ dn2 = (real)NUM2DBL(rblapack_dn2);
+ dmin1 = (real)NUM2DBL(rblapack_dmin1);
+
+ slasq4_(&i0, &n0, z, &pp, &n0in, &dmin, &dmin1, &dmin2, &dn, &dn1, &dn2, &tau, &ttype, &g);
+
+ rblapack_tau = rb_float_new((double)tau);
+ rblapack_ttype = INT2NUM(ttype);
+ rblapack_g = rb_float_new((double)g);
+ return rb_ary_new3(3, rblapack_tau, rblapack_ttype, rblapack_g);
+}
+
+void
+init_lapack_slasq4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasq4", rblapack_slasq4, -1);
+}
diff --git a/ext/slasq5.c b/ext/slasq5.c
new file mode 100644
index 0000000..a74db2b
--- /dev/null
+++ b/ext/slasq5.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID slasq5_(integer* i0, integer* n0, real* z, integer* pp, real* tau, real* dmin, real* dmin1, real* dmin2, real* dn, real* dnm1, real* dnm2, logical* ieee);
+
+
+static VALUE
+rblapack_slasq5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_ieee;
+ logical ieee;
+ VALUE rblapack_dmin;
+ real dmin;
+ VALUE rblapack_dmin1;
+ real dmin1;
+ VALUE rblapack_dmin2;
+ real dmin2;
+ VALUE rblapack_dn;
+ real dn;
+ VALUE rblapack_dnm1;
+ real dnm1;
+ VALUE rblapack_dnm2;
+ real dnm2;
+
+
+ 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 dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq5( i0, n0, z, pp, tau, ieee, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n* Purpose\n* =======\n*\n* SLASQ5 computes one dqds transform in ping-pong form, one\n* version for IEEE machines another for non IEEE machines.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* TAU (input) REAL\n* This is the shift.\n*\n* DMIN (output) REAL\n* Minimum value of d.\n*\n* DMIN1 (output) REAL\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) REAL\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) REAL\n* d(N0), the last value of d.\n*\n* DNM1 (output) REAL\n* d(N0-1).\n*\n* DNM2 (output) REAL\n* d(N0-2).\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic.\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n REAL ZERO\n PARAMETER ( ZERO = 0.0E0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n REAL D, EMIN, TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq5( i0, n0, z, pp, tau, ieee, [: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_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_ieee = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ ieee = (rblapack_ieee == Qtrue);
+ n0 = NUM2INT(rblapack_n0);
+ tau = (real)NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+
+ slasq5_(&i0, &n0, z, &pp, &tau, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2, &ieee);
+
+ rblapack_dmin = rb_float_new((double)dmin);
+ rblapack_dmin1 = rb_float_new((double)dmin1);
+ rblapack_dmin2 = rb_float_new((double)dmin2);
+ rblapack_dn = rb_float_new((double)dn);
+ rblapack_dnm1 = rb_float_new((double)dnm1);
+ rblapack_dnm2 = rb_float_new((double)dnm2);
+ return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
+}
+
+void
+init_lapack_slasq5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasq5", rblapack_slasq5, -1);
+}
diff --git a/ext/slasq6.c b/ext/slasq6.c
new file mode 100644
index 0000000..15d96ed
--- /dev/null
+++ b/ext/slasq6.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID slasq6_(integer* i0, integer* n0, real* z, integer* pp, real* dmin, real* dmin1, real* dmin2, real* dn, real* dnm1, real* dnm2);
+
+
+static VALUE
+rblapack_slasq6(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_i0;
+ integer i0;
+ VALUE rblapack_n0;
+ integer n0;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_pp;
+ integer pp;
+ VALUE rblapack_dmin;
+ real dmin;
+ VALUE rblapack_dmin1;
+ real dmin1;
+ VALUE rblapack_dmin2;
+ real dmin2;
+ VALUE rblapack_dn;
+ real dn;
+ VALUE rblapack_dnm1;
+ real dnm1;
+ VALUE rblapack_dnm2;
+ real dnm2;
+
+
+ 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 dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq6( i0, n0, z, pp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n* Purpose\n* =======\n*\n* SLASQ6 computes one dqd (shift equal to zero) transform in\n* ping-pong form, with protection against underflow and overflow.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* DMIN (output) REAL\n* Minimum value of d.\n*\n* DMIN1 (output) REAL\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) REAL\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) REAL\n* d(N0), the last value of d.\n*\n* DNM1 (output) REAL\n* d(N0-1).\n*\n* DNM2 (output) REAL\n* d(N0-2).\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n REAL ZERO\n PARAMETER ( ZERO = 0.0E0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n REAL D, EMIN, SAFMIN, TEMP\n* ..\n* .. External Function ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq6( i0, n0, z, pp, [: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_i0 = argv[0];
+ rblapack_n0 = argv[1];
+ rblapack_z = argv[2];
+ rblapack_pp = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ i0 = NUM2INT(rblapack_i0);
+ pp = NUM2INT(rblapack_pp);
+ n0 = NUM2INT(rblapack_n0);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (3th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != (4*n0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+
+ slasq6_(&i0, &n0, z, &pp, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2);
+
+ rblapack_dmin = rb_float_new((double)dmin);
+ rblapack_dmin1 = rb_float_new((double)dmin1);
+ rblapack_dmin2 = rb_float_new((double)dmin2);
+ rblapack_dn = rb_float_new((double)dn);
+ rblapack_dnm1 = rb_float_new((double)dnm1);
+ rblapack_dnm2 = rb_float_new((double)dnm2);
+ return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
+}
+
+void
+init_lapack_slasq6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasq6", rblapack_slasq6, -1);
+}
diff --git a/ext/slasr.c b/ext/slasr.c
new file mode 100644
index 0000000..f1bcdaf
--- /dev/null
+++ b/ext/slasr.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID slasr_(char* side, char* pivot, char* direct, integer* m, integer* n, real* c, real* s, real* a, integer* lda);
+
+
+static VALUE
+rblapack_slasr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_pivot;
+ char pivot;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_a_out__;
+ real *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 a = NumRu::Lapack.slasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* SLASR applies a sequence of plane rotations to a real matrix A,\n* from either the left or the right.\n* \n* When SIDE = 'L', the transformation takes the form\n* \n* A := P*A\n* \n* and when SIDE = 'R', the transformation takes the form\n* \n* A := A*P**T\n* \n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.slasr( side, pivot, direct, m, c, s, a, [: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_pivot = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_m = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ pivot = StringValueCStr(rblapack_pivot)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
+ if (NA_TYPE(rblapack_c) != NA_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, 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__;
+
+ slasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_slasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasr", rblapack_slasr, -1);
+}
diff --git a/ext/slasrt.c b/ext/slasrt.c
new file mode 100644
index 0000000..7ab298e
--- /dev/null
+++ b/ext/slasrt.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID slasrt_(char* id, integer* n, real* d, integer* info);
+
+
+static VALUE
+rblapack_slasrt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_id;
+ char id;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+
+ 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, d = NumRu::Lapack.slasrt( id, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASRT( ID, N, D, INFO )\n\n* Purpose\n* =======\n*\n* Sort the numbers in D in increasing order (if ID = 'I') or\n* in decreasing order (if ID = 'D' ).\n*\n* Use Quick Sort, reverting to Insertion sort on arrays of\n* size <= 20. Dimension of STACK limits N to about 2**32.\n*\n\n* Arguments\n* =========\n*\n* ID (input) CHARACTER*1\n* = 'I': sort D in increasing order;\n* = 'D': sort D in decreasing order.\n*\n* N (input) INTEGER\n* The length of the array D.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the array to be sorted.\n* On exit, D has been sorted into increasing order\n* (D(1) <= ... <= D(N) ) or into decreasing order\n* (D(1) >= ... >= D(N) ), depending on ID.\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, d = NumRu::Lapack.slasrt( id, d, [: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_id = argv[0];
+ rblapack_d = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ id = StringValueCStr(rblapack_id)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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*);
+ {
+ 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__;
+
+ slasrt_(&id, &n, d, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_d);
+}
+
+void
+init_lapack_slasrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasrt", rblapack_slasrt, -1);
+}
diff --git a/ext/slassq.c b/ext/slassq.c
new file mode 100644
index 0000000..0aef36c
--- /dev/null
+++ b/ext/slassq.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern VOID slassq_(integer* n, real* x, integer* incx, real* scale, real* sumsq);
+
+
+static VALUE
+rblapack_slassq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_sumsq;
+ real sumsq;
+
+ 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 scale, sumsq = NumRu::Lapack.slassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* SLASSQ returns the values scl and smsq such that\n*\n* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is\n* assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( x( i ) ) ).\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ and\n* scl and smsq are overwritten on SCALE and SUMSQ respectively.\n*\n* The routine makes only one pass through the vector x.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) REAL array, dimension (N)\n* The vector for which a scaled sum of squares is computed.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) REAL\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with scl , the scaling factor\n* for the sum of squares.\n*\n* SUMSQ (input/output) REAL\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with smsq , the basic sum of\n* squares from which scl has been factored out.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.slassq( x, incx, scale, sumsq, [: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_x = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_scale = argv[2];
+ rblapack_sumsq = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(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*);
+ scale = (real)NUM2DBL(rblapack_scale);
+ incx = NUM2INT(rblapack_incx);
+ sumsq = (real)NUM2DBL(rblapack_sumsq);
+
+ slassq_(&n, x, &incx, &scale, &sumsq);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_sumsq = rb_float_new((double)sumsq);
+ return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
+}
+
+void
+init_lapack_slassq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slassq", rblapack_slassq, -1);
+}
diff --git a/ext/slasv2.c b/ext/slasv2.c
new file mode 100644
index 0000000..157d8cc
--- /dev/null
+++ b/ext/slasv2.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID slasv2_(real* f, real* g, real* h, real* ssmin, real* ssmax, real* snr, real* csr, real* snl, real* csl);
+
+
+static VALUE
+rblapack_slasv2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ real f;
+ VALUE rblapack_g;
+ real g;
+ VALUE rblapack_h;
+ real h;
+ VALUE rblapack_ssmin;
+ real ssmin;
+ VALUE rblapack_ssmax;
+ real ssmax;
+ VALUE rblapack_snr;
+ real snr;
+ VALUE rblapack_csr;
+ real csr;
+ VALUE rblapack_snl;
+ real snl;
+ VALUE rblapack_csl;
+ real csl;
+
+
+ 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 ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.slasv2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n* Purpose\n* =======\n*\n* SLASV2 computes the singular value decomposition of a 2-by-2\n* triangular matrix\n* [ F G ]\n* [ 0 H ].\n* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n* right singular vectors for abs(SSMAX), giving the decomposition\n*\n* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]\n* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) REAL\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) REAL\n* abs(SSMIN) is the smaller singular value.\n*\n* SSMAX (output) REAL\n* abs(SSMAX) is the larger singular value.\n*\n* SNL (output) REAL\n* CSL (output) REAL\n* The vector (CSL, SNL) is a unit left singular vector for the\n* singular value abs(SSMAX).\n*\n* SNR (output) REAL\n* CSR (output) REAL\n* The vector (CSR, SNR) is a unit right singular vector for the\n* singular value abs(SSMAX).\n*\n\n* Further Details\n* ===============\n*\n* Any input parameter may be aliased with any output parameter.\n*\n* Barring over/underflow and assuming a guard digit in subtraction, all\n* output quantities are correct to within a few units in the last\n* place (ulps).\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.slasv2( f, g, h, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ rblapack_h = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f = (real)NUM2DBL(rblapack_f);
+ h = (real)NUM2DBL(rblapack_h);
+ g = (real)NUM2DBL(rblapack_g);
+
+ slasv2_(&f, &g, &h, &ssmin, &ssmax, &snr, &csr, &snl, &csl);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ rblapack_ssmax = rb_float_new((double)ssmax);
+ rblapack_snr = rb_float_new((double)snr);
+ rblapack_csr = rb_float_new((double)csr);
+ rblapack_snl = rb_float_new((double)snl);
+ rblapack_csl = rb_float_new((double)csl);
+ return rb_ary_new3(6, rblapack_ssmin, rblapack_ssmax, rblapack_snr, rblapack_csr, rblapack_snl, rblapack_csl);
+}
+
+void
+init_lapack_slasv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasv2", rblapack_slasv2, -1);
+}
diff --git a/ext/slaswp.c b/ext/slaswp.c
new file mode 100644
index 0000000..b680536
--- /dev/null
+++ b/ext/slaswp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID slaswp_(integer* n, real* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);
+
+
+static VALUE
+rblapack_slaswp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_k1;
+ integer k1;
+ VALUE rblapack_k2;
+ integer k2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_a_out__;
+ real *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 a = NumRu::Lapack.slaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* SLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n REAL TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.slaswp( a, k1, k2, ipiv, incx, [: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_a = argv[0];
+ rblapack_k1 = argv[1];
+ rblapack_k2 = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_incx = argv[4];
+ if (argc == 5) {
+ } 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);
+ n = 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*);
+ k2 = NUM2INT(rblapack_k2);
+ incx = NUM2INT(rblapack_incx);
+ k1 = NUM2INT(rblapack_k1);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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__;
+
+ slaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_slaswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slaswp", rblapack_slaswp, -1);
+}
diff --git a/ext/slasy2.c b/ext/slasy2.c
new file mode 100644
index 0000000..f99be77
--- /dev/null
+++ b/ext/slasy2.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID slasy2_(logical* ltranl, logical* ltranr, integer* isgn, integer* n1, integer* n2, real* tl, integer* ldtl, real* tr, integer* ldtr, real* b, integer* ldb, real* scale, real* x, integer* ldx, real* xnorm, integer* info);
+
+
+static VALUE
+rblapack_slasy2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ltranl;
+ logical ltranl;
+ VALUE rblapack_ltranr;
+ logical ltranr;
+ VALUE rblapack_isgn;
+ integer isgn;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_tl;
+ real *tl;
+ VALUE rblapack_tr;
+ real *tr;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_xnorm;
+ real xnorm;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldtl;
+ integer ldtr;
+ integer ldb;
+ 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 scale, x, xnorm, info = NumRu::Lapack.slasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n*\n* op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n*\n* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n* -1. op(T) = T or T', where T' denotes the transpose of T.\n*\n\n* Arguments\n* =========\n*\n* LTRANL (input) LOGICAL\n* On entry, LTRANL specifies the op(TL):\n* = .FALSE., op(TL) = TL,\n* = .TRUE., op(TL) = TL'.\n*\n* LTRANR (input) LOGICAL\n* On entry, LTRANR specifies the op(TR):\n* = .FALSE., op(TR) = TR,\n* = .TRUE., op(TR) = TR'.\n*\n* ISGN (input) INTEGER\n* On entry, ISGN specifies the sign of the equation\n* as described before. ISGN may only be 1 or -1.\n*\n* N1 (input) INTEGER\n* On entry, N1 specifies the order of matrix TL.\n* N1 may only be 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* On entry, N2 specifies the order of matrix TR.\n* N2 may only be 0, 1 or 2.\n*\n* TL (input) REAL array, dimension (LDTL,2)\n* On entry, TL contains an N1 by N1 matrix.\n*\n* LDTL (input) INTEGER\n* The leading dimension of the matrix TL. LDTL >= max(1,N1).\n*\n* TR (input) REAL array, dimension (LDTR,2)\n* On entry, TR contains an N2 by N2 matrix.\n*\n* LDTR (input) INTEGER\n* The leading dimension of the matrix TR. LDTR >= max(1,N2).\n*\n* B (input) REAL array, dimension (LDB,2)\n* On entry, the N1 by N2 matrix B contains the right-hand\n* side of the equation.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1,N1).\n*\n* SCALE (output) REAL\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* less than or equal to 1 to prevent the solution overflowing.\n*\n* X (output) REAL array, dimension (LDX,2)\n* On exit, X contains the N1 by N2 solution.\n*\n* LDX (input) INTEGER\n* The leading dimension of the matrix X. LDX >= max(1,N1).\n*\n* XNORM (output) REAL\n* On exit, XNORM is the infinity-norm of the solution.\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: TL and TR have too close eigenvalues, so TL or\n* TR is perturbed to get a nonsingular equation.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, x, xnorm, info = NumRu::Lapack.slasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [: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_ltranl = argv[0];
+ rblapack_ltranr = argv[1];
+ rblapack_isgn = argv[2];
+ rblapack_n1 = argv[3];
+ rblapack_n2 = argv[4];
+ rblapack_tl = argv[5];
+ rblapack_tr = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ltranl = (rblapack_ltranl == Qtrue);
+ isgn = NUM2INT(rblapack_isgn);
+ n2 = NUM2INT(rblapack_n2);
+ if (!NA_IsNArray(rblapack_tr))
+ rb_raise(rb_eArgError, "tr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_tr) != 2)
+ rb_raise(rb_eArgError, "rank of tr (7th argument) must be %d", 2);
+ ldtr = NA_SHAPE0(rblapack_tr);
+ if (NA_SHAPE1(rblapack_tr) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of tr must be %d", 2);
+ if (NA_TYPE(rblapack_tr) != NA_SFLOAT)
+ rblapack_tr = na_change_type(rblapack_tr, NA_SFLOAT);
+ tr = NA_PTR_TYPE(rblapack_tr, real*);
+ ltranr = (rblapack_ltranr == Qtrue);
+ if (!NA_IsNArray(rblapack_tl))
+ rb_raise(rb_eArgError, "tl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_tl) != 2)
+ rb_raise(rb_eArgError, "rank of tl (6th argument) must be %d", 2);
+ ldtl = NA_SHAPE0(rblapack_tl);
+ if (NA_SHAPE1(rblapack_tl) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of tl must be %d", 2);
+ if (NA_TYPE(rblapack_tl) != NA_SFLOAT)
+ rblapack_tl = na_change_type(rblapack_tl, NA_SFLOAT);
+ tl = NA_PTR_TYPE(rblapack_tl, real*);
+ n1 = NUM2INT(rblapack_n1);
+ ldx = MAX(1,n1);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ if (NA_SHAPE1(rblapack_b) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = 2;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+
+ slasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &ldtl, tr, &ldtr, b, &ldb, &scale, x, &ldx, &xnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_xnorm = rb_float_new((double)xnorm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_x, rblapack_xnorm, rblapack_info);
+}
+
+void
+init_lapack_slasy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasy2", rblapack_slasy2, -1);
+}
diff --git a/ext/slasyf.c b/ext/slasyf.c
new file mode 100644
index 0000000..a9a62a7
--- /dev/null
+++ b/ext/slasyf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID slasyf_(char* uplo, integer* n, integer* nb, integer* kb, real* a, integer* lda, integer* ipiv, real* w, integer* ldw, integer* info);
+
+
+static VALUE
+rblapack_slasyf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *w;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 kb, ipiv, info, a = NumRu::Lapack.slasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* SLASYF computes a partial factorization of a real symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n*\n* SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) REAL 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) REAL array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.slasyf( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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__;
+ w = ALLOC_N(real, (ldw)*(MAX(1,nb)));
+
+ slasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
+
+ free(w);
+ rblapack_kb = INT2NUM(kb);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_slasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slasyf", rblapack_slasyf, -1);
+}
diff --git a/ext/slatbs.c b/ext/slatbs.c
new file mode 100644
index 0000000..fad254c
--- /dev/null
+++ b/ext/slatbs.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID slatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, real* ab, integer* ldab, real* x, real* scale, real* cnorm, integer* info);
+
+
+static VALUE
+rblapack_slatbs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_cnorm;
+ real *cnorm;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_cnorm_out__;
+ real *cnorm_out__;
+
+ integer ldab;
+ 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 scale, info, x, cnorm = NumRu::Lapack.slatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLATBS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine STBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) REAL array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, STBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.slatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [: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_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_kd = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_x = argv[6];
+ rblapack_cnorm = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ n = NA_SHAPE0(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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
+ MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ slatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_slatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slatbs", rblapack_slatbs, -1);
+}
diff --git a/ext/slatdf.c b/ext/slatdf.c
new file mode 100644
index 0000000..cea67ee
--- /dev/null
+++ b/ext/slatdf.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID slatdf_(integer* ijob, integer* n, real* z, integer* ldz, real* rhs, real* rdsum, real* rdscal, integer* ipiv, integer* jpiv);
+
+
+static VALUE
+rblapack_slatdf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_rhs;
+ real *rhs;
+ VALUE rblapack_rdsum;
+ real rdsum;
+ VALUE rblapack_rdscal;
+ real rdscal;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_rhs_out__;
+ real *rhs_out__;
+
+ integer ldz;
+ 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 rhs, rdsum, rdscal = NumRu::Lapack.slatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* SLATDF uses the LU factorization of the n-by-n matrix Z computed by\n* SGETC2 and computes a contribution to the reciprocal Dif-estimate\n* by solving Z * x = b for x, and choosing the r.h.s. b such that\n* the norm of x is as large as possible. On entry RHS = b holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,\n* where P and Q are permutation matrices. L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using SGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value\n* of 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where all entries of\n* the r.h.s. b is choosen as either +1 or -1 (Default).\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) REAL array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by SGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) REAL array, dimension N.\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries acoording to the value of IJOB (see above).\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by STGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when STGSY2 is called by\n* STGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report IMINF-95.05, Departement of\n* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.slatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [: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_ijob = argv[0];
+ rblapack_z = argv[1];
+ rblapack_rhs = argv[2];
+ rblapack_rdsum = argv[3];
+ rblapack_rdscal = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_jpiv = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ if (!NA_IsNArray(rblapack_rhs))
+ rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_rhs);
+ if (NA_TYPE(rblapack_rhs) != NA_SFLOAT)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_SFLOAT);
+ rhs = NA_PTR_TYPE(rblapack_rhs, real*);
+ rdscal = (real)NUM2DBL(rblapack_rdscal);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, 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 rhs");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ rdsum = (real)NUM2DBL(rblapack_rdsum);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, real*);
+ MEMCPY(rhs_out__, rhs, real, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ slatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
+
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_slatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slatdf", rblapack_slatdf, -1);
+}
diff --git a/ext/slatps.c b/ext/slatps.c
new file mode 100644
index 0000000..d42f233
--- /dev/null
+++ b/ext/slatps.c
@@ -0,0 +1,124 @@
+#include "rb_lapack.h"
+
+extern VOID slatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, real* ap, real* x, real* scale, real* cnorm, integer* info);
+
+
+static VALUE
+rblapack_slatps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_cnorm;
+ real *cnorm;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_cnorm_out__;
+ real *cnorm_out__;
+
+ 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 scale, info, x, cnorm = NumRu::Lapack.slatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLATPS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A' denotes the\n* transpose of A, x and b are n-element vectors, and s is a scaling\n* factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\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*\n* X (input/output) REAL array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, STPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.slatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ n = NA_SHAPE0(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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ 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) != (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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
+ MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ slatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_slatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slatps", rblapack_slatps, -1);
+}
diff --git a/ext/slatrd.c b/ext/slatrd.c
new file mode 100644
index 0000000..32c3b9f
--- /dev/null
+++ b/ext/slatrd.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID slatrd_(char* uplo, integer* n, integer* nb, real* a, integer* lda, real* e, real* tau, real* w, integer* ldw);
+
+
+static VALUE
+rblapack_slatrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 e, tau, w, a = NumRu::Lapack.slatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* SLATRD reduces NB rows and columns of a real symmetric matrix A to\n* symmetric tridiagonal form by an orthogonal similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', SLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', SLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by SSYTRD.\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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) REAL 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= (1,N).\n*\n* E (output) REAL array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) REAL array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a symmetric rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.slatrd( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[2];
+ shape[0] = ldw;
+ shape[1] = MAX(n,nb);
+ rblapack_w = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, 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__;
+
+ slatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
+
+ return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
+}
+
+void
+init_lapack_slatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slatrd", rblapack_slatrd, -1);
+}
diff --git a/ext/slatrs.c b/ext/slatrs.c
new file mode 100644
index 0000000..aa7e379
--- /dev/null
+++ b/ext/slatrs.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID slatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, real* a, integer* lda, real* x, real* scale, real* cnorm, integer* info);
+
+
+static VALUE
+rblapack_slatrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_cnorm;
+ real *cnorm;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_cnorm_out__;
+ real *cnorm_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 scale, info, x, cnorm = NumRu::Lapack.slatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLATRS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A' denotes the transpose of A, x and b are\n* n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine STRSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) REAL array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, STRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.slatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_a = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
+ 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) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_x) != NA_SFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
+ MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ slatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_slatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slatrs", rblapack_slatrs, -1);
+}
diff --git a/ext/slatrz.c b/ext/slatrz.c
new file mode 100644
index 0000000..de83615
--- /dev/null
+++ b/ext/slatrz.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID slatrz_(integer* m, integer* n, integer* l, real* a, integer* lda, real* tau, real* work);
+
+
+static VALUE
+rblapack_slatrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.slatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means\n* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) REAL array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.slatrz( l, 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_l = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ l = NUM2INT(rblapack_l);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (m));
+
+ slatrz_(&m, &n, &l, a, &lda, tau, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_tau, rblapack_a);
+}
+
+void
+init_lapack_slatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slatrz", rblapack_slatrz, -1);
+}
diff --git a/ext/slatzm.c b/ext/slatzm.c
new file mode 100644
index 0000000..0adcb46
--- /dev/null
+++ b/ext/slatzm.c
@@ -0,0 +1,131 @@
+#include "rb_lapack.h"
+
+extern VOID slatzm_(char* side, integer* m, integer* n, real* v, integer* incv, real* tau, real* c1, real* c2, integer* ldc, real* work);
+
+
+static VALUE
+rblapack_slatzm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ real tau;
+ VALUE rblapack_c1;
+ real *c1;
+ VALUE rblapack_c2;
+ real *c2;
+ VALUE rblapack_c1_out__;
+ real *c1_out__;
+ VALUE rblapack_c2_out__;
+ real *c2_out__;
+ real *work;
+
+ 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 c1, c2 = NumRu::Lapack.slatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SORMRZ.\n*\n* SLATZM applies a Householder matrix generated by STZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) REAL array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) REAL\n* The value tau in the representation of P.\n*\n* C1 (input/output) REAL array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) REAL array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.slatzm( side, m, n, v, incv, tau, c1, c2, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c1 = argv[6];
+ rblapack_c2 = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ n = NUM2INT(rblapack_n);
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c2))
+ rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c2) != 2)
+ rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c2);
+ if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
+ if (NA_TYPE(rblapack_c2) != NA_SFLOAT)
+ rblapack_c2 = na_change_type(rblapack_c2, NA_SFLOAT);
+ c2 = NA_PTR_TYPE(rblapack_c2, real*);
+ m = NUM2INT(rblapack_m);
+ tau = (real)NUM2DBL(rblapack_tau);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ if (!NA_IsNArray(rblapack_c1))
+ rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c1) != 2)
+ rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
+ if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
+ if (NA_TYPE(rblapack_c1) != NA_SFLOAT)
+ rblapack_c1 = na_change_type(rblapack_c1, NA_SFLOAT);
+ c1 = NA_PTR_TYPE(rblapack_c1, real*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
+ rblapack_c1_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, real*);
+ MEMCPY(c1_out__, c1, real, NA_TOTAL(rblapack_c1));
+ rblapack_c1 = rblapack_c1_out__;
+ c1 = c1_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
+ rblapack_c2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, real*);
+ MEMCPY(c2_out__, c2, real, NA_TOTAL(rblapack_c2));
+ rblapack_c2 = rblapack_c2_out__;
+ c2 = c2_out__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ slatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_c1, rblapack_c2);
+}
+
+void
+init_lapack_slatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slatzm", rblapack_slatzm, -1);
+}
diff --git a/ext/slauu2.c b/ext/slauu2.c
new file mode 100644
index 0000000..a6b06ad
--- /dev/null
+++ b/ext/slauu2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID slauu2_(char* uplo, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_slauu2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.slauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLAUU2 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) REAL 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.slauu2( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+
+ slauu2_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_slauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slauu2", rblapack_slauu2, -1);
+}
diff --git a/ext/slauum.c b/ext/slauum.c
new file mode 100644
index 0000000..47683fc
--- /dev/null
+++ b/ext/slauum.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID slauum_(char* uplo, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_slauum(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.slauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLAUUM 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) REAL 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.slauum( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+
+ slauum_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_slauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "slauum", rblapack_slauum, -1);
+}
diff --git a/ext/sopgtr.c b/ext/sopgtr.c
new file mode 100644
index 0000000..5702253
--- /dev/null
+++ b/ext/sopgtr.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID sopgtr_(char* uplo, integer* n, real* ap, real* tau, real* q, integer* ldq, real* work, integer* info);
+
+
+static VALUE
+rblapack_sopgtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_info;
+ integer info;
+ real *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.sopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SOPGTR 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* SSPTRD 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 SSPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to SSPTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* AP (input) REAL array, dimension (N*(N+1)/2)\n* The vectors which define the elementary reflectors, as\n* returned by SSPTRD.\n*\n* TAU (input) REAL array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SSPTRD.\n*\n* Q (output) REAL 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) REAL 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.sopgtr( 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_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, real*);
+ ldq = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ work = ALLOC_N(real, (n-1));
+
+ sopgtr_(&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_sopgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sopgtr", rblapack_sopgtr, -1);
+}
diff --git a/ext/sopmtr.c b/ext/sopmtr.c
new file mode 100644
index 0000000..4b6f9b0
--- /dev/null
+++ b/ext/sopmtr.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID sopmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, real* ap, real* tau, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sopmtr(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;
+ real *ap;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *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.sopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SOPMTR 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 SSPTRD 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 SSPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to SSPTRD.\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) REAL 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 SSPTRD. AP is modified by the routine but\n* restored on exit.\n*\n* TAU (input) REAL 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 SSPTRD.\n*\n* C (input/output) REAL 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) REAL 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.sopmtr( 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_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ 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_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
+ ap = NA_PTR_TYPE(rblapack_ap, real*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ sopmtr_(&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_sopmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sopmtr", rblapack_sopmtr, -1);
+}
diff --git a/ext/sorbdb.c b/ext/sorbdb.c
new file mode 100644
index 0000000..80de755
--- /dev/null
+++ b/ext/sorbdb.c
@@ -0,0 +1,232 @@
+#include "rb_lapack.h"
+
+extern VOID sorbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, real* x11, integer* ldx11, real* x12, integer* ldx12, real* x21, integer* ldx21, real* x22, integer* ldx22, real* theta, real* phi, real* taup1, real* taup2, real* tauq1, real* tauq2, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorbdb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_signs;
+ char signs;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x11;
+ real *x11;
+ VALUE rblapack_x12;
+ real *x12;
+ VALUE rblapack_x21;
+ real *x21;
+ VALUE rblapack_x22;
+ real *x22;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_theta;
+ real *theta;
+ VALUE rblapack_phi;
+ real *phi;
+ VALUE rblapack_taup1;
+ real *taup1;
+ VALUE rblapack_taup2;
+ real *taup2;
+ VALUE rblapack_tauq1;
+ real *tauq1;
+ VALUE rblapack_tauq2;
+ real *tauq2;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x11_out__;
+ real *x11_out__;
+ VALUE rblapack_x12_out__;
+ real *x12_out__;
+ VALUE rblapack_x21_out__;
+ real *x21_out__;
+ VALUE rblapack_x22_out__;
+ real *x22_out__;
+ real *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.sorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORBDB( 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* SORBDB 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 SORCSD\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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL array, dimension (P)\n* The scalar factors of the elementary reflectors that define\n* P1.\n*\n* TAUP2 (output) REAL array, dimension (M-P)\n* The scalar factors of the elementary reflectors that define\n* P2.\n*\n* TAUQ1 (output) REAL array, dimension (Q)\n* The scalar factors of the elementary reflectors that define\n* Q1.\n*\n* TAUQ2 (output) REAL array, dimension (M-Q)\n* The scalar factors of the elementary reflectors that define\n* Q2.\n*\n* WORK (workspace) REAL 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 SORCSD for details.\n*\n* P1, P2, Q1, and Q2 are represented as products of elementary\n* reflectors. See SORCSD for details on generating P1, P2, Q1, and Q2\n* using SORGQR and SORGLQ.\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.sorbdb( 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_SFLOAT)
+ rblapack_x11 = na_change_type(rblapack_x11, NA_SFLOAT);
+ x11 = NA_PTR_TYPE(rblapack_x11, real*);
+ 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_SFLOAT)
+ rblapack_x21 = na_change_type(rblapack_x21, NA_SFLOAT);
+ x21 = NA_PTR_TYPE(rblapack_x21, real*);
+ 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_SFLOAT)
+ rblapack_x22 = na_change_type(rblapack_x22, NA_SFLOAT);
+ x22 = NA_PTR_TYPE(rblapack_x22, real*);
+ 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_SFLOAT)
+ rblapack_x12 = na_change_type(rblapack_x12, NA_SFLOAT);
+ x12 = NA_PTR_TYPE(rblapack_x12, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, real*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ phi = NA_PTR_TYPE(rblapack_phi, real*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_taup1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taup1 = NA_PTR_TYPE(rblapack_taup1, real*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_taup2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ taup2 = NA_PTR_TYPE(rblapack_taup2, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_tauq1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tauq1 = NA_PTR_TYPE(rblapack_tauq1, real*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_tauq2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tauq2 = NA_PTR_TYPE(rblapack_tauq2, real*);
+ {
+ int shape[2];
+ shape[0] = ldx11;
+ shape[1] = q;
+ rblapack_x11_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, real*);
+ MEMCPY(x11_out__, x11, real, NA_TOTAL(rblapack_x11));
+ rblapack_x11 = rblapack_x11_out__;
+ x11 = x11_out__;
+ {
+ int shape[2];
+ shape[0] = ldx12;
+ shape[1] = m-q;
+ rblapack_x12_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, real*);
+ MEMCPY(x12_out__, x12, real, NA_TOTAL(rblapack_x12));
+ rblapack_x12 = rblapack_x12_out__;
+ x12 = x12_out__;
+ {
+ int shape[2];
+ shape[0] = ldx21;
+ shape[1] = q;
+ rblapack_x21_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, real*);
+ MEMCPY(x21_out__, x21, real, NA_TOTAL(rblapack_x21));
+ rblapack_x21 = rblapack_x21_out__;
+ x21 = x21_out__;
+ {
+ int shape[2];
+ shape[0] = ldx22;
+ shape[1] = m-q;
+ rblapack_x22_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, real*);
+ MEMCPY(x22_out__, x22, real, NA_TOTAL(rblapack_x22));
+ rblapack_x22 = rblapack_x22_out__;
+ x22 = x22_out__;
+ work = ALLOC_N(real, (MAX(1,lwork)));
+
+ sorbdb_(&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_sorbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorbdb", rblapack_sorbdb, -1);
+}
diff --git a/ext/sorcsd.c b/ext/sorcsd.c
new file mode 100644
index 0000000..cabc8f1
--- /dev/null
+++ b/ext/sorcsd.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID sorcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, char* signs, integer* m, integer* p, integer* q, real* x11, integer* ldx11, real* x12, integer* ldx12, real* x21, integer* ldx21, real* x22, integer* ldx22, real* theta, real* u1, integer* ldu1, real* u2, integer* ldu2, real* v1t, integer* ldv1t, real* v2t, integer* ldv2t, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sorcsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_signs;
+ char signs;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x11;
+ real *x11;
+ VALUE rblapack_x12;
+ real *x12;
+ VALUE rblapack_x21;
+ real *x21;
+ VALUE rblapack_x22;
+ real *x22;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_theta;
+ real *theta;
+ VALUE rblapack_u1;
+ real *u1;
+ VALUE rblapack_u2;
+ real *u2;
+ VALUE rblapack_v1t;
+ real *v1t;
+ VALUE rblapack_v2t;
+ real *v2t;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ integer ldx11;
+ integer q;
+ integer ldx12;
+ integer ldx21;
+ integer ldx22;
+ integer p;
+ integer ldv2t;
+ integer ldv1t;
+ integer ldu1;
+ integer ldu2;
+
+ 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, u1, u2, v1t, v2t, info = NumRu::Lapack.sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORCSD computes the CS decomposition of an M-by-M partitioned\n* orthogonal matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) REAL array, dimension (LDX,M)\n* On entry, the orthogonal matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) REAL array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) REAL array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) REAL array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) REAL array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n* matrix V1**T.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) REAL array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n* matrix V2**T.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n* If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\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-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: SBBCSD did not converge. See the description of WORK\n* above for details.\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\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [: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_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_signs = argv[5];
+ rblapack_m = argv[6];
+ rblapack_x11 = argv[7];
+ rblapack_x12 = argv[8];
+ rblapack_x21 = argv[9];
+ rblapack_x22 = argv[10];
+ rblapack_lwork = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ m = NUM2INT(rblapack_m);
+ lwork = NUM2INT(rblapack_lwork);
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ signs = StringValueCStr(rblapack_signs)[0];
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_x11))
+ rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x11) != 2)
+ rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
+ ldx11 = NA_SHAPE0(rblapack_x11);
+ q = NA_SHAPE1(rblapack_x11);
+ if (NA_TYPE(rblapack_x11) != NA_SFLOAT)
+ rblapack_x11 = na_change_type(rblapack_x11, NA_SFLOAT);
+ x11 = NA_PTR_TYPE(rblapack_x11, real*);
+ p = ldx11;
+ ldx21 = p;
+ if (!NA_IsNArray(rblapack_x21))
+ rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_x21) != 2)
+ rb_raise(rb_eArgError, "rank of x21 (10th 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_SFLOAT)
+ rblapack_x21 = na_change_type(rblapack_x21, NA_SFLOAT);
+ x21 = NA_PTR_TYPE(rblapack_x21, real*);
+ ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
+ ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
+ ldx12 = p;
+ if (!NA_IsNArray(rblapack_x12))
+ rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x12) != 2)
+ rb_raise(rb_eArgError, "rank of x12 (9th 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_SFLOAT)
+ rblapack_x12 = na_change_type(rblapack_x12, NA_SFLOAT);
+ x12 = NA_PTR_TYPE(rblapack_x12, real*);
+ ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
+ ldx22 = p;
+ if (!NA_IsNArray(rblapack_x22))
+ rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
+ if (NA_RANK(rblapack_x22) != 2)
+ rb_raise(rb_eArgError, "rank of x22 (11th 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_SFLOAT)
+ rblapack_x22 = na_change_type(rblapack_x22, NA_SFLOAT);
+ x22 = NA_PTR_TYPE(rblapack_x22, real*);
+ ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
+ {
+ int shape[1];
+ shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
+ rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, real*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_u1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ u1 = NA_PTR_TYPE(rblapack_u1, real*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_u2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ u2 = NA_PTR_TYPE(rblapack_u2, real*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_v1t = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ v1t = NA_PTR_TYPE(rblapack_v1t, real*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_v2t = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ v2t = NA_PTR_TYPE(rblapack_v2t, real*);
+ work = ALLOC_N(real, (MAX(1,lwork)));
+ iwork = ALLOC_N(integer, (m-q));
+
+ sorcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
+}
+
+void
+init_lapack_sorcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorcsd", rblapack_sorcsd, -1);
+}
diff --git a/ext/sorg2l.c b/ext/sorg2l.c
new file mode 100644
index 0000000..f249774
--- /dev/null
+++ b/ext/sorg2l.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID sorg2l_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sorg2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.sorg2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORG2L generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.sorg2l( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+ work = ALLOC_N(real, (n));
+
+ sorg2l_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorg2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorg2l", rblapack_sorg2l, -1);
+}
diff --git a/ext/sorg2r.c b/ext/sorg2r.c
new file mode 100644
index 0000000..9bd5904
--- /dev/null
+++ b/ext/sorg2r.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID sorg2r_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sorg2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.sorg2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORG2R generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.sorg2r( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+ work = ALLOC_N(real, (n));
+
+ sorg2r_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorg2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorg2r", rblapack_sorg2r, -1);
+}
diff --git a/ext/sorgbr.c b/ext/sorgbr.c
new file mode 100644
index 0000000..8fa4188
--- /dev/null
+++ b/ext/sorgbr.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID sorgbr_(char* vect, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorgbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 work, info, a = NumRu::Lapack.sorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGBR generates one of the real orthogonal matrices Q or P**T\n* determined by SGEBRD when reducing a real matrix A to bidiagonal\n* form: A = Q * B * P**T. Q and P**T are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n* is of order N:\n* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m\n* rows of P**T, where n >= m >= k;\n* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**T is\n* required, as defined in the transformation applied by SGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**T.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**T to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**T to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by SGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by SGEBRD.\n* K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by SGEBRD.\n* On exit, the M-by-N matrix Q or P**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**T, as\n* returned by SGEBRD in its array argument TAUQ or TAUP.\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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_m = argv[1];
+ rblapack_k = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ k = NUM2INT(rblapack_k);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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);
+ n = 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 (rblapack_lwork == Qnil)
+ lwork = MIN(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sorgbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorgbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorgbr", rblapack_sorgbr, -1);
+}
diff --git a/ext/sorghr.c b/ext/sorghr.c
new file mode 100644
index 0000000..740d730
--- /dev/null
+++ b/ext/sorghr.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID sorghr_(integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorghr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 work, info, a = NumRu::Lapack.sorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGHR generates a real orthogonal matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* SGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of SGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by SGEHRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEHRD.\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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = 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*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = ihi-ilo;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sorghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorghr", rblapack_sorghr, -1);
+}
diff --git a/ext/sorgl2.c b/ext/sorgl2.c
new file mode 100644
index 0000000..485291e
--- /dev/null
+++ b/ext/sorgl2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID sorgl2_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sorgl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.sorgl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGL2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by SGELQF in the first k rows of its array argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\n*\n* WORK (workspace) REAL array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.sorgl2( a, tau, [: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_tau = 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);
+ n = 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*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (m));
+
+ sorgl2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorgl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorgl2", rblapack_sorgl2, -1);
+}
diff --git a/ext/sorglq.c b/ext/sorglq.c
new file mode 100644
index 0000000..a98ff60
--- /dev/null
+++ b/ext/sorglq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID sorglq_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorglq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.sorglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by SGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sorglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorglq", rblapack_sorglq, -1);
+}
diff --git a/ext/sorgql.c b/ext/sorgql.c
new file mode 100644
index 0000000..460ada8
--- /dev/null
+++ b/ext/sorgql.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID sorgql_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorgql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.sorgql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGQL generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sorgql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorgql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorgql", rblapack_sorgql, -1);
+}
diff --git a/ext/sorgqr.c b/ext/sorgqr.c
new file mode 100644
index 0000000..c95c2d9
--- /dev/null
+++ b/ext/sorgqr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID sorgqr_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorgqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.sorgqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGQR generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sorgqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorgqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorgqr", rblapack_sorgqr, -1);
+}
diff --git a/ext/sorgr2.c b/ext/sorgr2.c
new file mode 100644
index 0000000..7191ac5
--- /dev/null
+++ b/ext/sorgr2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID sorgr2_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);
+
+
+static VALUE
+rblapack_sorgr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.sorgr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGR2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGERQF in the last k rows of its array argument\n* A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\n*\n* WORK (workspace) REAL array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.sorgr2( a, tau, [: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_tau = 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);
+ n = 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*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+ work = ALLOC_N(real, (m));
+
+ sorgr2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorgr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorgr2", rblapack_sorgr2, -1);
+}
diff --git a/ext/sorgrq.c b/ext/sorgrq.c
new file mode 100644
index 0000000..9ae499b
--- /dev/null
+++ b/ext/sorgrq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID sorgrq_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorgrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.sorgrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sorgrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorgrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorgrq", rblapack_sorgrq, -1);
+}
diff --git a/ext/sorgtr.c b/ext/sorgtr.c
new file mode 100644
index 0000000..92a2d42
--- /dev/null
+++ b/ext/sorgtr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID sorgtr_(char* uplo, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sorgtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 work, info, a = NumRu::Lapack.sorgtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGTR generates a real orthogonal matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* SSYTRD:\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 triangle of A contains elementary reflectors\n* from SSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from SSYTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by SSYTRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SSYTRD.\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 >= max(1,N-1).\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ sorgtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_sorgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorgtr", rblapack_sorgtr, -1);
+}
diff --git a/ext/sorm2l.c b/ext/sorm2l.c
new file mode 100644
index 0000000..66dac58
--- /dev/null
+++ b/ext/sorm2l.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID sorm2l_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sorm2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer lda;
+ integer k;
+ 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.sorm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORM2L overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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.sorm2l( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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_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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ sorm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sorm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorm2l", rblapack_sorm2l, -1);
+}
diff --git a/ext/sorm2r.c b/ext/sorm2r.c
new file mode 100644
index 0000000..9c9d1ba
--- /dev/null
+++ b/ext/sorm2r.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID sorm2r_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sorm2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer lda;
+ integer k;
+ 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.sorm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORM2R overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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.sorm2r( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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_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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ sorm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sorm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorm2r", rblapack_sorm2r, -1);
+}
diff --git a/ext/sormbr.c b/ext/sormbr.c
new file mode 100644
index 0000000..1e7c0e8
--- /dev/null
+++ b/ext/sormbr.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID sormbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer ldc;
+ integer n;
+ integer nq;
+
+ 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 work, info, c = NumRu::Lapack.sormbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'T': Q**T * C C * Q**T\n*\n* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'T': P**T * C C * P**T\n*\n* Here Q and P**T are the orthogonal matrices determined by SGEBRD when\n* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n* P**T are defined as products of elementary reflectors H(i) and G(i)\n* respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the orthogonal matrix Q or P**T that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**T;\n* = 'P': apply P or P**T.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**T, P or P**T from the Left;\n* = 'R': apply Q, Q**T, P or P**T from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'T': Transpose, apply Q**T or P**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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by SGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by SGEBRD.\n* K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by SGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) REAL array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by SGEBRD in the array argument TAUQ or TAUP.\n*\n* C (input/output) REAL 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* or P*C or P**T*C or C*P or C*P**T.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SORMLQ, SORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormbr( vect, side, trans, m, k, a, tau, c, [: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_vect = argv[0];
+ rblapack_side = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_m = argv[3];
+ rblapack_k = argv[4];
+ rblapack_a = argv[5];
+ rblapack_tau = argv[6];
+ rblapack_c = 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;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th 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*);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
+ 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_tau))
+ rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormbr", rblapack_sormbr, -1);
+}
diff --git a/ext/sormhr.c b/ext/sormhr.c
new file mode 100644
index 0000000..17fcfb2
--- /dev/null
+++ b/ext/sormhr.c
@@ -0,0 +1,133 @@
+#include "rb_lapack.h"
+
+extern VOID sormhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormhr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.sormhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMHR 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* IHI-ILO elementary reflectors, as returned by SGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-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* 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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of SGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by SGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEHRD.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormhr( side, trans, ilo, ihi, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = 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;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th 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 (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_SFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormhr", rblapack_sormhr, -1);
+}
diff --git a/ext/sorml2.c b/ext/sorml2.c
new file mode 100644
index 0000000..cda0b4e
--- /dev/null
+++ b/ext/sorml2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID sorml2_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sorml2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.sorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORML2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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.sorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ sorml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sorml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sorml2", rblapack_sorml2, -1);
+}
diff --git a/ext/sormlq.c b/ext/sormlq.c
new file mode 100644
index 0000000..37ee713
--- /dev/null
+++ b/ext/sormlq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID sormlq_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormlq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.sormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMLQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormlq", rblapack_sormlq, -1);
+}
diff --git a/ext/sormql.c b/ext/sormql.c
new file mode 100644
index 0000000..2a1d16c
--- /dev/null
+++ b/ext/sormql.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID sormql_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.sormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMQL 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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_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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormql", rblapack_sormql, -1);
+}
diff --git a/ext/sormqr.c b/ext/sormqr.c
new file mode 100644
index 0000000..41254cc
--- /dev/null
+++ b/ext/sormqr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID sormqr_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.sormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMQR 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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_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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormqr", rblapack_sormqr, -1);
+}
diff --git a/ext/sormr2.c b/ext/sormr2.c
new file mode 100644
index 0000000..e74e96c
--- /dev/null
+++ b/ext/sormr2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID sormr2_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sormr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.sormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMR2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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.sormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ sormr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormr2", rblapack_sormr2, -1);
+}
diff --git a/ext/sormr3.c b/ext/sormr3.c
new file mode 100644
index 0000000..c4937ce
--- /dev/null
+++ b/ext/sormr3.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID sormr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);
+
+
+static VALUE
+rblapack_sormr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+ real *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.sormr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMR3 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by STZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* STZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by STZRZF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLARZ, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.sormr3( side, trans, l, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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_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);
+ 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*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ sormr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormr3", rblapack_sormr3, -1);
+}
diff --git a/ext/sormrq.c b/ext/sormrq.c
new file mode 100644
index 0000000..3c9de44
--- /dev/null
+++ b/ext/sormrq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID sormrq_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.sormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMRQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormrq", rblapack_sormrq, -1);
+}
diff --git a/ext/sormrz.c b/ext/sormrz.c
new file mode 100644
index 0000000..19216c9
--- /dev/null
+++ b/ext/sormrz.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID sormrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.sormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMRZ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* STZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by STZRZF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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_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);
+ 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 (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormrz", rblapack_sormrz, -1);
+}
diff --git a/ext/sormtr.c b/ext/sormtr.c
new file mode 100644
index 0000000..a040e10
--- /dev/null
+++ b/ext/sormtr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID sormtr_(char* side, char* uplo, char* trans, integer* m, integer* n, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_sormtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.sormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMTR 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 SSYTRD:\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 triangle of A contains elementary reflectors\n* from SSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from SSYTRD.\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* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by SSYTRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SSYTRD.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SORMQL, SORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ 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 (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th 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_SFLOAT)
+ rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+
+ sormtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_sormtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sormtr", rblapack_sormtr, -1);
+}
diff --git a/ext/spbcon.c b/ext/spbcon.c
new file mode 100644
index 0000000..e31caef
--- /dev/null
+++ b/ext/spbcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID spbcon_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_spbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ integer ldab;
+ 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.spbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite band matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the symmetric band 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 (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.spbcon( uplo, kd, ab, anorm, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ kd = NUM2INT(rblapack_kd);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ spbcon_(&uplo, &n, &kd, ab, &ldab, &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_spbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbcon", rblapack_spbcon, -1);
+}
diff --git a/ext/spbequ.c b/ext/spbequ.c
new file mode 100644
index 0000000..e523f1b
--- /dev/null
+++ b/ext/spbequ.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID spbequ_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_spbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 s, scond, amax, info = NumRu::Lapack.spbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPBEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.spbequ( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ spbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_spbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbequ", rblapack_spbequ, -1);
+}
diff --git a/ext/spbrfs.c b/ext/spbrfs.c
new file mode 100644
index 0000000..bacd8ff
--- /dev/null
+++ b/ext/spbrfs.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID spbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_spbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ 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 ldab;
+ integer n;
+ integer ldafb;
+ 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.spbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A as computed by\n* SPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+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/output) REAL array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SPBTRS.\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.spbrfs( uplo, kd, ab, afb, 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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_afb = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ 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*);
+ kd = NUM2INT(rblapack_kd);
+ 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_afb))
+ rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, 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));
+
+ spbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, 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_spbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbrfs", rblapack_spbrfs, -1);
+}
diff --git a/ext/spbstf.c b/ext/spbstf.c
new file mode 100644
index 0000000..560c6e4
--- /dev/null
+++ b/ext/spbstf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID spbstf_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_spbstf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.spbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* SPBSTF computes a split Cholesky factorization of a real\n* symmetric positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with SSBGST.\n*\n* The factorization has the form A = S**T*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**T*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.spbstf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ spbstf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_spbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbstf", rblapack_spbstf, -1);
+}
diff --git a/ext/spbsv.c b/ext/spbsv.c
new file mode 100644
index 0000000..0a7dfaa
--- /dev/null
+++ b/ext/spbsv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID spbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_spbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, ab, b = NumRu::Lapack.spbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPBSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPBTRF, SPBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.spbsv( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ spbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_spbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbsv", rblapack_spbsv, -1);
+}
diff --git a/ext/spbsvx.c b/ext/spbsvx.c
new file mode 100644
index 0000000..8b780fb
--- /dev/null
+++ b/ext/spbsvx.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID spbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_spbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_afb;
+ real *afb;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_afb_out__;
+ real *afb_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.spbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.spbsvx( fact, uplo, kd, ab, afb, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, real*);
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
+ MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ spbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_spbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbsvx", rblapack_spbsvx, -1);
+}
diff --git a/ext/spbtf2.c b/ext/spbtf2.c
new file mode 100644
index 0000000..b208bcd
--- /dev/null
+++ b/ext/spbtf2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID spbtf2_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_spbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.spbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* SPBTF2 computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the transpose of U, and\n* L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.spbtf2( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ spbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_spbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbtf2", rblapack_spbtf2, -1);
+}
diff --git a/ext/spbtrf.c b/ext/spbtrf.c
new file mode 100644
index 0000000..59aab62
--- /dev/null
+++ b/ext/spbtrf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID spbtrf_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_spbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.spbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* SPBTRF computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.spbtrf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ spbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_spbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbtrf", rblapack_spbtrf, -1);
+}
diff --git a/ext/spbtrs.c b/ext/spbtrs.c
new file mode 100644
index 0000000..6a9b994
--- /dev/null
+++ b/ext/spbtrs.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID spbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_spbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.spbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPBTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite band matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by SPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL STBSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spbtrs( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ spbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_spbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spbtrs", rblapack_spbtrs, -1);
+}
diff --git a/ext/spftrf.c b/ext/spftrf.c
new file mode 100644
index 0000000..7599dfe
--- /dev/null
+++ b/ext/spftrf.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID spftrf_(char* transr, char* uplo, integer* n, real* a, integer* info);
+
+
+static VALUE
+rblapack_spftrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_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, a = NumRu::Lapack.spftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* SPFTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension ( N*(N+1)/2 );\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the NT elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**T*U or RFP A = L*L**T.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spftrf( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+
+ spftrf_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_spftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spftrf", rblapack_spftrf, -1);
+}
diff --git a/ext/spftri.c b/ext/spftri.c
new file mode 100644
index 0000000..79addd3
--- /dev/null
+++ b/ext/spftri.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID spftri_(char* transr, char* uplo, integer* n, real* a, integer* info);
+
+
+static VALUE
+rblapack_spftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_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, a = NumRu::Lapack.spftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* SPFTRI computes the inverse of a real (symmetric) positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by SPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension ( N*(N+1)/2 )\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the symmetric inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spftri( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+
+ spftri_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_spftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spftri", rblapack_spftri, -1);
+}
diff --git a/ext/spftrs.c b/ext/spftrs.c
new file mode 100644
index 0000000..f314b7f
--- /dev/null
+++ b/ext/spftrs.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID spftrs_(char* transr, char* uplo, integer* n, integer* nrhs, real* a, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_spftrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.spftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPFTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by SPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) REAL array, dimension ( N*(N+1)/2 )\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**H*U or RFP A = L*L**T, as computed by SPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spftrs( transr, uplo, n, a, b, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ spftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_spftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spftrs", rblapack_spftrs, -1);
+}
diff --git a/ext/spocon.c b/ext/spocon.c
new file mode 100644
index 0000000..6adc3f1
--- /dev/null
+++ b/ext/spocon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID spocon_(char* uplo, integer* n, real* a, integer* lda, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_spocon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ 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 rcond, info = NumRu::Lapack.spocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPOCON estimates the reciprocal of the condition number (in the \n* 1-norm) of a real symmetric positive definite matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the symmetric 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 (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.spocon( uplo, a, anorm, [: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_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ spocon_(&uplo, &n, a, &lda, &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_spocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spocon", rblapack_spocon, -1);
+}
diff --git a/ext/spoequ.c b/ext/spoequ.c
new file mode 100644
index 0000000..51b0285
--- /dev/null
+++ b/ext/spoequ.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID spoequ_(integer* n, real* a, integer* lda, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_spoequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.spoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.spoequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ spoequ_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_spoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spoequ", rblapack_spoequ, -1);
+}
diff --git a/ext/spoequb.c b/ext/spoequb.c
new file mode 100644
index 0000000..c3f46a9
--- /dev/null
+++ b/ext/spoequb.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID spoequb_(integer* n, real* a, integer* lda, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_spoequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.spoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.spoequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ spoequb_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_spoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spoequb", rblapack_spoequb, -1);
+}
diff --git a/ext/sporfs.c b/ext/sporfs.c
new file mode 100644
index 0000000..67402e1
--- /dev/null
+++ b/ext/sporfs.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID sporfs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sporfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ 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 lda;
+ integer n;
+ integer ldaf;
+ 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.sporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\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 SPOTRS.\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.sporfs( uplo, a, af, b, x, [: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_af = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th 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_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 1 of af");
+ 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_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) != 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*);
+ {
+ 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));
+
+ sporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, 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_sporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sporfs", rblapack_sporfs, -1);
+}
diff --git a/ext/sporfsx.c b/ext/sporfsx.c
new file mode 100644
index 0000000..2196749
--- /dev/null
+++ b/ext/sporfsx.c
@@ -0,0 +1,206 @@
+#include "rb_lapack.h"
+
+extern VOID sporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sporfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.sporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.sporfsx( uplo, equed, a, af, s, b, x, params, [: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_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_s = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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_s))
+ rb_raise(rb_eArgError, "s (5th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th 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*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_sporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sporfsx", rblapack_sporfsx, -1);
+}
diff --git a/ext/sposv.c b/ext/sposv.c
new file mode 100644
index 0000000..682156a
--- /dev/null
+++ b/ext/sposv.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID sposv_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sposv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.sposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPOSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPOTRF, SPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.sposv( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_sposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sposv", rblapack_sposv, -1);
+}
diff --git a/ext/sposvx.c b/ext/sposvx.c
new file mode 100644
index 0000000..1235735
--- /dev/null
+++ b/ext/sposvx.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID sposvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sposvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_af_out__;
+ real *af_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.sposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.sposvx( fact, uplo, a, af, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = 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*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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] = 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[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
+ MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_sposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sposvx", rblapack_sposvx, -1);
+}
diff --git a/ext/sposvxx.c b/ext/sposvxx.c
new file mode 100644
index 0000000..2b6fbd8
--- /dev/null
+++ b/ext/sposvxx.c
@@ -0,0 +1,235 @@
+#include "rb_lapack.h"
+
+extern VOID sposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sposvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_af_out__;
+ real *af_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.sposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a real system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.sposvxx( fact, uplo, a, af, equed, s, b, params, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = 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*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, 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[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
+ MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_sposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sposvxx", rblapack_sposvxx, -1);
+}
diff --git a/ext/spotf2.c b/ext/spotf2.c
new file mode 100644
index 0000000..bb6420e
--- /dev/null
+++ b/ext/spotf2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID spotf2_(char* uplo, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_spotf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.spotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SPOTF2 computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\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.spotf2( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+
+ spotf2_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_spotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spotf2", rblapack_spotf2, -1);
+}
diff --git a/ext/spotrf.c b/ext/spotrf.c
new file mode 100644
index 0000000..29ef7e3
--- /dev/null
+++ b/ext/spotrf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID spotrf_(char* uplo, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_spotrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.spotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SPOTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\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.spotrf( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+
+ spotrf_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_spotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spotrf", rblapack_spotrf, -1);
+}
diff --git a/ext/spotri.c b/ext/spotri.c
new file mode 100644
index 0000000..11f67ea
--- /dev/null
+++ b/ext/spotri.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID spotri_(char* uplo, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_spotri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.spotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SPOTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, as computed by\n* SPOTRF.\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLAUUM, STRTRI, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spotri( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+
+ spotri_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_spotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spotri", rblapack_spotri, -1);
+}
diff --git a/ext/spotrs.c b/ext/spotrs.c
new file mode 100644
index 0000000..39c2ded
--- /dev/null
+++ b/ext/spotrs.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID spotrs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_spotrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.spotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPOTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) REAL array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.spotrs( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ spotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_spotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spotrs", rblapack_spotrs, -1);
+}
diff --git a/ext/sppcon.c b/ext/sppcon.c
new file mode 100644
index 0000000..51c0b09
--- /dev/null
+++ b/ext/sppcon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID sppcon_(char* uplo, integer* n, real* ap, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sppcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_anorm;
+ real anorm;
+ 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.sppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite packed matrix using\n* the Cholesky factorization A = U**T*U or A = L*L**T computed by\n* SPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the symmetric 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 (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.sppcon( uplo, ap, anorm, [: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_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ 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_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));
+
+ sppcon_(&uplo, &n, ap, &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_sppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sppcon", rblapack_sppcon, -1);
+}
diff --git a/ext/sppequ.c b/ext/sppequ.c
new file mode 100644
index 0000000..98b9e3b
--- /dev/null
+++ b/ext/sppequ.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID sppequ_(char* uplo, integer* n, real* ap, real* s, real* scond, real* amax, integer* info);
+
+
+static VALUE
+rblapack_sppequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.sppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPPEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.sppequ( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_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;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+
+ sppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_sppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sppequ", rblapack_sppequ, -1);
+}
diff --git a/ext/spprfs.c b/ext/spprfs.c
new file mode 100644
index 0000000..a92a0b1
--- /dev/null
+++ b/ext/spprfs.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID spprfs_(char* uplo, integer* n, integer* nrhs, real* ap, real* afp, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_spprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_afp;
+ real *afp;
+ 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 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, x = NumRu::Lapack.spprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) REAL array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\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 SPPTRS.\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.spprfs( uplo, ap, afp, b, x, [: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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ 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;
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th 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_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, 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));
+
+ spprfs_(&uplo, &n, &nrhs, ap, afp, 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_spprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spprfs", rblapack_spprfs, -1);
+}
diff --git a/ext/sppsv.c b/ext/sppsv.c
new file mode 100644
index 0000000..c2cbcf9
--- /dev/null
+++ b/ext/sppsv.c
@@ -0,0 +1,104 @@
+#include "rb_lapack.h"
+
+extern VOID sppsv_(char* uplo, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sppsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.sppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. \n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPPTRF, SPPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.sppsv( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ 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 = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_sppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sppsv", rblapack_sppsv, -1);
+}
diff --git a/ext/sppsvx.c b/ext/sppsvx.c
new file mode 100644
index 0000000..b396704
--- /dev/null
+++ b/ext/sppsvx.c
@@ -0,0 +1,191 @@
+#include "rb_lapack.h"
+
+extern VOID sppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* ap, real* afp, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sppsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_afp;
+ real *afp;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ VALUE rblapack_afp_out__;
+ real *afp_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ real *b_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 x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.sppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) REAL array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L', in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the original matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.sppsvx( fact, uplo, ap, afp, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_s);
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, real*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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[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__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, real*);
+ MEMCPY(afp_out__, afp, real, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_sppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sppsvx", rblapack_sppsvx, -1);
+}
diff --git a/ext/spptrf.c b/ext/spptrf.c
new file mode 100644
index 0000000..3ff6133
--- /dev/null
+++ b/ext/spptrf.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID spptrf_(char* uplo, integer* n, real* ap, integer* info);
+
+
+static VALUE
+rblapack_spptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ 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.spptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* SPPTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ======= =======\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.spptrf( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ {
+ int 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__;
+
+ spptrf_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_spptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spptrf", rblapack_spptrf, -1);
+}
diff --git a/ext/spptri.c b/ext/spptri.c
new file mode 100644
index 0000000..cc82e57
--- /dev/null
+++ b/ext/spptri.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID spptri_(char* uplo, integer* n, real* ap, integer* info);
+
+
+static VALUE
+rblapack_spptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ 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.spptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* SPPTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by SPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\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 triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.spptri( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ {
+ int 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__;
+
+ spptri_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_spptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spptri", rblapack_spptri, -1);
+}
diff --git a/ext/spptrs.c b/ext/spptrs.c
new file mode 100644
index 0000000..cc7748a
--- /dev/null
+++ b/ext/spptrs.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID spptrs_(char* uplo, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_spptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.spptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPPTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**T*U or A = L*L**T computed by SPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) REAL array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL STPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spptrs( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ 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 = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ spptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_spptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spptrs", rblapack_spptrs, -1);
+}
diff --git a/ext/spstf2.c b/ext/spstf2.c
new file mode 100644
index 0000000..e961b52
--- /dev/null
+++ b/ext/spstf2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID spstf2_(char* uplo, integer* n, real* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);
+
+
+static VALUE
+rblapack_spstf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tol;
+ real tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.spstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPSTF2 computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.spstf2( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = (real)NUM2DBL(rblapack_tol);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ 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__;
+ work = ALLOC_N(real, (2*n));
+
+ spstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_spstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spstf2", rblapack_spstf2, -1);
+}
diff --git a/ext/spstrf.c b/ext/spstrf.c
new file mode 100644
index 0000000..4f00dcc
--- /dev/null
+++ b/ext/spstrf.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID spstrf_(char* uplo, integer* n, real* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);
+
+
+static VALUE
+rblapack_spstrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tol;
+ real tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.spstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPSTRF computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.spstrf( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = (real)NUM2DBL(rblapack_tol);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ 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__;
+ work = ALLOC_N(real, (2*n));
+
+ spstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_spstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spstrf", rblapack_spstrf, -1);
+}
diff --git a/ext/sptcon.c b/ext/sptcon.c
new file mode 100644
index 0000000..193f278
--- /dev/null
+++ b/ext/sptcon.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID sptcon_(integer* n, real* d, real* e, real* anorm, real* rcond, real* work, integer* info);
+
+
+static VALUE
+rblapack_sptcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_anorm;
+ real anorm;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ real *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 rcond, info = NumRu::Lapack.sptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite tridiagonal matrix\n* using the factorization A = L*D*L**T or A = U**T*D*U computed by\n* SPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by SPTTRF.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by SPTTRF.\n*\n* ANORM (input) REAL\n* The 1-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 the\n* 1-norm of inv(A) computed in this routine.\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.sptcon( d, e, anorm, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ work = ALLOC_N(real, (n));
+
+ sptcon_(&n, d, e, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_sptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sptcon", rblapack_sptcon, -1);
+}
diff --git a/ext/spteqr.c b/ext/spteqr.c
new file mode 100644
index 0000000..feeac4f
--- /dev/null
+++ b/ext/spteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID spteqr_(char* compz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_spteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.spteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using SPTTRF, and then calling SBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band symmetric positive definite matrix\n* can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n* form, however, may preclude the possibility of obtaining high\n* relative accuracy in the small eigenvalues of the original matrix, if\n* these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original symmetric\n* matrix also. Array Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal\n* matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original symmetric matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.spteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of z");
+ 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(real, (4*n));
+
+ spteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_spteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spteqr", rblapack_spteqr, -1);
+}
diff --git a/ext/sptrfs.c b/ext/sptrfs.c
new file mode 100644
index 0000000..2d2676d
--- /dev/null
+++ b/ext/sptrfs.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID sptrfs_(integer* n, integer* nrhs, real* d, real* e, real* df, real* ef, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* info);
+
+
+static VALUE
+rblapack_sptrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_df;
+ real *df;
+ VALUE rblapack_ef;
+ real *ef;
+ 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 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.sptrfs( d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization computed by SPTTRF.\n*\n* EF (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the factorization computed by SPTTRF.\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 SPTTRS.\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 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).\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 (2*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.sptrfs( d, e, df, ef, 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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_df = argv[2];
+ rblapack_ef = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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 (3th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (3th 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_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*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ 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_ef))
+ rb_raise(rb_eArgError, "ef (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_SFLOAT)
+ rblapack_ef = na_change_type(rblapack_ef, NA_SFLOAT);
+ ef = NA_PTR_TYPE(rblapack_ef, 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, (2*n));
+
+ sptrfs_(&n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_sptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sptrfs", rblapack_sptrfs, -1);
+}
diff --git a/ext/sptsv.c b/ext/sptsv.c
new file mode 100644
index 0000000..ed9df70
--- /dev/null
+++ b/ext/sptsv.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID sptsv_(integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sptsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.sptsv( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPTSV computes the solution to a real system of linear equations\n* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**T, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**T.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**T factorization of\n* A. (E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**T*D*U factorization of A.)\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL SPTTRF, SPTTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.sptsv( d, e, b, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sptsv_(&n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_sptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sptsv", rblapack_sptsv, -1);
+}
diff --git a/ext/sptsvx.c b/ext/sptsvx.c
new file mode 100644
index 0000000..d2f7bf0
--- /dev/null
+++ b/ext/sptsvx.c
@@ -0,0 +1,168 @@
+#include "rb_lapack.h"
+
+extern VOID sptsvx_(char* fact, integer* n, integer* nrhs, real* d, real* e, real* df, real* ef, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* info);
+
+
+static VALUE
+rblapack_sptsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_df;
+ real *df;
+ VALUE rblapack_ef;
+ real *ef;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_df_out__;
+ real *df_out__;
+ VALUE rblapack_ef_out__;
+ real *ef_out__;
+ real *work;
+
+ 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 x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.sptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTSVX uses the factorization A = L*D*L**T to compute the solution\n* to a real system of linear equations A*X = B, where A is an N-by-N\n* symmetric positive definite tridiagonal matrix and X and B are\n* N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**T*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) REAL array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n*\n* EF (input or output) REAL array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) REAL array, dimension (NRHS)\n* The 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).\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 any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.sptsvx( fact, d, e, df, ef, b, [: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_fact = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_df = argv[3];
+ rblapack_ef = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (4th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_df);
+ 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_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 df");
+ 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_ef))
+ rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_SFLOAT)
+ rblapack_ef = na_change_type(rblapack_ef, NA_SFLOAT);
+ ef = NA_PTR_TYPE(rblapack_ef, real*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, real*);
+ MEMCPY(df_out__, df, real, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_ef_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, real*);
+ MEMCPY(ef_out__, ef, real, NA_TOTAL(rblapack_ef));
+ rblapack_ef = rblapack_ef_out__;
+ ef = ef_out__;
+ work = ALLOC_N(real, (2*n));
+
+ sptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
+}
+
+void
+init_lapack_sptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sptsvx", rblapack_sptsvx, -1);
+}
diff --git a/ext/spttrf.c b/ext/spttrf.c
new file mode 100644
index 0000000..ae160f5
--- /dev/null
+++ b/ext/spttrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID spttrf_(integer* n, real* d, real* e, integer* info);
+
+
+static VALUE
+rblapack_spttrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ 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, d, e = NumRu::Lapack.spttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* SPTTRF computes the L*D*L' factorization of a real symmetric\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.spttrf( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ spttrf_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_spttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spttrf", rblapack_spttrf, -1);
+}
diff --git a/ext/spttrs.c b/ext/spttrs.c
new file mode 100644
index 0000000..cd049ac
--- /dev/null
+++ b/ext/spttrs.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID spttrs_(integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_spttrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.spttrs( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by SPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n INTEGER J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SPTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spttrs( d, e, b, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ spttrs_(&n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_spttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "spttrs", rblapack_spttrs, -1);
+}
diff --git a/ext/sptts2.c b/ext/sptts2.c
new file mode 100644
index 0000000..f34175d
--- /dev/null
+++ b/ext/sptts2.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID sptts2_(integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb);
+
+
+static VALUE
+rblapack_sptts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.sptts2( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* SPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by SPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL SSCAL\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.sptts2( d, e, b, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sptts2_(&n, &nrhs, d, e, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_sptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sptts2", rblapack_sptts2, -1);
+}
diff --git a/ext/srscl.c b/ext/srscl.c
new file mode 100644
index 0000000..7203e3f
--- /dev/null
+++ b/ext/srscl.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID srscl_(integer* n, real* sa, real* sx, integer* incx);
+
+
+static VALUE
+rblapack_srscl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_sa;
+ real sa;
+ VALUE rblapack_sx;
+ real *sx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_sx_out__;
+ real *sx_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 sx = NumRu::Lapack.srscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* SRSCL multiplies an n-element real vector x by the real scalar 1/a.\n* This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) REAL\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) REAL array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sx = NumRu::Lapack.srscl( n, sa, sx, incx, [: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_n = argv[0];
+ rblapack_sa = argv[1];
+ rblapack_sx = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ sa = (real)NUM2DBL(rblapack_sa);
+ if (!NA_IsNArray(rblapack_sx))
+ rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
+ if (NA_RANK(rblapack_sx) != 1)
+ rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
+ if (NA_TYPE(rblapack_sx) != NA_SFLOAT)
+ rblapack_sx = na_change_type(rblapack_sx, NA_SFLOAT);
+ sx = NA_PTR_TYPE(rblapack_sx, real*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*abs(incx);
+ rblapack_sx_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, real*);
+ MEMCPY(sx_out__, sx, real, NA_TOTAL(rblapack_sx));
+ rblapack_sx = rblapack_sx_out__;
+ sx = sx_out__;
+
+ srscl_(&n, &sa, sx, &incx);
+
+ return rblapack_sx;
+}
+
+void
+init_lapack_srscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "srscl", rblapack_srscl, -1);
+}
diff --git a/ext/ssbev.c b/ext/ssbev.c
new file mode 100644
index 0000000..e3b8194
--- /dev/null
+++ b/ext/ssbev.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID ssbev_(char* jobz, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* w, real* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssbev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ab = NumRu::Lapack.ssbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.ssbev( jobz, uplo, kd, ab, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(real, (MAX(1,3*n-2)));
+
+ ssbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_ssbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbev", rblapack_ssbev, -1);
+}
diff --git a/ext/ssbevd.c b/ext/ssbevd.c
new file mode 100644
index 0000000..825b3e3
--- /dev/null
+++ b/ext/ssbevd.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID ssbevd_(char* jobz, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_ssbevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ab = NumRu::Lapack.ssbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A. If eigenvectors are desired, it uses\n* a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array,\n* dimension (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.\n* IF N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 2, LWORK must be at least\n* ( 1 + 5*N + 2*N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array LIWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab = NumRu::Lapack.ssbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 6) {
+ rblapack_lwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=0 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ ssbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_ssbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbevd", rblapack_ssbevd, -1);
+}
diff --git a/ext/ssbevx.c b/ext/ssbevx.c
new file mode 100644
index 0000000..9bdf7a4
--- /dev/null
+++ b/ext/ssbevx.c
@@ -0,0 +1,157 @@
+#include "rb_lapack.h"
+
+extern VOID ssbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_ssbevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ real *work;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, ifail, info, ab = NumRu::Lapack.ssbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric band matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) REAL array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.ssbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vu = argv[6];
+ rblapack_il = argv[7];
+ rblapack_iu = argv[8];
+ rblapack_abstol = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ vu = (real)NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
+ range = StringValueCStr(rblapack_range)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ kd = NUM2INT(rblapack_kd);
+ il = NUM2INT(rblapack_il);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(real, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ ssbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_ssbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbevx", rblapack_ssbevx, -1);
+}
diff --git a/ext/ssbgst.c b/ext/ssbgst.c
new file mode 100644
index 0000000..18c0fce
--- /dev/null
+++ b/ext/ssbgst.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID ssbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* x, integer* ldx, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssbgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_bb;
+ real *bb;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ 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 x, info, ab = NumRu::Lapack.ssbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBGST reduces a real symmetric-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**T*S by SPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**T*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) REAL array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by SPBSTF, stored in the first KB+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) REAL array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) REAL array, dimension (2*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 x, info, ab = NumRu::Lapack.ssbgst( vect, uplo, ka, kb, ab, bb, [: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_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, real*);
+ kb = NUM2INT(rblapack_kb);
+ ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(real, (2*n));
+
+ ssbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_ssbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbgst", rblapack_ssbgst, -1);
+}
diff --git a/ext/ssbgv.c b/ext/ssbgv.c
new file mode 100644
index 0000000..3043018
--- /dev/null
+++ b/ext/ssbgv.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID ssbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* w, real* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssbgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_bb;
+ real *bb;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_bb_out__;
+ real *bb_out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, info, ab, bb = NumRu::Lapack.ssbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) REAL array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by SPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.ssbgv( jobz, uplo, ka, kb, ab, bb, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, real*);
+ kb = NUM2INT(rblapack_kb);
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, real*);
+ MEMCPY(bb_out__, bb, real, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+ work = ALLOC_N(real, (3*n));
+
+ ssbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_ssbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbgv", rblapack_ssbgv, -1);
+}
diff --git a/ext/ssbgvd.c b/ext/ssbgvd.c
new file mode 100644
index 0000000..99edaa6
--- /dev/null
+++ b/ext/ssbgvd.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+extern VOID ssbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_ssbgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_bb;
+ real *bb;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_bb_out__;
+ real *bb_out__;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ab, bb = NumRu::Lapack.ssbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of the\n* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and\n* banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) REAL array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by SPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab, bb = NumRu::Lapack.ssbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 8) {
+ rblapack_lwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, real*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ kb = NUM2INT(rblapack_kb);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 3*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, real*);
+ MEMCPY(bb_out__, bb, real, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+
+ ssbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_ssbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbgvd", rblapack_ssbgvd, -1);
+}
diff --git a/ext/ssbgvx.c b/ext/ssbgvx.c
new file mode 100644
index 0000000..63b112b
--- /dev/null
+++ b/ext/ssbgvx.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID ssbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_ssbgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_bb;
+ real *bb;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_bb_out__;
+ real *bb_out__;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.ssbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSBGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) REAL array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by SPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) REAL array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array, dimension (7N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (5N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvalues that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* < 0 : if INFO = -i, the i-th argument had an illegal value\n* <= N: if INFO = i, then i eigenvectors failed to converge.\n* Their indices are stored in IFAIL.\n* > N : SPBSTF returned an error code; i.e.,\n* if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.ssbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ka = argv[3];
+ rblapack_kb = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_bb = argv[6];
+ rblapack_vl = argv[7];
+ rblapack_vu = argv[8];
+ rblapack_il = argv[9];
+ rblapack_iu = argv[10];
+ rblapack_abstol = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kb = NUM2INT(rblapack_kb);
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ n = NA_SHAPE1(rblapack_bb);
+ if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
+ rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
+ bb = NA_PTR_TYPE(rblapack_bb, real*);
+ vu = (real)NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ il = NUM2INT(rblapack_il);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
+ ka = NUM2INT(rblapack_ka);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ vl = (real)NUM2DBL(rblapack_vl);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = 7*n;
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = 5*n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, real*);
+ MEMCPY(bb_out__, bb, real, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+
+ ssbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_ssbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbgvx", rblapack_ssbgvx, -1);
+}
diff --git a/ext/ssbtrd.c b/ext/ssbtrd.c
new file mode 100644
index 0000000..1d06d1f
--- /dev/null
+++ b/ext/ssbtrd.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID ssbtrd_(char* vect, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* d, real* e, real* q, integer* ldq, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssbtrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ real *ab_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ real *work;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.ssbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBTRD reduces a real symmetric band matrix A to symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.ssbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
+ MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(real, (n));
+
+ ssbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
+}
+
+void
+init_lapack_ssbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssbtrd", rblapack_ssbtrd, -1);
+}
diff --git a/ext/ssfrk.c b/ext/ssfrk.c
new file mode 100644
index 0000000..f07c2de
--- /dev/null
+++ b/ext/ssfrk.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID ssfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, real* alpha, real* a, integer* lda, real* beta, real* c);
+
+
+static VALUE
+rblapack_ssfrk(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_beta;
+ real beta;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ integer lda;
+ integer nt;
+
+ 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.ssfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* SSFRK performs one of the symmetric rank--k operations\n*\n* C := alpha*A*A' + beta*C,\n*\n* or\n*\n* C := alpha*A'*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n symmetric\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.\n*\n* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with TRANS = 'T'\n* or 't', K specifies the number of rows of the matrix A. K\n* must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) REAL array of DIMENSION (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n*\n* C (input/output) REAL array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n* Format. RFP Format is described by TRANSR, UPLO and N.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.ssfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_n = argv[3];
+ rblapack_k = argv[4];
+ rblapack_alpha = argv[5];
+ rblapack_a = argv[6];
+ rblapack_beta = argv[7];
+ rblapack_c = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ k = NUM2INT(rblapack_k);
+ beta = (real)NUM2DBL(rblapack_beta);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ nt = NA_SHAPE0(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*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ if (NA_SHAPE1(rblapack_a) != ((lsame_(&trans,"N") || lsame_(&trans,"n")) ? k : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", (lsame_(&trans,"N") || lsame_(&trans,"n")) ? k : n);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = nt;
+ rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+
+ ssfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
+
+ return rblapack_c;
+}
+
+void
+init_lapack_ssfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssfrk", rblapack_ssfrk, -1);
+}
diff --git a/ext/sspcon.c b/ext/sspcon.c
new file mode 100644
index 0000000..7ccc6f3
--- /dev/null
+++ b/ext/sspcon.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID sspcon_(char* uplo, integer* n, real* ap, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sspcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ 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.sspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric packed matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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 block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\n*\n* ANORM (input) REAL\n* The 1-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.sspcon( uplo, ap, ipiv, anorm, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(real, (2*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sspcon_(&uplo, &n, ap, 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_sspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspcon", rblapack_sspcon, -1);
+}
diff --git a/ext/sspev.c b/ext/sspev.c
new file mode 100644
index 0000000..ce775a3
--- /dev/null
+++ b/ext/sspev.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID sspev_(char* jobz, char* uplo, integer* n, real* ap, real* w, real* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_sspev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ real *work;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap = NumRu::Lapack.sspev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.sspev( jobz, uplo, ap, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+ work = ALLOC_N(real, (3*n));
+
+ sspev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_sspev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspev", rblapack_sspev, -1);
+}
diff --git a/ext/sspevd.c b/ext/sspevd.c
new file mode 100644
index 0000000..8b67f1d
--- /dev/null
+++ b/ext/sspevd.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID sspevd_(char* jobz, char* uplo, integer* n, real* ap, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_sspevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ap = NumRu::Lapack.sspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPEVD computes all the eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least\n* 1 + 6*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap = NumRu::Lapack.sspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 5) {
+ rblapack_lwork = argv[3];
+ rblapack_liwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+n*n : 2;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+
+ sspevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_sspevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspevd", rblapack_sspevd, -1);
+}
diff --git a/ext/sspevx.c b/ext/sspevx.c
new file mode 100644
index 0000000..0592d2a
--- /dev/null
+++ b/ext/sspevx.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID sspevx_(char* jobz, char* range, char* uplo, integer* n, real* ap, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_sspevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ real *work;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap = NumRu::Lapack.sspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. Eigenvalues/vectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.sspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ 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;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+ work = ALLOC_N(real, (8*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ sspevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_sspevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspevx", rblapack_sspevx, -1);
+}
diff --git a/ext/sspgst.c b/ext/sspgst.c
new file mode 100644
index 0000000..7c1aed9
--- /dev/null
+++ b/ext/sspgst.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID sspgst_(integer* itype, char* uplo, integer* n, real* ap, real* bp, integer* info);
+
+
+static VALUE
+rblapack_sspgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_bp;
+ real *bp;
+ 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.sspgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* SSPGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by SPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) REAL array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by SPPTRF.\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, ap = NumRu::Lapack.sspgst( itype, uplo, n, ap, bp, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, real*);
+ 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);
+ 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*);
+ {
+ int 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__;
+
+ sspgst_(&itype, &uplo, &n, ap, bp, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_sspgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspgst", rblapack_sspgst, -1);
+}
diff --git a/ext/sspgv.c b/ext/sspgv.c
new file mode 100644
index 0000000..e442715
--- /dev/null
+++ b/ext/sspgv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID sspgv_(integer* itype, char* jobz, char* uplo, integer* n, real* ap, real* bp, real* w, real* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_sspgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_bp;
+ real *bp;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ VALUE rblapack_bp_out__;
+ real *bp_out__;
+ real *work;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap, bp = NumRu::Lapack.sspgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) REAL array, dimension\n* (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: SPPTRF or SSPEV returned an error code:\n* <= N: if INFO = i, SSPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero.\n* > N: if INFO = n + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPPTRF, SSPEV, SSPGST, STPMV, STPSV, XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.sspgv( itype, jobz, uplo, ap, bp, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, real*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, real*);
+ MEMCPY(bp_out__, bp, real, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(real, (3*n));
+
+ sspgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_sspgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspgv", rblapack_sspgv, -1);
+}
diff --git a/ext/sspgvd.c b/ext/sspgvd.c
new file mode 100644
index 0000000..6e2fb0b
--- /dev/null
+++ b/ext/sspgvd.c
@@ -0,0 +1,162 @@
+#include "rb_lapack.h"
+
+extern VOID sspgvd_(integer* itype, char* jobz, char* uplo, integer* n, real* ap, real* bp, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_sspgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_bp;
+ real *bp;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ VALUE rblapack_bp_out__;
+ real *bp_out__;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, iwork, info, ap, bp = NumRu::Lapack.sspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: SPPTRF or SSPEVD returned an error code:\n* <= N: if INFO = i, SSPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap, bp = NumRu::Lapack.sspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 7) {
+ rblapack_lwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, real*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, real*);
+ MEMCPY(bp_out__, bp, real, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+
+ sspgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_sspgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspgvd", rblapack_sspgvd, -1);
+}
diff --git a/ext/sspgvx.c b/ext/sspgvx.c
new file mode 100644
index 0000000..dde37af
--- /dev/null
+++ b/ext/sspgvx.c
@@ -0,0 +1,168 @@
+#include "rb_lapack.h"
+
+extern VOID sspgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, real* ap, real* bp, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_sspgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_bp;
+ real *bp;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ VALUE rblapack_bp_out__;
+ real *bp_out__;
+ real *work;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap, bp = NumRu::Lapack.sspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSPGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric, stored in packed storage, and B\n* is also positive definite. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: SPPTRF or SSPEVX returned an error code:\n* <= N: if INFO = i, SSPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.sspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_bp = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vu = argv[7];
+ rblapack_il = argv[8];
+ rblapack_iu = argv[9];
+ rblapack_abstol = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ 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);
+ 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*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
+ rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
+ bp = NA_PTR_TYPE(rblapack_bp, real*);
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ vu = (real)NUM2DBL(rblapack_vu);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, real*);
+ MEMCPY(bp_out__, bp, real, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(real, (8*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ sspgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_sspgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspgvx", rblapack_sspgvx, -1);
+}
diff --git a/ext/ssprfs.c b/ext/ssprfs.c
new file mode 100644
index 0000000..326d22b
--- /dev/null
+++ b/ext/ssprfs.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID ssprfs_(char* uplo, integer* n, integer* nrhs, real* ap, real* afp, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ssprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_afp;
+ real *afp;
+ 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.ssprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix A, packed\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*\n* AFP (input) REAL array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by SSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\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 SSPTRS.\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.ssprfs( uplo, ap, afp, ipiv, 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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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 (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);
+ 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_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);
+ 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*);
+ 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);
+ 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_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, 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));
+
+ ssprfs_(&uplo, &n, &nrhs, ap, afp, 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_ssprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssprfs", rblapack_ssprfs, -1);
+}
diff --git a/ext/sspsv.c b/ext/sspsv.c
new file mode 100644
index 0000000..f402d30
--- /dev/null
+++ b/ext/sspsv.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID sspsv_(char* uplo, integer* n, integer* nrhs, real* ap, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_sspsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldb;
+ integer nrhs;
+ 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 ipiv, info, ap, b = NumRu::Lapack.sspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by SSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSPTRF, SSPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.sspsv( uplo, ap, b, [: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_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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;
+ 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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ sspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_sspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspsv", rblapack_sspsv, -1);
+}
diff --git a/ext/sspsvx.c b/ext/sspsvx.c
new file mode 100644
index 0000000..3e6303f
--- /dev/null
+++ b/ext/sspsvx.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID sspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* ap, real* afp, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sspsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_afp;
+ real *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_afp_out__;
+ real *afp_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_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 x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.sspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a real system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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 triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) REAL array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by SSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by SSPTRF.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.sspsvx( fact, uplo, ap, afp, ipiv, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ ldx = MAX(1,n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
+ rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
+ afp = NA_PTR_TYPE(rblapack_afp, real*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, real*);
+ MEMCPY(afp_out__, afp, real, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
+}
+
+void
+init_lapack_sspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sspsvx", rblapack_sspsvx, -1);
+}
diff --git a/ext/ssptrd.c b/ext/ssptrd.c
new file mode 100644
index 0000000..1f37d1f
--- /dev/null
+++ b/ext/ssptrd.c
@@ -0,0 +1,100 @@
+#include "rb_lapack.h"
+
+extern VOID ssptrd_(char* uplo, integer* n, real* ap, real* d, real* e, real* tau, integer* info);
+
+
+static VALUE
+rblapack_ssptrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+
+ 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 d, e, tau, info, ap = NumRu::Lapack.ssptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRD reduces a real symmetric matrix A stored in packed form to\n* symmetric tridiagonal form T by an orthogonal similarity\n* transformation: Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.ssptrd( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_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;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+
+ ssptrd_(&uplo, &n, ap, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_ssptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssptrd", rblapack_ssptrd, -1);
+}
diff --git a/ext/ssptrf.c b/ext/ssptrf.c
new file mode 100644
index 0000000..396cd4a
--- /dev/null
+++ b/ext/ssptrf.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID ssptrf_(char* uplo, integer* n, real* ap, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_ssptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+
+ 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 ipiv, info, ap = NumRu::Lapack.ssptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRF computes the factorization of a real symmetric matrix A stored\n* in packed format using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.ssptrf( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_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;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ 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__;
+
+ ssptrf_(&uplo, &n, ap, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_ssptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssptrf", rblapack_ssptrf, -1);
+}
diff --git a/ext/ssptri.c b/ext/ssptri.c
new file mode 100644
index 0000000..a28678f
--- /dev/null
+++ b/ext/ssptri.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID ssptri_(char* uplo, integer* n, real* ap, integer* ipiv, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ real *ap_out__;
+ real *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 info, ap = NumRu::Lapack.ssptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRI computes the inverse of a real symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by SSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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 block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\n*\n* WORK (workspace) REAL 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.ssptri( uplo, ap, ipiv, [: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_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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*);
+ {
+ int 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__;
+ work = ALLOC_N(real, (n));
+
+ ssptri_(&uplo, &n, ap, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_ssptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssptri", rblapack_ssptri, -1);
+}
diff --git a/ext/ssptrs.c b/ext/ssptrs.c
new file mode 100644
index 0000000..f17c64c
--- /dev/null
+++ b/ext/ssptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID ssptrs_(char* uplo, integer* n, integer* nrhs, real* ap, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ssptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ssptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) REAL array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.ssptrs( uplo, ap, ipiv, b, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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*);
+ 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);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ssptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ssptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssptrs", rblapack_ssptrs, -1);
+}
diff --git a/ext/sstebz.c b/ext/sstebz.c
new file mode 100644
index 0000000..bb3772a
--- /dev/null
+++ b/ext/sstebz.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID sstebz_(char* range, char* order, integer* n, real* vl, real* vu, integer* il, integer* iu, real* abstol, real* d, real* e, integer* m, integer* nsplit, real* w, integer* iblock, integer* isplit, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_sstebz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_order;
+ char order;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_nsplit;
+ integer nsplit;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ 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 m, nsplit, w, iblock, isplit, info = NumRu::Lapack.sstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEBZ computes the eigenvalues of a symmetric tridiagonal\n* matrix T. The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute tolerance for the eigenvalues. An eigenvalue\n* (or cluster) is considered to be located if it has been\n* determined to lie in an interval whose width is ABSTOL or\n* less. If ABSTOL is less than or equal to zero, then ULP*|T|\n* will be used, where |T| means the 1-norm of T.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* NSPLIT (output) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* W (output) REAL array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalues. (SSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (SSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* RELFAC REAL, default = 2.0e0\n* The relative tolerance. An interval (a,b] lies within\n* \"relative tolerance\" if b-a < RELFAC*ulp*max(|a|,|b|),\n* where \"ulp\" is the machine precision (distance from 1 to\n* the next larger floating point number.)\n*\n* FUDGE REAL, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, nsplit, w, iblock, isplit, info = NumRu::Lapack.sstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_range = argv[0];
+ rblapack_order = argv[1];
+ rblapack_vl = argv[2];
+ rblapack_vu = argv[3];
+ rblapack_il = argv[4];
+ rblapack_iu = argv[5];
+ rblapack_abstol = argv[6];
+ rblapack_d = argv[7];
+ rblapack_e = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ range = StringValueCStr(rblapack_range)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ order = StringValueCStr(rblapack_order)[0];
+ iu = NUM2INT(rblapack_iu);
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (8th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (8th 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_e))
+ rb_raise(rb_eArgError, "e (9th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (3*n));
+
+ sstebz_(&range, &order, &n, &vl, &vu, &il, &iu, &abstol, d, e, &m, &nsplit, w, iblock, isplit, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_nsplit = INT2NUM(nsplit);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_m, rblapack_nsplit, rblapack_w, rblapack_iblock, rblapack_isplit, rblapack_info);
+}
+
+void
+init_lapack_sstebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstebz", rblapack_sstebz, -1);
+}
diff --git a/ext/sstedc.c b/ext/sstedc.c
new file mode 100644
index 0000000..bd9f868
--- /dev/null
+++ b/ext/sstedc.c
@@ -0,0 +1,159 @@
+#include "rb_lapack.h"
+
+extern VOID sstedc_(char* compz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_sstedc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 work, iwork, info, d, e, z = NumRu::Lapack.sstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band real symmetric matrix can also be\n* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See SLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original dense symmetric\n* matrix also. On entry, Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\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.\n* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be max(1,2*(N-1)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LIWORK must be at least\n* ( 6 + 6*N + 5*N*lg N ).\n* If COMPZ = 'I' and N > 1 then LIWORK must be at least\n* ( 3 + 5*N ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, iwork, info, d, e, z = NumRu::Lapack.sstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 6) {
+ rblapack_lwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of z");
+ if (NA_TYPE(rblapack_d) != NA_SFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ sstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_sstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstedc", rblapack_sstedc, -1);
+}
diff --git a/ext/sstegr.c b/ext/sstegr.c
new file mode 100644
index 0000000..dc19e76
--- /dev/null
+++ b/ext/sstegr.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID sstegr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_sstegr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* SSTEGR is a compatability wrapper around the improved SSTEMR routine.\n* See SSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : SSTEGR and SSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in SLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* SLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL SSTEMR\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ sstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_sstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstegr", rblapack_sstegr, -1);
+}
diff --git a/ext/sstein.c b/ext/sstein.c
new file mode 100644
index 0000000..049e437
--- /dev/null
+++ b/ext/sstein.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID sstein_(integer* n, real* d, real* e, integer* m, real* w, integer* iblock, integer* isplit, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_sstein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.sstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) REAL array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from SSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from SSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from SSTEBZ is expected here. )\n*\n* Z (output) REAL array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.sstein( d, e, w, iblock, isplit, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_w = argv[2];
+ rblapack_iblock = argv[3];
+ rblapack_isplit = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_SFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ m = n;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ ldz = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = m;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ work = ALLOC_N(real, (5*n));
+ iwork = ALLOC_N(integer, (n));
+
+ sstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
+}
+
+void
+init_lapack_sstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstein", rblapack_sstein, -1);
+}
diff --git a/ext/sstemr.c b/ext/sstemr.c
new file mode 100644
index 0000000..40b4dd9
--- /dev/null
+++ b/ext/sstemr.c
@@ -0,0 +1,193 @@
+#include "rb_lapack.h"
+
+extern VOID sstemr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, integer* m, real* w, real* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_sstemr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_nzc;
+ integer nzc;
+ VALUE rblapack_tryrac;
+ logical tryrac;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.sstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.SSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in SLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* SLARRV, respectively.\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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.sstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_nzc = argv[8];
+ rblapack_tryrac = argv[9];
+ if (argc == 12) {
+ rblapack_lwork = argv[10];
+ rblapack_liwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ nzc = NUM2INT(rblapack_nzc);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ tryrac = (rblapack_tryrac == Qtrue);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ sstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ rblapack_tryrac = tryrac ? Qtrue : Qfalse;
+ return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
+}
+
+void
+init_lapack_sstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstemr", rblapack_sstemr, -1);
+}
diff --git a/ext/ssteqr.c b/ext/ssteqr.c
new file mode 100644
index 0000000..4084b6c
--- /dev/null
+++ b/ext/ssteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID ssteqr_(char* compz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.ssteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band symmetric matrix can also be found\n* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to\n* tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* symmetric matrix. On entry, Z must contain the\n* orthogonal matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is orthogonally similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.ssteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(rblapack_z);
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of z");
+ 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(real, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
+
+ ssteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_ssteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssteqr", rblapack_ssteqr, -1);
+}
diff --git a/ext/ssterf.c b/ext/ssterf.c
new file mode 100644
index 0000000..65598be
--- /dev/null
+++ b/ext/ssterf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID ssterf_(integer* n, real* d, real* e, integer* info);
+
+
+static VALUE
+rblapack_ssterf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ 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, d, e = NumRu::Lapack.ssterf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTERF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n* using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed to find all of the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.ssterf( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th 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_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ ssterf_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_ssterf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssterf", rblapack_ssterf, -1);
+}
diff --git a/ext/sstev.c b/ext/sstev.c
new file mode 100644
index 0000000..f16109f
--- /dev/null
+++ b/ext/sstev.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID sstev_(char* jobz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* info);
+
+
+static VALUE
+rblapack_sstev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ real *work;
+
+ integer n;
+ integer ldz;
+
+ 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 z, info, d, e = NumRu::Lapack.sstev( jobz, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,2*N-2))\n* If JOBZ = 'N', WORK is not referenced.\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, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, info, d, e = NumRu::Lapack.sstev( jobz, d, e, [: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_jobz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(real, (lsame_(&jobz,"N") ? 0 : MAX(1,2*n-2)));
+
+ sstev_(&jobz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_z, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_sstev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstev", rblapack_sstev, -1);
+}
diff --git a/ext/sstevd.c b/ext/sstevd.c
new file mode 100644
index 0000000..2e35a8f
--- /dev/null
+++ b/ext/sstevd.c
@@ -0,0 +1,144 @@
+#include "rb_lapack.h"
+
+extern VOID sstevd_(char* jobz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_sstevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 z, work, iwork, info, d, e = NumRu::Lapack.sstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array,\n* dimension (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.\n* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, work, iwork, info, d, e = NumRu::Lapack.sstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 5) {
+ rblapack_lwork = argv[3];
+ rblapack_liwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 (rblapack_lwork == Qnil)
+ lwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 1+4*n+n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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-1;
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ sstevd_(&jobz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_sstevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstevd", rblapack_sstevd, -1);
+}
diff --git a/ext/sstevr.c b/ext/sstevr.c
new file mode 100644
index 0000000..a8735f4
--- /dev/null
+++ b/ext/sstevr.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID sstevr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_sstevr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n* Whenever possible, SSTEVR calls SSTEMR to compute the\n* eigenspectrum using Relatively Robust Representations. SSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows. For the i-th\n* unreduced block of T,\n* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n* is a relatively robust representation,\n* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n* relative accuracy by the dqds algorithm,\n* (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n* close to the cluster, and go to step (a),\n* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n* compute the corresponding eigenvector by forming a\n* rank-revealing twisted factorization.\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n* Computer Science Division Technical Report No. UCB//CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of SSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** SSTEIN are called\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) REAL array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal (and\n* minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= 20*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal (and\n* minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 10*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ if (rblapack_liwork == Qnil)
+ liwork = 10*n;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ if (rblapack_lwork == Qnil)
+ lwork = 20*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"I") ? iu-il+1 : n;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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] = MAX(1,n-1);
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ sstevr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_sstevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstevr", rblapack_sstevr, -1);
+}
diff --git a/ext/sstevx.c b/ext/sstevx.c
new file mode 100644
index 0000000..7d38c35
--- /dev/null
+++ b/ext/sstevx.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID sstevx_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_sstevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ real *d_out__;
+ VALUE rblapack_e_out__;
+ real *e_out__;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, d, e = NumRu::Lapack.sstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSTEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix A. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) REAL array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less\n* than or equal to zero, then EPS*|T| will be used in\n* its place, where |T| is the 1-norm of the tridiagonal\n* matrix.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge (INFO > 0), then that\n* column of Z contains the latest approximation to the\n* eigenvector, and the index of the eigenvector is returned\n* in IFAIL. If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, d, e = NumRu::Lapack.sstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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*);
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ m = n;
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
+ if (NA_TYPE(rblapack_e) != NA_SFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ iu = NUM2INT(rblapack_iu);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ 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] = MAX(1,n-1);
+ rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
+ MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ work = ALLOC_N(real, (5*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ sstevx_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_sstevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "sstevx", rblapack_sstevx, -1);
+}
diff --git a/ext/ssycon.c b/ext/ssycon.c
new file mode 100644
index 0000000..e802c83
--- /dev/null
+++ b/ext/ssycon.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID ssycon_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ssycon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ 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 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 rcond, info = NumRu::Lapack.ssycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by SSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* ANORM (input) REAL\n* The 1-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.ssycon( uplo, a, ipiv, anorm, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ anorm = (real)NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(real, (2*n));
+ iwork = ALLOC_N(integer, (n));
+
+ ssycon_(&uplo, &n, a, &lda, 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_ssycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssycon", rblapack_ssycon, -1);
+}
diff --git a/ext/ssyconv.c b/ext/ssyconv.c
new file mode 100644
index 0000000..56da180
--- /dev/null
+++ b/ext/ssyconv.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID ssyconv_(char* uplo, char* way, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssyconv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_way;
+ char way;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+
+ 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 = NumRu::Lapack.ssyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYCONV convert A given by TRF into L and D and vice-versa.\n* Get Non-diag elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 = NumRu::Lapack.ssyconv( uplo, way, a, ipiv, [: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_way = argv[1];
+ rblapack_a = argv[2];
+ rblapack_ipiv = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ way = StringValueCStr(rblapack_way)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ work = ALLOC_N(real, (MAX(1,n)));
+
+ ssyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rblapack_info;
+}
+
+void
+init_lapack_ssyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyconv", rblapack_ssyconv, -1);
+}
diff --git a/ext/ssyequb.c b/ext/ssyequb.c
new file mode 100644
index 0000000..3db130e
--- /dev/null
+++ b/ext/ssyequb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ssyequb_(char* uplo, integer* n, real* a, integer* lda, real* s, real* scond, real* amax, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssyequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_scond;
+ real scond;
+ VALUE rblapack_amax;
+ real amax;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+
+ 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 s, scond, amax, info = NumRu::Lapack.ssyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.ssyequb( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ work = ALLOC_N(real, (3*n));
+
+ ssyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
+
+ free(work);
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_ssyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyequb", rblapack_ssyequb, -1);
+}
diff --git a/ext/ssyev.c b/ext/ssyev.c
new file mode 100644
index 0000000..3e3d432
--- /dev/null
+++ b/ext/ssyev.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID ssyev_(char* jobz, char* uplo, integer* n, real* a, integer* lda, real* w, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ssyev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 w, work, info, a = NumRu::Lapack.ssyev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for SSYTRD returned by ILAENV.\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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.ssyev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ n = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ ssyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssyev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyev", rblapack_ssyev, -1);
+}
diff --git a/ext/ssyevd.c b/ext/ssyevd.c
new file mode 100644
index 0000000..575f3a5
--- /dev/null
+++ b/ext/ssyevd.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID ssyevd_(char* jobz, char* uplo, integer* n, real* a, integer* lda, real* w, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_ssyevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 w, work, iwork, info, a = NumRu::Lapack.ssyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* Because of large use of BLAS of level 3, SSYEVD needs N**2 more\n* workspace than SSYEVX.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) REAL array,\n* dimension (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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least \n* 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, iwork, info, a = NumRu::Lapack.ssyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 5) {
+ rblapack_lwork = argv[3];
+ rblapack_liwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ n = 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 (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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__;
+
+ ssyevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssyevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyevd", rblapack_ssyevd, -1);
+}
diff --git a/ext/ssyevr.c b/ext/ssyevr.c
new file mode 100644
index 0000000..0dd4db9
--- /dev/null
+++ b/ext/ssyevr.c
@@ -0,0 +1,172 @@
+#include "rb_lapack.h"
+
+extern VOID ssyevr_(char* jobz, char* range, char* uplo, integer* n, real* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_ssyevr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.ssyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* SSYEVR first reduces the matrix A to tridiagonal form T with a call\n* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute\n* the eigenspectrum using Relatively Robust Representations. SSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see SSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of SSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** SSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 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 >= max(1,26*N).\n* For optimal efficiency, LWORK >= (NB+6)*N,\n* where NB is the max of the blocksize for SSYTRD and SORMTR\n* returned by ILAENV.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.ssyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ 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);
+ n = 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 (rblapack_lwork == Qnil)
+ lwork = 26*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"I") ? iu-il+1 : n;
+ if (rblapack_liwork == Qnil)
+ liwork = 10*n;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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__;
+
+ ssyevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssyevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyevr", rblapack_ssyevr, -1);
+}
diff --git a/ext/ssyevx.c b/ext/ssyevx.c
new file mode 100644
index 0000000..6376792
--- /dev/null
+++ b/ext/ssyevx.c
@@ -0,0 +1,157 @@
+#include "rb_lapack.h"
+
+extern VOID ssyevx_(char* jobz, char* range, char* uplo, integer* n, real* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_ssyevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a = NumRu::Lapack.ssyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSYEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\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 length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 8*N.\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the max of the blocksize for SSYTRD and SORMTR\n* returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.ssyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = (real)NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = (real)NUM2DBL(rblapack_vu);
+ 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);
+ n = 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 (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : 8*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"I") ? iu-il+1 : n;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ 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__;
+ iwork = ALLOC_N(integer, (5*n));
+
+ ssyevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssyevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyevx", rblapack_ssyevx, -1);
+}
diff --git a/ext/ssygs2.c b/ext/ssygs2.c
new file mode 100644
index 0000000..f24f87c
--- /dev/null
+++ b/ext/ssygs2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID ssygs2_(integer* itype, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ssygs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.ssygs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSYGS2 reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) REAL array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by SPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.ssygs2( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ n = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, 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__;
+
+ ssygs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssygs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssygs2", rblapack_ssygs2, -1);
+}
diff --git a/ext/ssygst.c b/ext/ssygst.c
new file mode 100644
index 0000000..653ec8f
--- /dev/null
+++ b/ext/ssygst.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID ssygst_(integer* itype, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ssygst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.ssygst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSYGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) REAL array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by SPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.ssygst( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ n = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, 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__;
+
+ ssygst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssygst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssygst", rblapack_ssygst, -1);
+}
diff --git a/ext/ssygv.c b/ext/ssygv.c
new file mode 100644
index 0000000..38b09c5
--- /dev/null
+++ b/ext/ssygv.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID ssygv_(integer* itype, char* jobz, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, real* w, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ssygv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, info, a, b = NumRu::Lapack.ssygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the symmetric positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for SSYTRD returned by ILAENV.\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* > 0: SPOTRF or SSYEV returned an error code:\n* <= N: if INFO = i, SSYEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.ssygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ssygv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_ssygv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssygv", rblapack_ssygv, -1);
+}
diff --git a/ext/ssygvd.c b/ext/ssygvd.c
new file mode 100644
index 0000000..1eb1671
--- /dev/null
+++ b/ext/ssygvd.c
@@ -0,0 +1,155 @@
+#include "rb_lapack.h"
+
+extern VOID ssygvd_(integer* itype, char* jobz, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, real* w, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_ssygvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, iwork, info, a, b = NumRu::Lapack.ssygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: SPOTRF or SSYEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if SSYEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, iwork, info, a, b = NumRu::Lapack.ssygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 7) {
+ rblapack_lwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ssygvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_ssygvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssygvd", rblapack_ssygvd, -1);
+}
diff --git a/ext/ssygvx.c b/ext/ssygvx.c
new file mode 100644
index 0000000..34095f9
--- /dev/null
+++ b/ext/ssygvx.c
@@ -0,0 +1,191 @@
+#include "rb_lapack.h"
+
+extern VOID ssygvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_ssygvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_ldb;
+ integer ldb;
+ VALUE rblapack_vl;
+ real vl;
+ VALUE rblapack_vu;
+ real vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ real abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ real *w;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a, b = NumRu::Lapack.ssygvx( itype, jobz, range, uplo, a, b, ldb, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSYGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\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 length of the array WORK. LWORK >= max(1,8*N).\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the blocksize for SSYTRD returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: SPOTRF or SSYEVX returned an error code:\n* <= N: if INFO = i, SSYEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.ssygvx( itype, jobz, range, uplo, a, b, ldb, vl, vu, il, iu, abstol, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_ldb = argv[6];
+ rblapack_vl = argv[7];
+ rblapack_vu = argv[8];
+ rblapack_il = argv[9];
+ rblapack_iu = argv[10];
+ rblapack_abstol = 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;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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*);
+ ldb = NUM2INT(rblapack_ldb);
+ vu = (real)NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_b) != lda)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 0 of a");
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ il = NUM2INT(rblapack_il);
+ if (rblapack_lwork == Qnil)
+ lwork = 8*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ abstol = (real)NUM2DBL(rblapack_abstol);
+ vl = (real)NUM2DBL(rblapack_vl);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, real*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
+ rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ 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[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (5*n));
+
+ ssygvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_ssygvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssygvx", rblapack_ssygvx, -1);
+}
diff --git a/ext/ssyrfs.c b/ext/ssyrfs.c
new file mode 100644
index 0000000..625ede7
--- /dev/null
+++ b/ext/ssyrfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID ssyrfs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ssyrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ 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 lda;
+ integer n;
+ integer ldaf;
+ 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.ssyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\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 SSYTRS.\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.ssyrfs( uplo, a, af, ipiv, 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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ 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*);
+ 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 1 of af");
+ 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_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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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));
+
+ ssyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, 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_ssyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyrfs", rblapack_ssyrfs, -1);
+}
diff --git a/ext/ssyrfsx.c b/ext/ssyrfsx.c
new file mode 100644
index 0000000..78ab515
--- /dev/null
+++ b/ext/ssyrfsx.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID ssyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ssyrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_x_out__;
+ real *x_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.ssyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.ssyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ n_err_bnds = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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*);
+ {
+ 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ ssyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_ssyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyrfsx", rblapack_ssyrfsx, -1);
+}
diff --git a/ext/ssysv.c b/ext/ssysv.c
new file mode 100644
index 0000000..224b306
--- /dev/null
+++ b/ext/ssysv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID ssysv_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ssysv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, work, info, a, b = NumRu::Lapack.ssysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by SSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\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 length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* SSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSYTRF, SSYTRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.ssysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ssysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_ssysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssysv", rblapack_ssysv, -1);
+}
diff --git a/ext/ssysvx.c b/ext/ssysvx.c
new file mode 100644
index 0000000..828f534
--- /dev/null
+++ b/ext/ssysvx.c
@@ -0,0 +1,183 @@
+#include "rb_lapack.h"
+
+extern VOID ssysvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ssysvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_ferr;
+ real *ferr;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_af_out__;
+ real *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.ssysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a real system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form of\n* A. AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by SSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by SSYTRF.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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/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 length of WORK. LWORK >= max(1,3*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n* NB is the optimal blocksize for SSYTRF.\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 (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.ssysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ ldx = MAX(1,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
+ MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ iwork = ALLOC_N(integer, (n));
+
+ ssysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
+}
+
+void
+init_lapack_ssysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssysvx", rblapack_ssysvx, -1);
+}
diff --git a/ext/ssysvxx.c b/ext/ssysvxx.c
new file mode 100644
index 0000000..7353d0d
--- /dev/null
+++ b/ext/ssysvxx.c
@@ -0,0 +1,258 @@
+#include "rb_lapack.h"
+
+extern VOID ssysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ssysvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_af;
+ real *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_params;
+ real *params;
+ VALUE rblapack_x;
+ real *x;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_rpvgrw;
+ real rpvgrw;
+ VALUE rblapack_berr;
+ real *berr;
+ VALUE rblapack_err_bnds_norm;
+ real *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ real *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_af_out__;
+ real *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_s_out__;
+ real *s_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_params_out__;
+ real *params_out__;
+ real *work;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.ssysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a real system of linear equations A * X = B, where A\n* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.ssysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = 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_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_SFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, real*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_SFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, real*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, 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] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, 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[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
+ MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
+ MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
+ MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(real, (4*n));
+ iwork = ALLOC_N(integer, (n));
+
+ ssysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_ssysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssysvxx", rblapack_ssysvxx, -1);
+}
diff --git a/ext/ssyswapr.c b/ext/ssyswapr.c
new file mode 100644
index 0000000..7b857d8
--- /dev/null
+++ b/ext/ssyswapr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ssyswapr_(char* uplo, integer* n, real* a, integer* i1, integer* i2);
+
+
+static VALUE
+rblapack_ssyswapr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_i1;
+ integer i1;
+ VALUE rblapack_i2;
+ integer i2;
+ VALUE rblapack_a_out__;
+ real *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 a = NumRu::Lapack.ssyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* SSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n REAL TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSWAP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.ssyswapr( uplo, a, i1, i2, [: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_a = argv[1];
+ rblapack_i1 = argv[2];
+ rblapack_i2 = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ i1 = NUM2INT(rblapack_i1);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ i2 = NUM2INT(rblapack_i2);
+ {
+ 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__;
+
+ ssyswapr_(&uplo, &n, a, &i1, &i2);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_ssyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssyswapr", rblapack_ssyswapr, -1);
+}
diff --git a/ext/ssytd2.c b/ext/ssytd2.c
new file mode 100644
index 0000000..e7a4c94
--- /dev/null
+++ b/ext/ssytd2.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID ssytd2_(char* uplo, integer* n, real* a, integer* lda, real* d, real* e, real* tau, integer* info);
+
+
+static VALUE
+rblapack_ssytd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 d, e, tau, info, a = NumRu::Lapack.ssytd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n* form T by an orthogonal similarity transformation: Q' * A * Q = T.\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) REAL 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.ssytd2( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+
+ ssytd2_(&uplo, &n, a, &lda, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssytd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytd2", rblapack_ssytd2, -1);
+}
diff --git a/ext/ssytf2.c b/ext/ssytf2.c
new file mode 100644
index 0000000..1ba9dd9
--- /dev/null
+++ b/ext/ssytf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID ssytf2_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_ssytf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 ipiv, info, a = NumRu::Lapack.ssytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SSYTF2 computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) REAL 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.204 and l.372\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.ssytf2( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ 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__;
+
+ ssytf2_(&uplo, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytf2", rblapack_ssytf2, -1);
+}
diff --git a/ext/ssytrd.c b/ext/ssytrd.c
new file mode 100644
index 0000000..6de840a
--- /dev/null
+++ b/ext/ssytrd.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID ssytrd_(char* uplo, integer* n, real* a, integer* lda, real* d, real* e, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ssytrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ real *d;
+ VALUE rblapack_e;
+ real *e;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 d, e, tau, work, info, a = NumRu::Lapack.ssytrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRD reduces a real symmetric matrix A to real symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.ssytrd( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, real*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ ssytrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssytrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytrd", rblapack_ssytrd, -1);
+}
diff --git a/ext/ssytrf.c b/ext/ssytrf.c
new file mode 100644
index 0000000..72663e4
--- /dev/null
+++ b/ext/ssytrf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID ssytrf_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ssytrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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 ipiv, work, info, a = NumRu::Lapack.ssytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRF computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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 length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SLASYF, SSYTF2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.ssytrf( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ ssytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytrf", rblapack_ssytrf, -1);
+}
diff --git a/ext/ssytri.c b/ext/ssytri.c
new file mode 100644
index 0000000..4db7ea0
--- /dev/null
+++ b/ext/ssytri.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID ssytri_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssytri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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.ssytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRI computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* SSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.ssytri( uplo, a, ipiv, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, 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__;
+ work = ALLOC_N(real, (n));
+
+ ssytri_(&uplo, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytri", rblapack_ssytri, -1);
+}
diff --git a/ext/ssytri2.c b/ext/ssytri2.c
new file mode 100644
index 0000000..6275fd3
--- /dev/null
+++ b/ext/ssytri2.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID ssytri2_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ssytri2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_work_out__;
+ real *work_out__;
+ integer c__1;
+ integer c__m1;
+ integer nb;
+
+ 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, work = NumRu::Lapack.ssytri2( uplo, a, ipiv, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRI2 computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* SSYTRF. SSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling SSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SSYTRI2X\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, work = NumRu::Lapack.ssytri2( uplo, a, ipiv, work, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_work = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ c__1 = 1;
+ 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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ c__m1 = -1;
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (4th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (4th argument) must be %d", 1);
+ lwork = NA_SHAPE0(rblapack_work);
+ if (NA_TYPE(rblapack_work) != NA_SFLOAT)
+ rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ nb = ilaenv_(&c__1, "SSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
+ if (rblapack_lwork == Qnil)
+ lwork = (n+nb+1)*(nb+3);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ 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] = lwork;
+ rblapack_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work_out__ = NA_PTR_TYPE(rblapack_work_out__, real*);
+ MEMCPY(work_out__, work, real, NA_TOTAL(rblapack_work));
+ rblapack_work = rblapack_work_out__;
+ work = work_out__;
+
+ ssytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_work);
+}
+
+void
+init_lapack_ssytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytri2", rblapack_ssytri2, -1);
+}
diff --git a/ext/ssytri2x.c b/ext/ssytri2x.c
new file mode 100644
index 0000000..07b7f10
--- /dev/null
+++ b/ext/ssytri2x.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID ssytri2x_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* nb, integer* info);
+
+
+static VALUE
+rblapack_ssytri2x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ real *work;
+
+ 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.ssytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRI2X computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* SSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.ssytri2x( uplo, a, ipiv, nb, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_nb = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ nb = NUM2INT(rblapack_nb);
+ {
+ 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__;
+ work = ALLOC_N(real, (n+nb+1)*(nb+3));
+
+ ssytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ssytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytri2x", rblapack_ssytri2x, -1);
+}
diff --git a/ext/ssytrs.c b/ext/ssytrs.c
new file mode 100644
index 0000000..293ee14
--- /dev/null
+++ b/ext/ssytrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID ssytrs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ssytrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ssytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by SSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.ssytrs( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ 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_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);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ssytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ssytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytrs", rblapack_ssytrs, -1);
+}
diff --git a/ext/ssytrs2.c b/ext/ssytrs2.c
new file mode 100644
index 0000000..fb61c1c
--- /dev/null
+++ b/ext/ssytrs2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID ssytrs2_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, real* work, integer* info);
+
+
+static VALUE
+rblapack_ssytrs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ssytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRS2 solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by SSYTRF and converted by SSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 info, b = NumRu::Lapack.ssytrs2( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ 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_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);
+ 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (n));
+
+ ssytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ssytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ssytrs2", rblapack_ssytrs2, -1);
+}
diff --git a/ext/stbcon.c b/ext/stbcon.c
new file mode 100644
index 0000000..4c67082
--- /dev/null
+++ b/ext/stbcon.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID stbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, real* ab, integer* ldab, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_stbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ integer ldab;
+ 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.stbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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.stbcon( norm, uplo, diag, kd, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kd = NUM2INT(rblapack_kd);
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ stbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &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_stbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stbcon", rblapack_stbcon, -1);
+}
diff --git a/ext/stbrfs.c b/ext/stbrfs.c
new file mode 100644
index 0000000..b35328f
--- /dev/null
+++ b/ext/stbrfs.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID stbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_stbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ 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 ldab;
+ 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 = NumRu::Lapack.stbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by STBTRS or some other\n* means before entering this routine. STBRFS 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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.stbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ 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*);
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ stbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, 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_stbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stbrfs", rblapack_stbrfs, -1);
+}
diff --git a/ext/stbtrs.c b/ext/stbtrs.c
new file mode 100644
index 0000000..5486053
--- /dev/null
+++ b/ext/stbtrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID stbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_stbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ real *ab;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.stbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* STBTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by NRHS matrix. A check is made to verify that A is nonsingular.\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 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.stbtrs( uplo, trans, diag, kd, ab, b, [: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_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = 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_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, real*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ stbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_stbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stbtrs", rblapack_stbtrs, -1);
+}
diff --git a/ext/stfsm.c b/ext/stfsm.c
new file mode 100644
index 0000000..fc43b10
--- /dev/null
+++ b/ext/stfsm.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID stfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, real* alpha, real* a, real* b, integer* ldb);
+
+
+static VALUE
+rblapack_stfsm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ real alpha;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer nt;
+ integer ldb;
+ 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 b = NumRu::Lapack.stfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* STFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = A'.\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'T' or 't' op( A ) = A'.\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) REAL array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'T' then RFP is the transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) REAL array, DIMENSION (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.stfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_transr = argv[0];
+ rblapack_side = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_trans = argv[3];
+ rblapack_diag = argv[4];
+ rblapack_m = argv[5];
+ rblapack_alpha = argv[6];
+ rblapack_a = argv[7];
+ rblapack_b = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ alpha = (real)NUM2DBL(rblapack_alpha);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ ldb = MAX(1,m);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_b) != ldb)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be MAX(1,m)");
+ n = 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*);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (8th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
+ nt = NA_SHAPE0(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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ stfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_stfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stfsm", rblapack_stfsm, -1);
+}
diff --git a/ext/stftri.c b/ext/stftri.c
new file mode 100644
index 0000000..3172aab
--- /dev/null
+++ b/ext/stftri.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID stftri_(char* transr, char* uplo, char* diag, integer* n, real* a, integer* info);
+
+
+static VALUE
+rblapack_stftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_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, a = NumRu::Lapack.stftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* STFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\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* A (input/output) REAL array, dimension (NT);\n* NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n* Positive Definite matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.stftri( transr, uplo, diag, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, 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__;
+
+ stftri_(&transr, &uplo, &diag, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_stftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stftri", rblapack_stftri, -1);
+}
diff --git a/ext/stfttp.c b/ext/stfttp.c
new file mode 100644
index 0000000..704642e
--- /dev/null
+++ b/ext/stfttp.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID stfttp_(char* transr, char* uplo, integer* n, real* arf, real* ap, integer* info);
+
+
+static VALUE
+rblapack_stfttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_arf;
+ real *arf;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 ap, info = NumRu::Lapack.stfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* STFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) REAL array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) REAL array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.stfttp( transr, uplo, n, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_arf = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
+ rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
+ if (NA_TYPE(rblapack_arf) != NA_SFLOAT)
+ rblapack_arf = na_change_type(rblapack_arf, NA_SFLOAT);
+ arf = NA_PTR_TYPE(rblapack_arf, real*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_ap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, real*);
+
+ stfttp_(&transr, &uplo, &n, arf, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_stfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stfttp", rblapack_stfttp, -1);
+}
diff --git a/ext/stfttr.c b/ext/stfttr.c
new file mode 100644
index 0000000..f6d8cd7
--- /dev/null
+++ b/ext/stfttr.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID stfttr_(char* transr, char* uplo, integer* n, real* arf, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_stfttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_arf;
+ real *arf;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldarf;
+ 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 a, info = NumRu::Lapack.stfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrices ARF and A. N >= 0.\n*\n* ARF (input) REAL array, dimension (N*(N+1)/2).\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* matrix A in RFP format. See the \"Notes\" below for more\n* details.\n*\n* A (output) REAL array, dimension (LDA,N)\n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER N1, N2, K, NT, NX2, NP1X2\n INTEGER I, J, L, IJ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.stfttr( transr, uplo, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_arf = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
+ ldarf = NA_SHAPE0(rblapack_arf);
+ if (NA_TYPE(rblapack_arf) != NA_SFLOAT)
+ rblapack_arf = na_change_type(rblapack_arf, NA_SFLOAT);
+ arf = NA_PTR_TYPE(rblapack_arf, real*);
+ n = ((int)sqrtf(ldarf*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, real*);
+
+ stfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_stfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stfttr", rblapack_stfttr, -1);
+}
diff --git a/ext/stgevc.c b/ext/stgevc.c
new file mode 100644
index 0000000..97ec2e8
--- /dev/null
+++ b/ext/stgevc.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID stgevc_(char* side, char* howmny, logical* select, integer* n, real* s, integer* lds, real* p, integer* ldp, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* mm, integer* m, real* work, integer* info);
+
+
+static VALUE
+rblapack_stgevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_p;
+ real *p;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_vl_out__;
+ real *vl_out__;
+ VALUE rblapack_vr_out__;
+ real *vr_out__;
+ real *work;
+
+ integer n;
+ integer lds;
+ integer ldp;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, vl, vr = NumRu::Lapack.stgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* STGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of real matrices (S,P), where S is a quasi-triangular matrix\n* and P is upper triangular. Matrix pairs of this type are produced by\n* the generalized Schur factorization of a matrix pair (A,B):\n*\n* A = Q*S*Z**T, B = Q*P*Z**T\n*\n* as computed by SGGHRD + SHGEQZ.\n*\n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal blocks of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the orthogonal factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n* \n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. If w(j) is a real eigenvalue, the corresponding\n* real eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector\n* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n* set to .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) REAL array, dimension (LDS,N)\n* The upper quasi-triangular matrix S from a generalized Schur\n* factorization, as computed by SHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) REAL array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by SHGEQZ.\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n* of S must be in positive diagonal form.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) REAL array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of left Schur vectors returned by SHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n*\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) REAL array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Z (usually the orthogonal matrix Z\n* of right Schur vectors returned by SHGEQZ).\n*\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B' or 'b', the matrix Z*X;\n* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n* specified by SELECT, stored consecutively in the\n* columns of VR, in the same order as their\n* eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* \n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected real eigenvector occupies one\n* column and each selected complex eigenvector occupies two\n* columns.\n*\n* WORK (workspace) REAL array, dimension (6*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Allocation of workspace:\n* ---------- -- ---------\n*\n* WORK( j ) = 1-norm of j-th column of A, above the diagonal\n* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n* WORK( 2*N+1:3*N ) = real part of eigenvector\n* WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n*\n* Rowwise vs. columnwise solution methods:\n* ------- -- ---------- -------- -------\n*\n* Finding a generalized eigenvector consists basically of solving the\n* singular triangular system\n*\n* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)\n*\n* Consider finding the i-th right eigenvector (assume all eigenvalues\n* are real). The equation to be solved is:\n* n i\n* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1\n* k=j k=j\n*\n* where C = (A - w B) (The components v(i+1:n) are 0.)\n*\n* The \"rowwise\" method is:\n*\n* (1) v(i) := 1\n* for j = i-1,. . .,1:\n* i\n* (2) compute s = - sum C(j,k) v(k) and\n* k=j+1\n*\n* (3) v(j) := s / C(j,j)\n*\n* Step 2 is sometimes called the \"dot product\" step, since it is an\n* inner product between the j-th row and the portion of the eigenvector\n* that has been computed so far.\n*\n* The \"columnwise\" method consists basically in doing the sums\n* for all the rows in parallel. As each v(j) is computed, the\n* contribution of v(j) times the j-th column of C is added to the\n* partial sums. Since FORTRAN arrays are stored columnwise, this has\n* the advantage that at each step, the elements of C that are accessed\n* are adjacent to one another, whereas with the rowwise method, the\n* elements accessed at a step are spaced LDS (and LDP) words apart.\n*\n* When finding left eigenvectors, the matrix in question is the\n* transpose of the one in storage, so the rowwise method then\n* actually accesses columns of A and B at each step, and so is the\n* preferred method.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, info, vl, vr = NumRu::Lapack.stgevc( side, howmny, select, s, p, vl, vr, [: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_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_s = argv[3];
+ rblapack_p = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_p))
+ rb_raise(rb_eArgError, "p (5th argument) must be NArray");
+ if (NA_RANK(rblapack_p) != 2)
+ rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
+ ldp = NA_SHAPE0(rblapack_p);
+ if (NA_SHAPE1(rblapack_p) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_p) != NA_SFLOAT)
+ rblapack_p = na_change_type(rblapack_p, NA_SFLOAT);
+ p = NA_PTR_TYPE(rblapack_p, real*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ mm = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 2)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
+ lds = NA_SHAPE0(rblapack_s);
+ if (NA_SHAPE1(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_s) != NA_SFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
+ MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
+ MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(real, (6*n));
+
+ stgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
+
+ free(work);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_stgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stgevc", rblapack_stgevc, -1);
+}
diff --git a/ext/stgex2.c b/ext/stgex2.c
new file mode 100644
index 0000000..905de88
--- /dev/null
+++ b/ext/stgex2.c
@@ -0,0 +1,184 @@
+#include "rb_lapack.h"
+
+extern VOID stgex2_(logical* wantq, logical* wantz, integer* n, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* j1, integer* n1, integer* n2, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_stgex2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_j1;
+ integer j1;
+ VALUE rblapack_n1;
+ integer n1;
+ VALUE rblapack_n2;
+ integer n2;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldz;
+
+ 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, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n* (A, B) by an orthogonal equivalence transformation.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL arrays, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL arrays, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11). 1 <= J1 <= N.\n*\n* N1 (input) INTEGER\n* The order of the first block (A11, B11). N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block (A22, B22). N2 = 0, 1 or 2.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)).\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n*\n* INFO (output) INTEGER\n* =0: Successful exit\n* >0: If INFO = 1, the transformed matrix (A, B) would be\n* too far from generalized Schur form; the blocks are\n* not swapped and (A, B) and (Q, Z) are unchanged.\n* The problem of swapping is too ill-conditioned.\n* <0: If INFO = -16: LWORK is too small. Appropriate value\n* for LWORK is returned in WORK(1).\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* =====================================================================\n* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO\n* loops. Sven Hammarling, 1/5/02.\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_ldq = argv[5];
+ rblapack_z = argv[6];
+ rblapack_j1 = argv[7];
+ rblapack_n1 = argv[8];
+ rblapack_n2 = argv[9];
+ if (argc == 11) {
+ rblapack_lwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ n = 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_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldz)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ n1 = NUM2INT(rblapack_n1);
+ wantz = (rblapack_wantz == Qtrue);
+ ldq = NUM2INT(rblapack_ldq);
+ n2 = NUM2INT(rblapack_n2);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
+ j1 = NUM2INT(rblapack_j1);
+ {
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+ work = ALLOC_N(real, (lwork));
+
+ stgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &n1, &n2, work, &lwork, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_stgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stgex2", rblapack_stgex2, -1);
+}
diff --git a/ext/stgexc.c b/ext/stgexc.c
new file mode 100644
index 0000000..7296cd1
--- /dev/null
+++ b/ext/stgexc.c
@@ -0,0 +1,191 @@
+#include "rb_lapack.h"
+
+extern VOID stgexc_(logical* wantq, logical* wantz, integer* n, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* ifst, integer* ilst, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_stgexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldz;
+
+ 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 work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGEXC reorders the generalized real Schur decomposition of a real\n* matrix pair (A,B) using an orthogonal equivalence transformation\n*\n* (A, B) = Q * (A, B) * Z',\n*\n* so that the diagonal block of (A, B) with row index IFST is moved\n* to row ILST.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the matrix A in generalized real Schur canonical\n* form.\n* On exit, the updated matrix A, again in generalized\n* real Schur canonical form.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the matrix B in generalized real Schur canonical\n* form (A,B).\n* On exit, the updated matrix B, again in generalized\n* real Schur canonical form (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of\n* a 2-by-2 block, it is changed to point to the first row;\n* ILST always points to the first row of the block in its\n* final position (which may differ from its input value by\n* +1 or -1). 1 <= IFST, ILST <= N.\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.\n* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_ldq = argv[5];
+ rblapack_z = argv[6];
+ rblapack_ifst = argv[7];
+ rblapack_ilst = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ n = 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_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldz)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ ilst = NUM2INT(rblapack_ilst);
+ wantz = (rblapack_wantz == Qtrue);
+ ldq = NUM2INT(rblapack_ldq);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_SFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : 4*n+16;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ifst = NUM2INT(rblapack_ifst);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ stgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ rblapack_ifst = INT2NUM(ifst);
+ rblapack_ilst = INT2NUM(ilst);
+ return rb_ary_new3(8, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ifst, rblapack_ilst);
+}
+
+void
+init_lapack_stgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stgexc", rblapack_stgexc, -1);
+}
diff --git a/ext/stgsen.c b/ext/stgsen.c
new file mode 100644
index 0000000..80a95d1
--- /dev/null
+++ b/ext/stgsen.c
@@ -0,0 +1,252 @@
+#include "rb_lapack.h"
+
+extern VOID stgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* q, integer* ldq, real* z, integer* ldz, integer* m, real* pl, real* pr, real* dif, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_stgsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_z;
+ real *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_alphar;
+ real *alphar;
+ VALUE rblapack_alphai;
+ real *alphai;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_pl;
+ real pl;
+ VALUE rblapack_pr;
+ real pr;
+ VALUE rblapack_dif;
+ real *dif;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ VALUE rblapack_z_out__;
+ real *z_out__;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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 alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGSEN reorders the generalized real Schur decomposition of a real\n* matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the upper quasi-triangular\n* matrix A and the upper triangular B. The leading columns of Q and\n* Z form orthonormal bases of the corresponding left and right eigen-\n* spaces (deflating subspaces). (A, B) must be in generalized real\n* Schur canonical form (as returned by SGGES), i.e. A is block upper\n* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n* triangular.\n*\n* STGSEN also computes the generalized eigenvalues\n*\n* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, STGSEN computes the estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster.\n* To select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension(LDA,N)\n* On entry, the upper quasi-triangular matrix A, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real generalized Schur form of (A,B) were further reduced\n* to triangular form using complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* and if WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right eigen-\n* spaces (deflating subspaces). 0 <= M <= N.\n*\n* PL (output) REAL\n* PR (output) REAL\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspaces with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3, PL and PR are not referenced.\n*\n* DIF (output) REAL array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\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 >= 4*N+16.\n* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+6.\n* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n\n* Further Details\n* ===============\n*\n* STGSEN first collects the selected eigenvalues by computing\n* orthogonal U and W that move them to the top left corner of (A, B).\n* In other words, the selected eigenvalues are the eigenvalues of\n* (A11, B11) in:\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the transpose of U. The first n1 columns\n* of U and W span the specified pair of left and right eigenspaces\n* (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized real Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see SLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF\n* (IJOB = 2 will be used)). See STGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 8 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+ rblapack_ijob = argv[0];
+ rblapack_wantq = argv[1];
+ rblapack_wantz = argv[2];
+ rblapack_select = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 10) {
+ rblapack_lwork = argv[8];
+ rblapack_liwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = 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_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ wantq = (rblapack_wantq == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ 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_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_SFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, real*);
+ if (rblapack_liwork == Qnil)
+ liwork = (ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = (ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphar = NA_PTR_TYPE(rblapack_alphar, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alphai = NA_PTR_TYPE(rblapack_alphai, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, real*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
+ MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
+ rblapack_z = rblapack_z_out__;
+ z = z_out__;
+
+ stgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alphar, alphai, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_pl = rb_float_new((double)pl);
+ rblapack_pr = rb_float_new((double)pr);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(14, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_stgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stgsen", rblapack_stgsen, -1);
+}
diff --git a/ext/stgsja.c b/ext/stgsja.c
new file mode 100644
index 0000000..e47a105
--- /dev/null
+++ b/ext/stgsja.c
@@ -0,0 +1,227 @@
+#include "rb_lapack.h"
+
+extern VOID stgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, real* a, integer* lda, real* b, integer* ldb, real* tola, real* tolb, real* alpha, real* beta, real* u, integer* ldu, real* v, integer* ldv, real* q, integer* ldq, real* work, integer* ncycle, integer* info);
+
+
+static VALUE
+rblapack_stgsja(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_tola;
+ real tola;
+ VALUE rblapack_tolb;
+ real tolb;
+ VALUE rblapack_u;
+ real *u;
+ VALUE rblapack_v;
+ real *v;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_alpha;
+ real *alpha;
+ VALUE rblapack_beta;
+ real *beta;
+ VALUE rblapack_ncycle;
+ integer ncycle;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+ VALUE rblapack_u_out__;
+ real *u_out__;
+ VALUE rblapack_v_out__;
+ real *v_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.stgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* STGSJA computes the generalized singular value decomposition (GSVD)\n* of two real upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine SGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are orthogonal matrices, Z' denotes the transpose\n* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n* ``diagonal'' matrices, which are of the following structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the orthogonal transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain an orthogonal matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* orthogonal matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain an orthogonal matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* orthogonal matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by STGSJA.\n* See Further Details.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = max(M,N)*norm(A)*MACHEPS,\n* TOLB = max(P,N)*norm(B)*MACHEPS.\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0 and\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) REAL array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the orthogonal matrix returned by SGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the orthogonal matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) REAL array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the orthogonal matrix returned by SGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the orthogonal matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the orthogonal matrix returned by SGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the orthogonal matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n* of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.stgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_k = argv[3];
+ rblapack_l = argv[4];
+ rblapack_a = argv[5];
+ rblapack_b = argv[6];
+ rblapack_tola = argv[7];
+ rblapack_tolb = argv[8];
+ rblapack_u = argv[9];
+ rblapack_v = argv[10];
+ rblapack_q = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = 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*);
+ tolb = (real)NUM2DBL(rblapack_tolb);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ p = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_SFLOAT)
+ rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
+ v = NA_PTR_TYPE(rblapack_v, real*);
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th 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 1 of b");
+ 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_u))
+ rb_raise(rb_eArgError, "u (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ m = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_SFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, real*);
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (12th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ tola = (real)NUM2DBL(rblapack_tola);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, 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[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
+ MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ 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__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(real, (2*n));
+
+ stgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
+
+ free(work);
+ rblapack_ncycle = INT2NUM(ncycle);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
+}
+
+void
+init_lapack_stgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stgsja", rblapack_stgsja, -1);
+}
diff --git a/ext/stgsna.c b/ext/stgsna.c
new file mode 100644
index 0000000..fc8a540
--- /dev/null
+++ b/ext/stgsna.c
@@ -0,0 +1,164 @@
+#include "rb_lapack.h"
+
+extern VOID stgsna_(char* job, char* howmny, logical* select, integer* n, real* a, integer* lda, real* b, integer* ldb, real* vl, integer* ldvl, real* vr, integer* ldvr, real* s, real* dif, integer* mm, integer* m, real* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_stgsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_dif;
+ real *dif;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ integer *iwork;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+
+ 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 s, dif, m, work, info = NumRu::Lapack.stgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n* generalized real Schur canonical form (or of any matrix pair\n* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n* Z' denotes the transpose of Z.\n*\n* (A, B) must be in generalized real Schur form (as returned by SGGES),\n* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n* blocks. B is upper triangular.\n*\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The upper quasi-triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) REAL array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) REAL array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by STGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1.\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) REAL array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns ov VR, as returned by STGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1.\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), DIF(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of DIF are set to the same value. If\n* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected real\n* eigenvalue one element is used, and for each selected complex\n* conjugate pair of eigenvalues, two elements are used.\n* If HOWMNY = 'A', M is set to N.\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 >= max(1,N).\n* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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 (N + 6)\n* If JOB = 'E', IWORK is not referenced.\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* Further Details\n* ===============\n*\n* The reciprocal of the condition number of a generalized eigenvalue\n* w = (a, b) is defined as\n*\n* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the left and right eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u.\n* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n* of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number DIF(i) of right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows:\n*\n* a) If the i-th eigenvalue w = (a,b) is real\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1\n* ( 0 S22 ),( 0 T22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(i) is\n*\n* Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n*\n* where sigma-min(Zl) denotes the smallest singular value of the\n* 2(n-1)-by-2(n-1) matrix\n*\n* Zl = [ kron(a, In-1) -kron(1, S22) ]\n* [ kron(b, In-1) -kron(1, T22) ] .\n*\n* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n* Kronecker product between the matrices X and Y.\n*\n* Note that if the default method for computing DIF(i) is wanted\n* (see SLATDF), then the parameter DIFDRI (see below) should be\n* changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).\n* See STGSYL for more details.\n*\n* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2\n* ( 0 S22 ),( 0 T22) n-2\n* 2 n-2 2 n-2\n*\n* and (S11, T11) corresponds to the complex conjugate eigenvalue\n* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n* that\n*\n* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )\n* ( 0 s22 ) ( 0 t22 )\n*\n* where the generalized eigenvalues w = s11/t11 and\n* conjg(w) = s22/t22.\n*\n* Then the reciprocal condition number DIF(i) is bounded by\n*\n* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n*\n* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n* Z1 is the complex 2-by-2 matrix\n*\n* Z1 = [ s11 -s22 ]\n* [ t11 -t22 ],\n*\n* This is done by computing (using real arithmetic) the\n* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n* the determinant of X.\n*\n* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n*\n* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]\n* [ kron(T11', In-2) -kron(I2, T22) ]\n*\n* Note that if the default method for computing DIF is wanted (see\n* SLATDF), then the parameter DIFDRI (see below) should be changed\n* from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL\n* for more details.\n*\n* For each eigenvalue/vector specified by SELECT, DIF stores a\n* Frobenius norm-based estimate of Difl.\n*\n* An approximate error bound for the i-th computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.stgsna( job, howmny, select, a, b, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
+ 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_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ m = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ mm = 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 select");
+ if (NA_TYPE(rblapack_a) != NA_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n + 6));
+
+ stgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
+}
+
+void
+init_lapack_stgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stgsna", rblapack_stgsna, -1);
+}
diff --git a/ext/stgsy2.c b/ext/stgsy2.c
new file mode 100644
index 0000000..5b6cfc2
--- /dev/null
+++ b/ext/stgsy2.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID stgsy2_(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* rdsum, real* rdscal, integer* iwork, integer* pq, integer* info);
+
+
+static VALUE
+rblapack_stgsy2(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_rdsum;
+ real rdsum;
+ VALUE rblapack_rdscal;
+ real rdscal;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_pq;
+ integer pq;
+ 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, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.stgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n* Purpose\n* =======\n*\n* STGSY2 solves the generalized Sylvester equation:\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F,\n*\n* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n* must be in generalized Schur canonical form, i.e. A, B are upper\n* quasi triangular and D, E are upper triangular. The solution (R, L)\n* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n* chosen to avoid overflow.\n*\n* In matrix notation solving equation (1) corresponds to solve\n* Z*x = scale*b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n* In the process of solving (1), we solve a number of such systems\n* where Dim(In), Dim(In) = 1 or 2.\n*\n* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* sigma_min(Z) using reverse communicaton with SLACON.\n*\n* STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of the matrix pair in\n* STGSYL. See STGSYL for details.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* = 2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (SGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) REAL array, dimension (LDA, M)\n* On entry, A contains an upper quasi triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) REAL array, dimension (LDB, N)\n* On entry, B contains an upper quasi triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix 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).\n* On exit, if IJOB = 0, C has been overwritten by the\n* solution R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) REAL array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) REAL array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix 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).\n* On exit, if IJOB = 0, F has been overwritten by the\n* solution L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) REAL\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0. Normally,\n* SCALE = 1.\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by STGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when STGSY2 is called by\n* STGSYL.\n*\n* IWORK (workspace) INTEGER array, dimension (M+N+2)\n*\n* PQ (output) INTEGER\n* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n* 8-by-8) solved by this routine.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, the i-th argument had an illegal value.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n* Replaced various illegal calls to SCOPY by calls to SLASET.\n* Sven Hammarling, 27/5/02.\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.stgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", 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];
+ rblapack_rdsum = argv[8];
+ rblapack_rdscal = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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*);
+ rdsum = (real)NUM2DBL(rblapack_rdsum);
+ 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*);
+ rdscal = (real)NUM2DBL(rblapack_rdscal);
+ 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*);
+ {
+ int 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__;
+ {
+ int 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+2));
+
+ stgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, iwork, &pq, &info);
+
+ free(iwork);
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_pq = INT2NUM(pq);
+ rblapack_info = INT2NUM(info);
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(7, rblapack_scale, rblapack_pq, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_stgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stgsy2", rblapack_stgsy2, -1);
+}
diff --git a/ext/stgsyl.c b/ext/stgsyl.c
new file mode 100644
index 0000000..3267877
--- /dev/null
+++ b/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);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int 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__;
+ {
+ int 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);
+}
diff --git a/ext/stpcon.c b/ext/stpcon.c
new file mode 100644
index 0000000..5173213
--- /dev/null
+++ b/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);
+}
diff --git a/ext/stprfs.c b/ext/stprfs.c
new file mode 100644
index 0000000..e7232f5
--- /dev/null
+++ b/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*);
+ {
+ 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*);
+ 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);
+}
diff --git a/ext/stptri.c b/ext/stptri.c
new file mode 100644
index 0000000..b08f776
--- /dev/null
+++ b/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*);
+ {
+ int 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);
+}
diff --git a/ext/stptrs.c b/ext/stptrs.c
new file mode 100644
index 0000000..ecb5e9c
--- /dev/null
+++ b/ext/stptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID stptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_stptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.stptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* STPTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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 matrix B. 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*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.stptrs( uplo, trans, diag, n, ap, b, [: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_n = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_b = 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 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ n = NUM2INT(rblapack_n);
+ 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) != (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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ stptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_stptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stptrs", rblapack_stptrs, -1);
+}
diff --git a/ext/stpttf.c b/ext/stpttf.c
new file mode 100644
index 0000000..1d14142
--- /dev/null
+++ b/ext/stpttf.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID stpttf_(char* transr, char* uplo, integer* n, real* ap, real* arf, integer* info);
+
+
+static VALUE
+rblapack_stpttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_arf;
+ real *arf;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 arf, info = NumRu::Lapack.stpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* STPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'T': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower 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* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) REAL array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.stpttf( transr, uplo, 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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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);
+ 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*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_arf = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, real*);
+
+ stpttf_(&transr, &uplo, &n, ap, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_stpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stpttf", rblapack_stpttf, -1);
+}
diff --git a/ext/stpttr.c b/ext/stpttr.c
new file mode 100644
index 0000000..1eab861
--- /dev/null
+++ b/ext/stpttr.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID stpttr_(char* uplo, integer* n, real* ap, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_stpttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldap;
+ 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 a, info = NumRu::Lapack.stpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) REAL array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) REAL array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -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 a, info = NumRu::Lapack.stpttr( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_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;
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, real*);
+
+ stpttr_(&uplo, &n, ap, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_stpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stpttr", rblapack_stpttr, -1);
+}
diff --git a/ext/strcon.c b/ext/strcon.c
new file mode 100644
index 0000000..8ad8dad
--- /dev/null
+++ b/ext/strcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID strcon_(char* norm, char* uplo, char* diag, integer* n, real* a, integer* lda, real* rcond, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_strcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_rcond;
+ real rcond;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ 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 rcond, info = NumRu::Lapack.strcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRCON estimates the reciprocal of the condition number of a\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* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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.strcon( norm, uplo, diag, a, [: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_a = 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_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);
+ n = 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*);
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ strcon_(&norm, &uplo, &diag, &n, a, &lda, &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_strcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strcon", rblapack_strcon, -1);
+}
diff --git a/ext/strevc.c b/ext/strevc.c
new file mode 100644
index 0000000..61863a9
--- /dev/null
+++ b/ext/strevc.c
@@ -0,0 +1,150 @@
+#include "rb_lapack.h"
+
+extern VOID strevc_(char* side, char* howmny, logical* select, integer* n, real* t, integer* ldt, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* mm, integer* m, real* work, integer* info);
+
+
+static VALUE
+rblapack_strevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_select_out__;
+ logical *select_out__;
+ VALUE rblapack_vl_out__;
+ real *vl_out__;
+ VALUE rblapack_vr_out__;
+ real *vr_out__;
+ real *work;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, select, vl, vr = NumRu::Lapack.strevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* STREVC computes some or all of the right and/or left eigenvectors of\n* a real upper quasi-triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal blocks of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the orthogonal factor that reduces a matrix\n* A to Schur form T, then Q*X and Q*Y are the matrices of right and\n* left eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* If w(j) is a real eigenvalue, the corresponding real\n* eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector is\n* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n* .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) REAL array, dimension (LDT,N)\n* The upper quasi-triangular matrix T in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) REAL array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by SHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) REAL array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by SHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors.\n* If HOWMNY = 'A' or 'B', M is set to N.\n* Each selected real eigenvector occupies one column and each\n* selected complex eigenvector occupies two columns.\n*\n* WORK (workspace) REAL array, dimension (3*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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, info, select, vl, vr = NumRu::Lapack.strevc( side, howmny, select, t, vl, vr, [: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_side = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ mm = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
+ MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
+ rblapack_select = rblapack_select_out__;
+ select = select_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
+ MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
+ MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(real, (3*n));
+
+ strevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
+
+ free(work);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_select, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_strevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strevc", rblapack_strevc, -1);
+}
diff --git a/ext/strexc.c b/ext/strexc.c
new file mode 100644
index 0000000..9db2ba3
--- /dev/null
+++ b/ext/strexc.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID strexc_(char* compq, integer* n, real* t, integer* ldt, real* q, integer* ldq, integer* ifst, integer* ilst, real* work, integer* info);
+
+
+static VALUE
+rblapack_strexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ real *t_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ real *work;
+
+ integer ldt;
+ integer n;
+ integer ldq;
+
+ 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, t, q, ifst, ilst = NumRu::Lapack.strexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n* Purpose\n* =======\n*\n* STREXC reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n* moved to row ILST.\n*\n* The real Schur form T is reordered by an orthogonal similarity\n* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n* is updated by postmultiplying it with Z.\n*\n* T must be in Schur canonical form (as returned by SHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) REAL array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* Schur canonical form.\n* On exit, the reordered upper quasi-triangular matrix, again\n* in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of T.\n* The block with row index IFST is moved to row ILST, by a\n* sequence of transpositions between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of a\n* 2-by-2 block, it is changed to point to the first row; ILST\n* always points to the first row of the block in its final\n* position (which may differ from its input value by +1 or -1).\n* 1 <= IFST <= N; 1 <= ILST <= N.\n*\n* WORK (workspace) REAL 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* = 1: two adjacent blocks were too close to swap (the problem\n* is very ill-conditioned); T may have been partially\n* reordered, and ILST points to the first row of the\n* current position of the block being moved.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, t, q, ifst, ilst = NumRu::Lapack.strexc( compq, t, q, ifst, ilst, [: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_compq = argv[0];
+ rblapack_t = argv[1];
+ rblapack_q = argv[2];
+ rblapack_ifst = argv[3];
+ rblapack_ilst = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ ilst = NUM2INT(rblapack_ilst);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (2th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ ifst = NUM2INT(rblapack_ifst);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
+ MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(real, (n));
+
+ strexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ rblapack_ifst = INT2NUM(ifst);
+ rblapack_ilst = INT2NUM(ilst);
+ return rb_ary_new3(5, rblapack_info, rblapack_t, rblapack_q, rblapack_ifst, rblapack_ilst);
+}
+
+void
+init_lapack_strexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strexc", rblapack_strexc, -1);
+}
diff --git a/ext/strrfs.c b/ext/strrfs.c
new file mode 100644
index 0000000..139c3a2
--- /dev/null
+++ b/ext/strrfs.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID strrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_strrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ real *a;
+ 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 lda;
+ 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 = NumRu::Lapack.strrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by STRTRS or some other\n* means before entering this routine. STRRFS 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* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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.strrfs( uplo, trans, diag, a, 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_a = 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*);
+ 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_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);
+ n = 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*);
+ {
+ 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*);
+ work = ALLOC_N(real, (3*n));
+ iwork = ALLOC_N(integer, (n));
+
+ strrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, 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_strrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strrfs", rblapack_strrfs, -1);
+}
diff --git a/ext/strsen.c b/ext/strsen.c
new file mode 100644
index 0000000..78201e8
--- /dev/null
+++ b/ext/strsen.c
@@ -0,0 +1,169 @@
+#include "rb_lapack.h"
+
+extern VOID strsen_(char* job, char* compq, logical* select, integer* n, real* t, integer* ldt, real* q, integer* ldq, real* wr, real* wi, integer* m, real* s, real* sep, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_strsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_q;
+ real *q;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_wr;
+ real *wr;
+ VALUE rblapack_wi;
+ real *wi;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_s;
+ real s;
+ VALUE rblapack_sep;
+ real sep;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ real *t_out__;
+ VALUE rblapack_q_out__;
+ real *q_out__;
+ integer *iwork;
+
+ integer n;
+ integer ldt;
+ integer ldq;
+
+ 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 wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.strsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRSEN reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n* the leading diagonal blocks of the upper quasi-triangular matrix T,\n* and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n* T must be in Schur canonical form (as returned by SHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elemnts equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) REAL array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, T is overwritten by the reordered matrix T, again in\n* Schur canonical form, with the selected eigenvalues in the\n* leading diagonal blocks.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix which reorders T; the\n* leading M columns of Q form an orthonormal basis for the\n* specified invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* The real and imaginary parts, respectively, of the reordered\n* eigenvalues of T. The eigenvalues are stored in the same\n* order as on the diagonal of T, with WR(i) = T(i,i) and, if\n* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n* WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n* sufficiently ill-conditioned, then its value may differ\n* significantly from its value before reordering.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 < = M <= N.\n*\n* S (output) REAL\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) REAL\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\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.\n* If JOB = 'N', LWORK >= max(1,N);\n* if JOB = 'E', LWORK >= max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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 (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOB = 'N' or 'E', LIWORK >= 1;\n* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* = 1: reordering of T failed because some eigenvalues are too\n* close to separate (the problem is very ill-conditioned);\n* T may have been partially reordered, and WR and WI\n* contain the eigenvalues in the same order as in T; S and\n* SEP (if requested) are set to zero.\n*\n\n* Further Details\n* ===============\n*\n* STRSEN first collects the selected eigenvalues by computing an\n* orthogonal transformation Z to move them to the top left corner of T.\n* In other words, the selected eigenvalues are the eigenvalues of T11\n* in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n* of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the real Schur factorization of a matrix\n* A = Q*T*Q', then the reordered real Schur factorization of A is given\n* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n* the corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.strsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_q = argv[4];
+ rblapack_liwork = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_q) != NA_SFLOAT)
+ rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
+ q = NA_PTR_TYPE(rblapack_q, real*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ liwork = NUM2INT(rblapack_liwork);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wr = NA_PTR_TYPE(rblapack_wr, real*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ wi = NA_PTR_TYPE(rblapack_wi, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, real*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
+ MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
+ MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+
+ strsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, wr, wi, &m, &s, &sep, work, &lwork, iwork, &liwork, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_sep = rb_float_new((double)sep);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_wr, rblapack_wi, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_strsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strsen", rblapack_strsen, -1);
+}
diff --git a/ext/strsna.c b/ext/strsna.c
new file mode 100644
index 0000000..3cea230
--- /dev/null
+++ b/ext/strsna.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID strsna_(char* job, char* howmny, logical* select, integer* n, real* t, integer* ldt, real* vl, integer* ldvl, real* vr, integer* ldvr, real* s, real* sep, integer* mm, integer* m, real* work, integer* ldwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_strsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ real *t;
+ VALUE rblapack_vl;
+ real *vl;
+ VALUE rblapack_vr;
+ real *vr;
+ VALUE rblapack_s;
+ real *s;
+ VALUE rblapack_sep;
+ real *sep;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ real *work;
+ integer *iwork;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+ integer ldwork;
+
+ 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 s, sep, m, info = NumRu::Lapack.strsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a real upper\n* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n* orthogonal).\n*\n* T must be in Schur canonical form (as returned by SHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) REAL array, dimension (LDT,N)\n* The upper quasi-triangular matrix T, in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) REAL array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* SHSEIN or STREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) REAL array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* SHSEIN or STREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), SEP(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of SEP are set to the same value. If\n* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) REAL array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* IWORK (workspace) INTEGER array, dimension (2*(N-1))\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.strsna( job, howmny, select, t, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ m = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
+ rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
+ vl = NA_PTR_TYPE(rblapack_vl, real*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
+ rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
+ vr = NA_PTR_TYPE(rblapack_vr, real*);
+ mm = m;
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_SFLOAT)
+ rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
+ t = NA_PTR_TYPE(rblapack_t, real*);
+ ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, real*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ sep = NA_PTR_TYPE(rblapack_sep, real*);
+ work = ALLOC_N(real, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
+ iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : 2*(n-1)));
+
+ strsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
+}
+
+void
+init_lapack_strsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strsna", rblapack_strsna, -1);
+}
diff --git a/ext/strsyl.c b/ext/strsyl.c
new file mode 100644
index 0000000..0272295
--- /dev/null
+++ b/ext/strsyl.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID strsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb, real* c, integer* ldc, real* scale, integer* info);
+
+
+static VALUE
+rblapack_strsyl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trana;
+ char trana;
+ VALUE rblapack_tranb;
+ char tranb;
+ VALUE rblapack_isgn;
+ integer isgn;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_c;
+ real *c;
+ VALUE rblapack_scale;
+ real scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ real *c_out__;
+
+ 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 scale, info, c = NumRu::Lapack.strsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* STRSYL solves the real Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**T, and A and B are both upper quasi-\n* triangular. A is M-by-M and B is N-by-N; the right hand side C and\n* the solution X are M-by-N; and scale is an output scale factor, set\n* <= 1 to avoid overflow in X.\n*\n* A and B must be in Schur canonical form (as returned by SHSEQR), that\n* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n* each 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'T': op(A) = A**T (Transpose)\n* = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'T': op(B) = B**T (Transpose)\n* = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,M)\n* The upper quasi-triangular matrix A, in Schur canonical form.\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, in Schur canonical form.\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, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) REAL\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.strsyl( trana, tranb, isgn, a, b, c, [: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_trana = argv[0];
+ rblapack_tranb = argv[1];
+ rblapack_isgn = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trana = StringValueCStr(rblapack_trana)[0];
+ isgn = NUM2INT(rblapack_isgn);
+ 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);
+ n = 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*);
+ tranb = StringValueCStr(rblapack_tranb)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ if (NA_SHAPE1(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
+ 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_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);
+ 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*);
+ {
+ int 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__;
+
+ strsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_strsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strsyl", rblapack_strsyl, -1);
+}
diff --git a/ext/strti2.c b/ext/strti2.c
new file mode 100644
index 0000000..7dfdbe8
--- /dev/null
+++ b/ext/strti2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID strti2_(char* uplo, char* diag, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_strti2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.strti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STRTI2 computes the inverse of a real upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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.strti2( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ 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__;
+
+ strti2_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_strti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strti2", rblapack_strti2, -1);
+}
diff --git a/ext/strtri.c b/ext/strtri.c
new file mode 100644
index 0000000..b7e94a3
--- /dev/null
+++ b/ext/strtri.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID strtri_(char* uplo, char* diag, integer* n, real* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_strtri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *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.strtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STRTRI computes the inverse of a real upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.strtri( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = 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*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ 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__;
+
+ strtri_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_strtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strtri", rblapack_strtri, -1);
+}
diff --git a/ext/strtrs.c b/ext/strtrs.c
new file mode 100644
index 0000000..202f4da
--- /dev/null
+++ b/ext/strtrs.c
@@ -0,0 +1,99 @@
+#include "rb_lapack.h"
+
+extern VOID strtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_strtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_b;
+ real *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ real *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.strtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* STRTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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 matrix B. NRHS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.strtrs( uplo, trans, diag, a, b, [: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_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ n = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
+ MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ strtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_strtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strtrs", rblapack_strtrs, -1);
+}
diff --git a/ext/strttf.c b/ext/strttf.c
new file mode 100644
index 0000000..bc857d1
--- /dev/null
+++ b/ext/strttf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID strttf_(char* transr, char* uplo, integer* n, real* a, integer* lda, real* arf, integer* info);
+
+
+static VALUE
+rblapack_strttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_arf;
+ real *arf;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 arf, info = NumRu::Lapack.strttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* STRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal form is wanted;\n* = 'T': ARF in Transpose form is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N).\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) REAL array, dimension (NT).\n* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.strttf( transr, uplo, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[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);
+ n = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_arf = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, real*);
+
+ strttf_(&transr, &uplo, &n, a, &lda, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_strttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strttf", rblapack_strttf, -1);
+}
diff --git a/ext/strttp.c b/ext/strttp.c
new file mode 100644
index 0000000..3820244
--- /dev/null
+++ b/ext/strttp.c
@@ -0,0 +1,73 @@
+#include "rb_lapack.h"
+
+extern VOID strttp_(char* uplo, integer* n, real* a, integer* lda, real* ap, integer* info);
+
+
+static VALUE
+rblapack_strttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_ap;
+ real *ap;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 ap, info = NumRu::Lapack.strttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* STRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On exit, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) REAL array, dimension (N*(N+1)/2\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 ap, info = NumRu::Lapack.strttp( 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_SFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, real*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, real*);
+
+ strttp_(&uplo, &n, a, &lda, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_strttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "strttp", rblapack_strttp, -1);
+}
diff --git a/ext/stzrqf.c b/ext/stzrqf.c
new file mode 100644
index 0000000..411ffe0
--- /dev/null
+++ b/ext/stzrqf.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID stzrqf_(integer* m, integer* n, real* a, integer* lda, real* tau, integer* info);
+
+
+static VALUE
+rblapack_stzrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.stzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine STZRZF.\n*\n* STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.stzrqf( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = 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*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, 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__;
+
+ stzrqf_(&m, &n, a, &lda, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_stzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stzrqf", rblapack_stzrqf, -1);
+}
diff --git a/ext/stzrzf.c b/ext/stzrzf.c
new file mode 100644
index 0000000..80e5b6b
--- /dev/null
+++ b/ext/stzrzf.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID stzrzf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_stzrzf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ real *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ real *tau;
+ VALUE rblapack_work;
+ real *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ real *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.stzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.stzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 2)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 2) {
+ rblapack_lwork = argv[1];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = 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*);
+ m = lda;
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, real*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, 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__;
+
+ stzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_stzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "stzrzf", rblapack_stzrzf, -1);
+}
diff --git a/ext/xerbla.c b/ext/xerbla.c
new file mode 100644
index 0000000..684bcd6
--- /dev/null
+++ b/ext/xerbla.c
@@ -0,0 +1,52 @@
+#include "rb_lapack.h"
+
+extern VOID xerbla_(char* srname, integer* info);
+
+
+static VALUE
+rblapack_xerbla(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_srname;
+ char *srname;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 = NumRu::Lapack.xerbla( srname, info, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE XERBLA( SRNAME, INFO )\n\n* Purpose\n* =======\n*\n* XERBLA is an error handler for the LAPACK routines.\n* It is called by an LAPACK routine if an input parameter has an\n* invalid value. A message is printed and execution stops.\n*\n* Installers may consider modifying the STOP statement in order to\n* call system-specific exception-handling facilities.\n*\n\n* Arguments\n* =========\n*\n* SRNAME (input) CHARACTER*(*)\n* The name of the routine which called XERBLA.\n*\n* INFO (input) INTEGER\n* The position of the invalid parameter in the parameter list\n* of the calling routine.\n*\n\n* =====================================================================\n*\n* .. Intrinsic Functions ..\n INTRINSIC LEN_TRIM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n = NumRu::Lapack.xerbla( srname, info, [: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_srname = argv[0];
+ rblapack_info = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ srname = StringValueCStr(rblapack_srname);
+ info = NUM2INT(rblapack_info);
+
+ xerbla_(srname, &info);
+
+ return Qnil;
+}
+
+void
+init_lapack_xerbla(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "xerbla", rblapack_xerbla, -1);
+}
diff --git a/ext/xerbla_array.c b/ext/xerbla_array.c
new file mode 100644
index 0000000..5e8cbd1
--- /dev/null
+++ b/ext/xerbla_array.c
@@ -0,0 +1,53 @@
+#include "rb_lapack.h"
+
+extern VOID xerbla_array_(char* srname_array, integer* srname_len, integer* info);
+
+
+static VALUE
+rblapack_xerbla_array(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_srname_array;
+ char *srname_array;
+ VALUE rblapack_info;
+ integer info;
+
+ integer srname_len;
+
+ 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 = NumRu::Lapack.xerbla_array( srname_array, info, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO)\n\n* Purpose\n* =======\n*\n* XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK\n* and BLAS error handler. Rather than taking a Fortran string argument\n* as the function's name, XERBLA_ARRAY takes an array of single\n* characters along with the array's length. XERBLA_ARRAY then copies\n* up to 32 characters of that array into a Fortran string and passes\n* that to XERBLA. If called with a non-positive SRNAME_LEN,\n* XERBLA_ARRAY will call XERBLA with a string of all blank characters.\n*\n* Say some macro or other device makes XERBLA_ARRAY available to C99\n* by a name lapack_xerbla and with a common Fortran calling convention.\n* Then a C99 program could invoke XERBLA via:\n* {\n* int flen = strlen(__func__);\n* lapack_xerbla(__func__, &flen, &info);\n* }\n*\n* Providing XERBLA_ARRAY is not necessary for intercepting LAPACK\n* errors. XERBLA_ARRAY calls XERBLA.\n*\n\n* Arguments\n* =========\n*\n* SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN)\n* The name of the routine which called XERBLA_ARRAY.\n*\n* SRNAME_LEN (input) INTEGER\n* The length of the name in SRNAME_ARRAY.\n*\n* INFO (input) INTEGER\n* The position of the invalid parameter in the parameter list\n* of the calling routine.\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n INTEGER I\n* ..\n* .. Local Arrays ..\n CHARACTER*32 SRNAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN, LEN\n* ..\n* .. External Functions ..\n EXTERNAL XERBLA\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n = NumRu::Lapack.xerbla_array( srname_array, info, [: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_srname_array = argv[0];
+ rblapack_info = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ srname_array = StringValueCStr(rblapack_srname_array);
+ info = NUM2INT(rblapack_info);
+
+ xerbla_array_(srname_array, &srname_len, &info);
+
+ return Qnil;
+}
+
+void
+init_lapack_xerbla_array(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "xerbla_array", rblapack_xerbla_array, -1);
+}
diff --git a/ext/zbbcsd.c b/ext/zbbcsd.c
new file mode 100644
index 0000000..223a923
--- /dev/null
+++ b/ext/zbbcsd.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID zbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, doublereal* theta, doublereal* phi, doublecomplex* u1, integer* ldu1, doublecomplex* u2, integer* ldu2, doublecomplex* v1t, integer* ldv1t, doublecomplex* v2t, integer* ldv2t, doublereal* b11d, doublereal* b11e, doublereal* b12d, doublereal* b12e, doublereal* b21d, doublereal* b21e, doublereal* b22d, doublereal* b22e, doublereal* rwork, integer* lrwork, integer* info);
+
+
+static VALUE
+rblapack_zbbcsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_theta;
+ doublereal *theta;
+ VALUE rblapack_phi;
+ doublereal *phi;
+ VALUE rblapack_u1;
+ doublecomplex *u1;
+ VALUE rblapack_u2;
+ doublecomplex *u2;
+ VALUE rblapack_v1t;
+ doublecomplex *v1t;
+ VALUE rblapack_v2t;
+ doublecomplex *v2t;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_b11d;
+ doublereal *b11d;
+ VALUE rblapack_b11e;
+ doublereal *b11e;
+ VALUE rblapack_b12d;
+ doublereal *b12d;
+ VALUE rblapack_b12e;
+ doublereal *b12e;
+ VALUE rblapack_b21d;
+ doublereal *b21d;
+ VALUE rblapack_b21e;
+ doublereal *b21e;
+ VALUE rblapack_b22d;
+ doublereal *b22d;
+ VALUE rblapack_b22e;
+ doublereal *b22e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_theta_out__;
+ doublereal *theta_out__;
+ VALUE rblapack_u1_out__;
+ doublecomplex *u1_out__;
+ VALUE rblapack_u2_out__;
+ doublecomplex *u2_out__;
+ VALUE rblapack_v1t_out__;
+ doublecomplex *v1t_out__;
+ VALUE rblapack_v2t_out__;
+ doublecomplex *v2t_out__;
+ doublereal *rwork;
+
+ integer q;
+ integer ldu1;
+ integer p;
+ integer ldu2;
+ integer ldv1t;
+ integer ldv2t;
+
+ 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 b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZBBCSD computes the CS decomposition of a unitary matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See ZUNCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The unitary matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the unitary matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) DOUBLE PRECISION array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) COMPLEX*16 array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) COMPLEX*16 array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) COMPLEX*16 array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the conjugate transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) COMPLEX*16 array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the conjugate transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) DOUBLE PRECISION array, dimension (Q)\n* When ZBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If ZBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When ZBBCSD converges, B11E contains zeros. If ZBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) DOUBLE PRECISION array, dimension (Q)\n* When ZBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When ZBBCSD converges, B12E contains zeros. If ZBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the RWORK array,\n* returns this value as the first entry of the work array, and\n* no error message related to LRWORK 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* > 0: if ZBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :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_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_m = argv[5];
+ rblapack_theta = argv[6];
+ rblapack_phi = argv[7];
+ rblapack_u1 = argv[8];
+ rblapack_u2 = argv[9];
+ rblapack_v1t = argv[10];
+ rblapack_v2t = argv[11];
+ if (argc == 13) {
+ rblapack_lrwork = argv[12];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ } else {
+ rblapack_lrwork = Qnil;
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_theta))
+ rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
+ if (NA_RANK(rblapack_theta) != 1)
+ rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
+ q = NA_SHAPE0(rblapack_theta);
+ if (NA_TYPE(rblapack_theta) != NA_DFLOAT)
+ rblapack_theta = na_change_type(rblapack_theta, NA_DFLOAT);
+ theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
+ if (!NA_IsNArray(rblapack_u1))
+ rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_u1) != 2)
+ rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
+ ldu1 = NA_SHAPE0(rblapack_u1);
+ p = NA_SHAPE1(rblapack_u1);
+ if (NA_TYPE(rblapack_u1) != NA_DCOMPLEX)
+ rblapack_u1 = na_change_type(rblapack_u1, NA_DCOMPLEX);
+ u1 = NA_PTR_TYPE(rblapack_u1, doublecomplex*);
+ if (!NA_IsNArray(rblapack_v1t))
+ rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v1t) != 2)
+ rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
+ ldv1t = NA_SHAPE0(rblapack_v1t);
+ if (NA_SHAPE1(rblapack_v1t) != q)
+ rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
+ if (NA_TYPE(rblapack_v1t) != NA_DCOMPLEX)
+ rblapack_v1t = na_change_type(rblapack_v1t, NA_DCOMPLEX);
+ v1t = NA_PTR_TYPE(rblapack_v1t, doublecomplex*);
+ lrwork = MAX(1,8*q);
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_u2))
+ rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u2) != 2)
+ rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
+ ldu2 = NA_SHAPE0(rblapack_u2);
+ if (NA_SHAPE1(rblapack_u2) != (m-p))
+ rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
+ if (NA_TYPE(rblapack_u2) != NA_DCOMPLEX)
+ rblapack_u2 = na_change_type(rblapack_u2, NA_DCOMPLEX);
+ u2 = NA_PTR_TYPE(rblapack_u2, doublecomplex*);
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_v2t))
+ rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
+ if (NA_RANK(rblapack_v2t) != 2)
+ rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
+ ldv2t = NA_SHAPE0(rblapack_v2t);
+ if (NA_SHAPE1(rblapack_v2t) != (m-q))
+ rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
+ if (NA_TYPE(rblapack_v2t) != NA_DCOMPLEX)
+ rblapack_v2t = na_change_type(rblapack_v2t, NA_DCOMPLEX);
+ v2t = NA_PTR_TYPE(rblapack_v2t, doublecomplex*);
+ if (!NA_IsNArray(rblapack_phi))
+ rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
+ if (NA_RANK(rblapack_phi) != 1)
+ rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_phi) != (q-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
+ if (NA_TYPE(rblapack_phi) != NA_DFLOAT)
+ rblapack_phi = na_change_type(rblapack_phi, NA_DFLOAT);
+ phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b11d = NA_PTR_TYPE(rblapack_b11d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b11e = NA_PTR_TYPE(rblapack_b11e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b12d = NA_PTR_TYPE(rblapack_b12d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b12e = NA_PTR_TYPE(rblapack_b12e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b21d = NA_PTR_TYPE(rblapack_b21d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b21e = NA_PTR_TYPE(rblapack_b21e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b22d = NA_PTR_TYPE(rblapack_b22d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ b22e = NA_PTR_TYPE(rblapack_b22e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, doublereal*);
+ MEMCPY(theta_out__, theta, doublereal, NA_TOTAL(rblapack_theta));
+ rblapack_theta = rblapack_theta_out__;
+ theta = theta_out__;
+ {
+ int shape[2];
+ shape[0] = ldu1;
+ shape[1] = p;
+ rblapack_u1_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, doublecomplex*);
+ MEMCPY(u1_out__, u1, doublecomplex, NA_TOTAL(rblapack_u1));
+ rblapack_u1 = rblapack_u1_out__;
+ u1 = u1_out__;
+ {
+ int shape[2];
+ shape[0] = ldu2;
+ shape[1] = m-p;
+ rblapack_u2_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, doublecomplex*);
+ MEMCPY(u2_out__, u2, doublecomplex, NA_TOTAL(rblapack_u2));
+ rblapack_u2 = rblapack_u2_out__;
+ u2 = u2_out__;
+ {
+ int shape[2];
+ shape[0] = ldv1t;
+ shape[1] = q;
+ rblapack_v1t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, doublecomplex*);
+ MEMCPY(v1t_out__, v1t, doublecomplex, NA_TOTAL(rblapack_v1t));
+ rblapack_v1t = rblapack_v1t_out__;
+ v1t = v1t_out__;
+ {
+ int shape[2];
+ shape[0] = ldv2t;
+ shape[1] = m-q;
+ rblapack_v2t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, doublecomplex*);
+ MEMCPY(v2t_out__, v2t, doublecomplex, NA_TOTAL(rblapack_v2t));
+ rblapack_v2t = rblapack_v2t_out__;
+ v2t = v2t_out__;
+ rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
+
+ zbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, &lrwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
+}
+
+void
+init_lapack_zbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zbbcsd", rblapack_zbbcsd, -1);
+}
diff --git a/ext/zbdsqr.c b/ext/zbdsqr.c
new file mode 100644
index 0000000..838ce13
--- /dev/null
+++ b/ext/zbdsqr.c
@@ -0,0 +1,182 @@
+#include "rb_lapack.h"
+
+extern VOID zbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, doublereal* d, doublereal* e, doublecomplex* vt, integer* ldvt, doublecomplex* u, integer* ldu, doublecomplex* c, integer* ldc, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zbdsqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nru;
+ integer nru;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vt;
+ doublecomplex *vt;
+ VALUE rblapack_u;
+ doublecomplex *u;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_vt_out__;
+ doublecomplex *vt_out__;
+ VALUE rblapack_u_out__;
+ doublecomplex *u_out__;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublereal *rwork;
+
+ integer n;
+ integer ldvt;
+ integer ncvt;
+ integer ldu;
+ integer ldc;
+ integer ncc;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.zbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**H\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**H*VT instead of\n* P**H, for given complex input matrices U and VT. When U and VT are\n* the unitary matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by ZGEBRD, then\n* \n* A = (U*Q) * S * (P**H*VT)\n* \n* is the SVD of A. Optionally, the subroutine may also compute Q**H*C\n* for a given complex input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B.\n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**H * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) COMPLEX*16 array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**H * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.zbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_nru = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vt = argv[4];
+ rblapack_u = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
+ ldvt = NA_SHAPE0(rblapack_vt);
+ ncvt = NA_SHAPE1(rblapack_vt);
+ if (NA_TYPE(rblapack_vt) != NA_DCOMPLEX)
+ rblapack_vt = na_change_type(rblapack_vt, NA_DCOMPLEX);
+ vt = NA_PTR_TYPE(rblapack_vt, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ nru = NUM2INT(rblapack_nru);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (6th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ if (NA_SHAPE1(rblapack_u) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_u) != NA_DCOMPLEX)
+ rblapack_u = na_change_type(rblapack_u, NA_DCOMPLEX);
+ u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = ncvt;
+ rblapack_vt_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublecomplex*);
+ MEMCPY(vt_out__, vt, doublecomplex, NA_TOTAL(rblapack_vt));
+ rblapack_vt = rblapack_vt_out__;
+ vt = vt_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = n;
+ rblapack_u_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublecomplex*);
+ MEMCPY(u_out__, u, doublecomplex, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ rwork = ALLOC_N(doublereal, ((ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)));
+
+ zbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
+}
+
+void
+init_lapack_zbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zbdsqr", rblapack_zbdsqr, -1);
+}
diff --git a/ext/zcgesv.c b/ext/zcgesv.c
new file mode 100644
index 0000000..0886a80
--- /dev/null
+++ b/ext/zcgesv.c
@@ -0,0 +1,118 @@
+#include "rb_lapack.h"
+
+extern VOID zcgesv_(integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublecomplex* work, complex* swork, doublereal* rwork, integer* iter, integer* info);
+
+
+static VALUE
+rblapack_zcgesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_iter;
+ integer iter;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+ complex *swork;
+ doublereal *rwork;
+
+ integer lda;
+ 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 ipiv, x, iter, info, a = NumRu::Lapack.zcgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* ZCGESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* ZCGESV first attempts to factorize the matrix in COMPLEX and use this\n* factorization within an iterative refinement procedure to produce a\n* solution with COMPLEX*16 normwise backward error quality (see below).\n* If the approach fails the method switches to a COMPLEX*16\n* factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio COMPLEX performance over COMPLEX*16 performance is too\n* small. A reasonable strategy should take the number of right-hand\n* sides and the size of the matrix into account. This might be done\n* with a call to ILAENV in the future. Up to now, we always try\n* iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array,\n* dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n* Corresponds either to the single precision factorization\n* (if INFO.EQ.0 and ITER.GE.0) or the double precision\n* factorization (if INFO.EQ.0 and ITER.LT.0).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, COMPLEX*16\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of CGETRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, U(i,i) computed in COMPLEX*16 is exactly\n* zero. The factorization has been completed, but the\n* factor U is exactly singular, so the solution\n* could not be computed.\n*\n* =========\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, x, iter, info, a = NumRu::Lapack.zcgesv( 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldx = MAX(1,n);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n*nrhs));
+ swork = ALLOC_N(complex, (n*(n+nrhs)));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zcgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, x, &ldx, work, swork, rwork, &iter, &info);
+
+ free(work);
+ free(swork);
+ free(rwork);
+ rblapack_iter = INT2NUM(iter);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zcgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zcgesv", rblapack_zcgesv, -1);
+}
diff --git a/ext/zcposv.c b/ext/zcposv.c
new file mode 100644
index 0000000..dcfa853
--- /dev/null
+++ b/ext/zcposv.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID zcposv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublecomplex* work, complex* swork, doublereal* rwork, integer* iter, integer* info);
+
+
+static VALUE
+rblapack_zcposv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_iter;
+ integer iter;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+ complex *swork;
+ doublereal *rwork;
+
+ integer lda;
+ 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 x, iter, info, a = NumRu::Lapack.zcposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* ZCPOSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* ZCPOSV first attempts to factorize the matrix in COMPLEX and use this\n* factorization within an iterative refinement procedure to produce a\n* solution with COMPLEX*16 normwise backward error quality (see below).\n* If the approach fails the method switches to a COMPLEX*16\n* factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio COMPLEX performance over COMPLEX*16 performance is too\n* small. A reasonable strategy should take the number of right-hand\n* sides and the size of the matrix into account. This might be done\n* with a call to ILAENV in the future. Up to now, we always try\n* iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array,\n* dimension (LDA,N)\n* On entry, the Hermitian 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* Note that the imaginary parts of the diagonal\n* elements need not be set and are assumed to be zero.\n*\n* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, COMPLEX*16\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of CPOTRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, the leading minor of order i of\n* (COMPLEX*16) A is not positive definite, so the\n* factorization could not be completed, and the solution\n* has not been computed.\n*\n* =========\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iter, info, a = NumRu::Lapack.zcposv( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n*nrhs));
+ swork = ALLOC_N(complex, (n*(n+nrhs)));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zcposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, work, swork, rwork, &iter, &info);
+
+ free(work);
+ free(swork);
+ free(rwork);
+ rblapack_iter = INT2NUM(iter);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zcposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zcposv", rblapack_zcposv, -1);
+}
diff --git a/ext/zdrscl.c b/ext/zdrscl.c
new file mode 100644
index 0000000..f28972c
--- /dev/null
+++ b/ext/zdrscl.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID zdrscl_(integer* n, doublereal* sa, doublecomplex* sx, integer* incx);
+
+
+static VALUE
+rblapack_zdrscl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_sa;
+ doublereal sa;
+ VALUE rblapack_sx;
+ doublecomplex *sx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_sx_out__;
+ doublecomplex *sx_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 sx = NumRu::Lapack.zdrscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZDRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* ZDRSCL multiplies an n-element complex vector x by the real scalar\n* 1/a. This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) DOUBLE PRECISION\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) COMPLEX*16 array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sx = NumRu::Lapack.zdrscl( n, sa, sx, incx, [: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_n = argv[0];
+ rblapack_sa = argv[1];
+ rblapack_sx = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ sa = NUM2DBL(rblapack_sa);
+ if (!NA_IsNArray(rblapack_sx))
+ rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
+ if (NA_RANK(rblapack_sx) != 1)
+ rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
+ if (NA_TYPE(rblapack_sx) != NA_DCOMPLEX)
+ rblapack_sx = na_change_type(rblapack_sx, NA_DCOMPLEX);
+ sx = NA_PTR_TYPE(rblapack_sx, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*abs(incx);
+ rblapack_sx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, doublecomplex*);
+ MEMCPY(sx_out__, sx, doublecomplex, NA_TOTAL(rblapack_sx));
+ rblapack_sx = rblapack_sx_out__;
+ sx = sx_out__;
+
+ zdrscl_(&n, &sa, sx, &incx);
+
+ return rblapack_sx;
+}
+
+void
+init_lapack_zdrscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zdrscl", rblapack_zdrscl, -1);
+}
diff --git a/ext/zgbbrd.c b/ext/zgbbrd.c
new file mode 100644
index 0000000..f14752c
--- /dev/null
+++ b/ext/zgbbrd.c
@@ -0,0 +1,157 @@
+#include "rb_lapack.h"
+
+extern VOID zgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* d, doublereal* e, doublecomplex* q, integer* ldq, doublecomplex* pt, integer* ldpt, doublecomplex* c, integer* ldc, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgbbrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_pt;
+ doublecomplex *pt;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldc;
+ integer ncc;
+ integer ldq;
+ integer m;
+ integer ldpt;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.zgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBBRD reduces a complex general m-by-n band matrix A to real upper\n* bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) COMPLEX*16 array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(M,N))\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.zgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ ncc = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
+ m = ldab;
+ ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = m;
+ rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldpt;
+ shape[1] = n;
+ rblapack_pt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ pt = NA_PTR_TYPE(rblapack_pt, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = ncc;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (MAX(m,n)));
+ rwork = ALLOC_N(doublereal, (MAX(m,n)));
+
+ zgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
+}
+
+void
+init_lapack_zgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbbrd", rblapack_zgbbrd, -1);
+}
diff --git a/ext/zgbcon.c b/ext/zgbcon.c
new file mode 100644
index 0000000..b1cced2
--- /dev/null
+++ b/ext/zgbcon.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID zgbcon_(char* norm, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ 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.zgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBCON estimates the reciprocal of the condition number of a complex\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by ZGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zgbcon( norm, kl, ku, ab, ipiv, anorm, [: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_norm = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_anorm = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ anorm = NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbcon", rblapack_zgbcon, -1);
+}
diff --git a/ext/zgbequ.c b/ext/zgbequ.c
new file mode 100644
index 0000000..1ac077e
--- /dev/null
+++ b/ext/zgbequ.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID zgbequ_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zgbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequ( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,m);
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ zgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbequ", rblapack_zgbequ, -1);
+}
diff --git a/ext/zgbequb.c b/ext/zgbequb.c
new file mode 100644
index 0000000..2bfb902
--- /dev/null
+++ b/ext/zgbequb.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID zgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zgbequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from ZGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequb( kl, ku, ab, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ m = ldab;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ zgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbequb", rblapack_zgbequb, -1);
+}
diff --git a/ext/zgbrfs.c b/ext/zgbrfs.c
new file mode 100644
index 0000000..abe60f6
--- /dev/null
+++ b/ext/zgbrfs.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID zgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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.zgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbrfs", rblapack_zgbrfs, -1);
+}
diff --git a/ext/zgbrfsx.c b/ext/zgbrfsx.c
new file mode 100644
index 0000000..af9448b
--- /dev/null
+++ b/ext/zgbrfsx.c
@@ -0,0 +1,249 @@
+#include "rb_lapack.h"
+
+extern VOID zgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgbrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_afb;
+ doublereal *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_x_out__;
+ doublereal *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.zgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.zgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [: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_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_x = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ 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_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
+ afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
+ 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_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (8th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
+ MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
+ rblapack_x = rblapack_x_out__;
+ x = x_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_zgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbrfsx", rblapack_zgbrfsx, -1);
+}
diff --git a/ext/zgbsv.c b/ext/zgbsv.c
new file mode 100644
index 0000000..8a5f2ec
--- /dev/null
+++ b/ext/zgbsv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID zgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zgbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, ab, b = NumRu::Lapack.zgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGBSV computes the solution to a complex system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGBTRF, ZGBTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.zgbsv( kl, ku, ab, b, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ ku = NUM2INT(rblapack_ku);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_zgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbsv", rblapack_zgbsv, -1);
+}
diff --git a/ext/zgbsvx.c b/ext/zgbsvx.c
new file mode 100644
index 0000000..a32fd57
--- /dev/null
+++ b/ext/zgbsvx.c
@@ -0,0 +1,286 @@
+#include "rb_lapack.h"
+
+extern VOID zgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_afb_out__;
+ doublecomplex *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *work;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.zgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n* Moved setting of INFO = N+1 so INFO does not subsequently get\n* overwritten. Sven, 17 Mar 05. \n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.zgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 11) {
+ rblapack_afb = argv[6];
+ rblapack_ipiv = argv[7];
+ rblapack_equed = argv[8];
+ rblapack_r = argv[9];
+ rblapack_c = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_afb = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ku = NUM2INT(rblapack_ku);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ }
+ ldafb = 2*kl+ku+1;
+ if (rblapack_afb != Qnil) {
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (option) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_afb) != ldafb)
+ rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublecomplex*);
+ if (rblapack_afb != Qnil) {
+ MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rblapack_afb));
+ }
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_zgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbsvx", rblapack_zgbsvx, -1);
+}
diff --git a/ext/zgbsvxx.c b/ext/zgbsvxx.c
new file mode 100644
index 0000000..758cc8a
--- /dev/null
+++ b/ext/zgbsvxx.c
@@ -0,0 +1,289 @@
+#include "rb_lapack.h"
+
+extern VOID zgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgbsvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_afb_out__;
+ doublecomplex *afb_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.zgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBSVXX uses the LU factorization to compute the solution to a\n* complex*16 system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In DGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.zgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_equed = argv[7];
+ rblapack_r = argv[8];
+ rblapack_c = argv[9];
+ rblapack_b = argv[10];
+ rblapack_params = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th 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 1 of ab");
+ 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_r))
+ rb_raise(rb_eArgError, "r (9th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ n_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (10th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ ldx = MAX(1,n);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (12th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublecomplex*);
+ MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_zgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbsvxx", rblapack_zgbsvxx, -1);
+}
diff --git a/ext/zgbtf2.c b/ext/zgbtf2.c
new file mode 100644
index 0000000..d670c7f
--- /dev/null
+++ b/ext/zgbtf2.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID zgbtf2_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zgbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.zgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGBTF2 computes an LU factorization of a complex m-by-n band matrix\n* A using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.zgbtf2( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbtf2", rblapack_zgbtf2, -1);
+}
diff --git a/ext/zgbtrf.c b/ext/zgbtrf.c
new file mode 100644
index 0000000..c889168
--- /dev/null
+++ b/ext/zgbtrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID zgbtrf_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zgbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ 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 ipiv, info, ab = NumRu::Lapack.zgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGBTRF computes an LU factorization of a complex m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.zgbtrf( m, kl, ku, ab, [: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_m = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbtrf", rblapack_zgbtrf, -1);
+}
diff --git a/ext/zgbtrs.c b/ext/zgbtrs.c
new file mode 100644
index 0000000..ec75a0b
--- /dev/null
+++ b/ext/zgbtrs.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID zgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zgbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGBTRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general band matrix A using the LU factorization computed\n* by ZGBTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.zgbtrs( trans, kl, ku, ab, ipiv, b, [: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_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgbtrs", rblapack_zgbtrs, -1);
+}
diff --git a/ext/zgebak.c b/ext/zgebak.c
new file mode 100644
index 0000000..ad9db75
--- /dev/null
+++ b/ext/zgebak.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID zgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* scale, integer* m, doublecomplex* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_zgebak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ doublereal *scale;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ doublecomplex *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.zgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBAK forms the right or left eigenvectors of a complex general\n* matrix by backward transformation on the computed eigenvectors of the\n* balanced matrix output by ZGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to ZGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by ZGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by ZGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX*16 array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by ZHSEIN or ZTREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 info, v = NumRu::Lapack.zgebak( job, side, ilo, ihi, scale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_scale = argv[4];
+ rblapack_v = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_scale))
+ rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_scale) != 1)
+ rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_scale);
+ if (NA_TYPE(rblapack_scale) != NA_DFLOAT)
+ rblapack_scale = na_change_type(rblapack_scale, NA_DFLOAT);
+ scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
+ MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ zgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_zgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgebak", rblapack_zgebak, -1);
+}
diff --git a/ext/zgebal.c b/ext/zgebal.c
new file mode 100644
index 0000000..8b4e230
--- /dev/null
+++ b/ext/zgebal.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID zgebal_(char* job, integer* n, doublecomplex* a, integer* lda, integer* ilo, integer* ihi, doublereal* scale, integer* info);
+
+
+static VALUE
+rblapack_zgebal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ doublereal *scale;
+ VALUE rblapack_info;
+ integer info;
+ 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 ilo, ihi, scale, info, a = NumRu::Lapack.zgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBAL balances a general complex matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\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 input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine CBAL.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.zgebal( job, 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_job = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
+ {
+ int 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__;
+
+ zgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
+
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgebal", rblapack_zgebal, -1);
+}
diff --git a/ext/zgebd2.c b/ext/zgebd2.c
new file mode 100644
index 0000000..9c4ad19
--- /dev/null
+++ b/ext/zgebd2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID zgebd2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tauq, doublecomplex* taup, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgebd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tauq;
+ doublecomplex *tauq;
+ VALUE rblapack_taup;
+ doublecomplex *taup;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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 d, e, tauq, taup, info, a = NumRu::Lapack.zgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBD2 reduces a complex general m by n matrix A to upper or lower\n* real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX*16 array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, v and u are complex vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.zgebd2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (MAX(m,n)));
+
+ zgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgebd2", rblapack_zgebd2, -1);
+}
diff --git a/ext/zgebrd.c b/ext/zgebrd.c
new file mode 100644
index 0000000..7ff8a76
--- /dev/null
+++ b/ext/zgebrd.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID zgebrd_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tauq, doublecomplex* taup, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgebrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tauq;
+ doublecomplex *tauq;
+ VALUE rblapack_taup;
+ doublecomplex *taup;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 d, e, tauq, taup, work, info, a = NumRu::Lapack.zgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBRD reduces a general complex M-by-N matrix A to upper or lower\n* bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX*16 array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.zgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n)-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgebrd", rblapack_zgebrd, -1);
+}
diff --git a/ext/zgecon.c b/ext/zgecon.c
new file mode 100644
index 0000000..d4ecc0d
--- /dev/null
+++ b/ext/zgecon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID zgecon_(char* norm, integer* n, doublecomplex* a, integer* lda, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgecon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 rcond, info = NumRu::Lapack.zgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGECON estimates the reciprocal of the condition number of a general\n* complex matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by ZGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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.zgecon( norm, a, anorm, [: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_norm = argv[0];
+ rblapack_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ anorm = NUM2DBL(rblapack_anorm);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgecon", rblapack_zgecon, -1);
+}
diff --git a/ext/zgeequ.c b/ext/zgeequ.c
new file mode 100644
index 0000000..ade76a5
--- /dev/null
+++ b/ext/zgeequ.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID zgeequ_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zgeequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ zgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeequ", rblapack_zgeequ, -1);
+}
diff --git a/ext/zgeequb.c b/ext/zgeequb.c
new file mode 100644
index 0000000..1795e03
--- /dev/null
+++ b/ext/zgeequb.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID zgeequb_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zgeequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from ZGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+
+ zgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
+
+ rblapack_rowcnd = rb_float_new((double)rowcnd);
+ rblapack_colcnd = rb_float_new((double)colcnd);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeequb", rblapack_zgeequb, -1);
+}
diff --git a/ext/zgees.c b/ext/zgees.c
new file mode 100644
index 0000000..ab1b18c
--- /dev/null
+++ b/ext/zgees.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(doublecomplex *arg0){
+ VALUE rblapack_arg0;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+
+ rblapack_ret = rb_yield_values(1, rblapack_arg0);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID zgees_(char* jobvs, char* sort, L_fp select, integer* n, doublecomplex* a, integer* lda, integer* sdim, doublecomplex* w, doublecomplex* vs, integer* ldvs, doublecomplex* work, integer* lwork, doublereal* rwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_zgees(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_vs;
+ doublecomplex *vs;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, w, vs, work, info, a = NumRu::Lapack.zgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEES computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n*\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered:\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* IF SORT = 'N', SELECT is not referenced.\n* The eigenvalue W(j) is selected if SELECT(W(j)) is true.\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 N-by-N matrix A.\n* On exit, A has been overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues, in the same order that\n* they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX*16 array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged;\n* if JOBVS = 'V', VS contains the matrix which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because\n* some eigenvalues were too close to separate (the\n* problem is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Schur form no longer satisfy\n* SELECT = .TRUE.. This could also be caused by\n* underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, w, vs, work, info, a = NumRu::Lapack.zgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ rwork = ALLOC_N(doublereal, (n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ zgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, w, vs, &ldvs, work, &lwork, rwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgees", rblapack_zgees, -1);
+}
diff --git a/ext/zgeesx.c b/ext/zgeesx.c
new file mode 100644
index 0000000..cc70165
--- /dev/null
+++ b/ext/zgeesx.c
@@ -0,0 +1,152 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_select(doublecomplex *arg0){
+ VALUE rblapack_arg0;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+
+ rblapack_ret = rb_yield_values(1, rblapack_arg0);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID zgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, doublecomplex* a, integer* lda, integer* sdim, doublecomplex* w, doublecomplex* vs, integer* ldvs, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_zgeesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvs;
+ char jobvs;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_vs;
+ doublecomplex *vs;
+ VALUE rblapack_rconde;
+ doublereal rconde;
+ VALUE rblapack_rcondv;
+ doublereal rcondv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldvs;
+
+ 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 sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.zgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\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 N-by-N matrix A.\n* On exit, A is overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues, in the same order\n* that they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX*16 array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) DOUBLE PRECISION\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n* where SDIM is the number of selected eigenvalues computed by\n* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n* that an error is only returned if LWORK < max(1,2*N), but if\n* SENSE = 'E' or 'V' or 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bound on the optimal size of the\n* array WORK, returns this value as the first entry of the WORK\n* array, and no error message related to LWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.zgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvs = argv[0];
+ rblapack_sort = argv[1];
+ rblapack_sense = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvs = StringValueCStr(rblapack_jobvs)[0];
+ sense = StringValueCStr(rblapack_sense)[0];
+ sort = StringValueCStr(rblapack_sort)[0];
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldvs = lsame_(&jobvs,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n/2 : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvs;
+ shape[1] = n;
+ rblapack_vs = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vs = NA_PTR_TYPE(rblapack_vs, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ rwork = ALLOC_N(doublereal, (n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ zgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, w, vs, &ldvs, &rconde, &rcondv, work, &lwork, rwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_rconde = rb_float_new((double)rconde);
+ rblapack_rcondv = rb_float_new((double)rcondv);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeesx", rblapack_zgeesx, -1);
+}
diff --git a/ext/zgeev.c b/ext/zgeev.c
new file mode 100644
index 0000000..60454c4
--- /dev/null
+++ b/ext/zgeev.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID zgeev_(char* jobvl, char* jobvr, integer* n, doublecomplex* a, integer* lda, doublecomplex* w, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgeev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 w, vl, vr, work, info, a = NumRu::Lapack.zgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\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 N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements and i+1:N of W contain eigenvalues which have\n* converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, vl, vr, work, info, a = NumRu::Lapack.zgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgeev_(&jobvl, &jobvr, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeev", rblapack_zgeev, -1);
+}
diff --git a/ext/zgeevx.c b/ext/zgeevx.c
new file mode 100644
index 0000000..cc27619
--- /dev/null
+++ b/ext/zgeevx.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID zgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublecomplex* a, integer* lda, doublecomplex* w, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* scale, doublereal* abnrm, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgeevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_scale;
+ doublereal *scale;
+ VALUE rblapack_abnrm;
+ doublereal abnrm;
+ VALUE rblapack_rconde;
+ doublereal *rconde;
+ VALUE rblapack_rcondv;
+ doublereal *rcondv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldvl;
+ integer ldvr;
+
+ 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 w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.zgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, ie. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\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 N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the Schur form of the balanced\n* version of the matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and\n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\n*\n* WORK (workspace/output) COMPLEX*16 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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n* LWORK >= N*N+2*N.\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of W\n* contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.zgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n+2*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_w, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeevx", rblapack_zgeevx, -1);
+}
diff --git a/ext/zgegs.c b/ext/zgegs.c
new file mode 100644
index 0000000..189ebe5
--- /dev/null
+++ b/ext/zgegs.c
@@ -0,0 +1,166 @@
+#include "rb_lapack.h"
+
+extern VOID zgegs_(char* jobvsl, char* jobvsr, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vsl, integer* ldvsl, doublecomplex* vsr, integer* ldvsr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgegs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_vsl;
+ doublecomplex *vsl;
+ VALUE rblapack_vsr;
+ doublecomplex *vsr;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGGES.\n*\n* ZGEGS computes the eigenvalues, Schur form, and, optionally, the\n* left and or/right Schur vectors of a complex matrix pair (A,B).\n* Given two square matrices A and B, the generalized Schur\n* factorization has the form\n* \n* A = Q*S*Z**H, B = Q*T*Z**H\n* \n* where Q and Z are unitary matrices and S and T are upper triangular.\n* The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n* \n* If only the eigenvalues of (A,B) are needed, the driver routine\n* ZGEGV should be used instead. See ZGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper triangular matrix S from the generalized\n* Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur\n* form of A.\n*\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The non-negative real scalars beta that define the\n* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element\n* of the triangular factor T.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n*\n* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;\n* the optimal LWORK is N*(NB+1).\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* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from ZGGBAL\n* =N+2: error return from ZGEQRF\n* =N+3: error return from ZUNMQR\n* =N+4: error return from ZUNGQR\n* =N+5: error return from ZGGHRD\n* =N+6: error return from ZHGEQZ (other than failed\n* iteration)\n* =N+7: error return from ZGGBAK (computing VSL)\n* =N+8: error return from ZGGBAK (computing VSR)\n* =N+9: error return from ZLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (3*n));
+
+ zgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgegs", rblapack_zgegs, -1);
+}
diff --git a/ext/zgegv.c b/ext/zgegv.c
new file mode 100644
index 0000000..aa50836
--- /dev/null
+++ b/ext/zgegv.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID zgegv_(char* jobvl, char* jobvr, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgegv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGGEV.\n*\n* ZGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a complex matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n*\n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing. If no\n* eigenvectors were computed, then only the diagonal elements\n* of the Schur form will be correct. See ZGGHRD and ZHGEQZ\n* for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* elements of B will be correct. See ZGGHRD and ZHGEQZ for\n* details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP.\n*\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR;\n* The optimal LWORK is MAX( 2*N, N*(NB+1) ).\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* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from ZGGBAL\n* =N+2: error return from ZGEQRF\n* =N+3: error return from ZUNMQR\n* =N+4: error return from ZUNGQR\n* =N+5: error return from ZGGHRD\n* =N+6: error return from ZHGEQZ (other than failed\n* iteration)\n* =N+7: error return from ZTGEVC\n* =N+8: error return from ZGGBAK (computing VL)\n* =N+9: error return from ZGGBAK (computing VR)\n* =N+10: error return from ZLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls ZGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, ZGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the complex Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] In other words, upper triangular form.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 8*n;
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgegv", rblapack_zgegv, -1);
+}
diff --git a/ext/zgehd2.c b/ext/zgehd2.c
new file mode 100644
index 0000000..73cfc55
--- /dev/null
+++ b/ext/zgehd2.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID zgehd2_(integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgehd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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 tau, info, a = NumRu::Lapack.zgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n* by a unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to ZGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgehd2( ilo, ihi, a, [: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_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgehd2", rblapack_zgehd2, -1);
+}
diff --git a/ext/zgehrd.c b/ext/zgehrd.c
new file mode 100644
index 0000000..bd07ce7
--- /dev/null
+++ b/ext/zgehrd.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zgehrd_(integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgehrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 tau, work, info, a = NumRu::Lapack.zgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n* an unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to ZGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgehrd", rblapack_zgehrd, -1);
+}
diff --git a/ext/zgelq2.c b/ext/zgelq2.c
new file mode 100644
index 0000000..49d6233
--- /dev/null
+++ b/ext/zgelq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID zgelq2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgelq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELQ2 computes an LQ factorization of a complex m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgelq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (m));
+
+ zgelq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgelq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgelq2", rblapack_zgelq2, -1);
+}
diff --git a/ext/zgelqf.c b/ext/zgelqf.c
new file mode 100644
index 0000000..6ba75ba
--- /dev/null
+++ b/ext/zgelqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zgelqf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgelqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 tau, work, info, a = NumRu::Lapack.zgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELQF computes an LQ factorization of a complex M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgelqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgelqf", rblapack_zgelqf, -1);
+}
diff --git a/ext/zgels.c b/ext/zgels.c
new file mode 100644
index 0000000..e609d3c
--- /dev/null
+++ b/ext/zgels.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID zgels_(char* trans, integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgels(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 work, info, a, b = NumRu::Lapack.zgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELS solves overdetermined or underdetermined complex linear systems\n* involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n* or LQ factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided:\n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of\n* an undetermined system A**H * X = B.\n*\n* 4. If TRANS = 'C' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**H * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'C': the linear system involves A**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by ZGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by ZGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'C'.\n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of the\n* modulus of elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of the modulus of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.zgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } 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 (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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = 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*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(4, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zgels(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgels", rblapack_zgels, -1);
+}
diff --git a/ext/zgelsd.c b/ext/zgelsd.c
new file mode 100644
index 0000000..128b6c5
--- /dev/null
+++ b/ext/zgelsd.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID zgelsd_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zgelsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+ integer c__9;
+ integer c__0;
+ integer liwork;
+ integer lrwork;
+ integer nlvl;
+ integer smlsiz;
+
+ 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 s, rank, work, info, b = NumRu::Lapack.zgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder tranformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX*16 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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 2*N + N*NRHS\n* if M is greater than or equal to N or\n* 2*M + M*NRHS\n* if M is less than N, the code will execute correctly.\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the array WORK and the\n* minimum sizes of the arrays RWORK and IWORK, and returns\n* these values as the first entries of the WORK, RWORK and\n* IWORK arrays, and no error message related to LWORK is issued\n* by XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* LRWORK >=\n* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is greater than or equal to N or\n* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, b = NumRu::Lapack.zgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ rcond = NUM2DBL(rblapack_rcond);
+ m = lda;
+ c__9 = 9;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = 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*);
+ ldb = MAX(m,n);
+ if (rblapack_lwork == Qnil)
+ lwork = m>=n ? 2*n+n*nrhs : 2*m+m*nrhs;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ c__0 = 0;
+ smlsiz = ilaenv_(&c__9,"ZGELSD"," ",&c__0,&c__0,&c__0,&c__0);
+ nlvl = MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)));
+ liwork = MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)));
+ lrwork = m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
+ iwork = ALLOC_N(integer, (MAX(1,liwork)));
+
+ zgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, iwork, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgelsd", rblapack_zgelsd, -1);
+}
diff --git a/ext/zgelss.c b/ext/zgelss.c
new file mode 100644
index 0000000..0282e0b
--- /dev/null
+++ b/ext/zgelss.c
@@ -0,0 +1,151 @@
+#include "rb_lapack.h"
+
+extern VOID zgelss_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgelss(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 s, rank, work, info, a, b = NumRu::Lapack.zgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELSS computes the minimum norm solution to a complex linear\n* least squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX*16 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, and also:\n* LWORK >= 2*min(M,N) + max(M,N,NRHS)\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.zgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_rcond = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ rcond = NUM2DBL(rblapack_rcond);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = 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*);
+ ldb = MAX(m, n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (5*MIN(m,n)));
+
+ zgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgelss", rblapack_zgelss, -1);
+}
diff --git a/ext/zgelsx.c b/ext/zgelsx.c
new file mode 100644
index 0000000..269c493
--- /dev/null
+++ b/ext/zgelsx.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID zgelsx_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgelsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 rank, info, a, b, jpvt = NumRu::Lapack.zgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGELSY.\n*\n* ZGELSX computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 rank, info, a, b, jpvt = NumRu::Lapack.zgelsx( m, a, b, jpvt, rcond, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_rcond = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ rcond = NUM2DBL(rblapack_rcond);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(doublecomplex, (MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_zgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgelsx", rblapack_zgelsx, -1);
+}
diff --git a/ext/zgelsy.c b/ext/zgelsy.c
new file mode 100644
index 0000000..93b6a79
--- /dev/null
+++ b/ext/zgelsy.c
@@ -0,0 +1,166 @@
+#include "rb_lapack.h"
+
+extern VOID zgelsy_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgelsy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer m;
+ integer nrhs;
+ integer ldb;
+
+ 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 rank, work, info, a, b, jpvt = NumRu::Lapack.zgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELSY computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* The unblocked strategy requires that:\n* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n* where MN = min(M,N).\n* The block algorithm requires that:\n* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,\n* and ZUNMRZ.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.zgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_jpvt = argv[2];
+ rblapack_rcond = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ m = lda;
+ 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);
+ if (NA_SHAPE0(rblapack_b) != m)
+ rb_raise(rb_eRuntimeError, "shape 0 of b must be lda");
+ nrhs = 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ rcond = NUM2DBL(rblapack_rcond);
+ ldb = MAX(m,n);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = MAX(m, n);
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = m < n ? rb_range_new(rblapack_ZERO, INT2NUM(m), Qtrue) : Qtrue;
+ __shape__[1] = Qtrue;
+ __shape__[2] = rblapack_b;
+ na_aset(3, __shape__, rblapack_b_out__);
+ }
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = m < n ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue);
+ __shape__[1] = Qtrue;
+ rblapack_b = na_aref(2, __shape__, rblapack_b);
+ }
+ return rb_ary_new3(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
+}
+
+void
+init_lapack_zgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgelsy", rblapack_zgelsy, -1);
+}
diff --git a/ext/zgeql2.c b/ext/zgeql2.c
new file mode 100644
index 0000000..0022d4c
--- /dev/null
+++ b/ext/zgeql2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID zgeql2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgeql2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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 tau, info, a = NumRu::Lapack.zgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQL2 computes a QL factorization of a complex m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgeql2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zgeql2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeql2", rblapack_zgeql2, -1);
+}
diff --git a/ext/zgeqlf.c b/ext/zgeqlf.c
new file mode 100644
index 0000000..6108fce
--- /dev/null
+++ b/ext/zgeqlf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zgeqlf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgeqlf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 tau, work, info, a = NumRu::Lapack.zgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQLF computes a QL factorization of a complex M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQL2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeqlf", rblapack_zgeqlf, -1);
+}
diff --git a/ext/zgeqp3.c b/ext/zgeqp3.c
new file mode 100644
index 0000000..476dc62
--- /dev/null
+++ b/ext/zgeqp3.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID zgeqp3_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgeqp3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ doublereal *rwork;
+
+ 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 tau, work, info, a, jpvt = NumRu::Lapack.zgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* unitary matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= N+1.\n* For optimal performance LWORK >= ( N+1 )*NB, where NB\n* is the optimal blocksize.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.zgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n+1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_zgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeqp3", rblapack_zgeqp3, -1);
+}
diff --git a/ext/zgeqpf.c b/ext/zgeqpf.c
new file mode 100644
index 0000000..9ff399c
--- /dev/null
+++ b/ext/zgeqpf.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID zgeqpf_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgeqpf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 tau, info, a, jpvt = NumRu::Lapack.zgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGEQP3.\n*\n* ZGEQPF computes a QR factorization with column pivoting of a\n* complex M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the unitary matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.zgeqpf( m, a, jpvt, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_jpvt = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_jpvt);
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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 jpvt");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgeqpf_(&m, &n, a, &lda, jpvt, tau, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
+}
+
+void
+init_lapack_zgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeqpf", rblapack_zgeqpf, -1);
+}
diff --git a/ext/zgeqr2.c b/ext/zgeqr2.c
new file mode 100644
index 0000000..0c32ffe
--- /dev/null
+++ b/ext/zgeqr2.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID zgeqr2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgeqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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 tau, info, a = NumRu::Lapack.zgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQR2 computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgeqr2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zgeqr2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeqr2", rblapack_zgeqr2, -1);
+}
diff --git a/ext/zgeqr2p.c b/ext/zgeqr2p.c
new file mode 100644
index 0000000..7027522
--- /dev/null
+++ b/ext/zgeqr2p.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID zgeqr2p_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgeqr2p(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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 tau, info, a = NumRu::Lapack.zgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQR2P computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgeqr2p( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zgeqr2p_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeqr2p", rblapack_zgeqr2p, -1);
+}
diff --git a/ext/zgeqrf.c b/ext/zgeqrf.c
new file mode 100644
index 0000000..887fa56
--- /dev/null
+++ b/ext/zgeqrf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zgeqrf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgeqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 tau, work, info, a = NumRu::Lapack.zgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQRF computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeqrf", rblapack_zgeqrf, -1);
+}
diff --git a/ext/zgeqrfp.c b/ext/zgeqrfp.c
new file mode 100644
index 0000000..a163be3
--- /dev/null
+++ b/ext/zgeqrfp.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zgeqrfp_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgeqrfp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 tau, work, info, a = NumRu::Lapack.zgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQR2P, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgeqrfp", rblapack_zgeqrfp, -1);
+}
diff --git a/ext/zgerfs.c b/ext/zgerfs.c
new file mode 100644
index 0000000..7ffd383
--- /dev/null
+++ b/ext/zgerfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID zgerfs_(char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgerfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.zgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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)\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGETRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zgerfs( trans, a, af, ipiv, 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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgerfs", rblapack_zgerfs, -1);
+}
diff --git a/ext/zgerfsx.c b/ext/zgerfsx.c
new file mode 100644
index 0000000..28b4cdd
--- /dev/null
+++ b/ext/zgerfsx.c
@@ -0,0 +1,219 @@
+#include "rb_lapack.h"
+
+extern VOID zgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgerfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.zgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed.\n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.zgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_r = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_x = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (6th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_zgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgerfsx", rblapack_zgerfsx, -1);
+}
diff --git a/ext/zgerq2.c b/ext/zgerq2.c
new file mode 100644
index 0000000..b35dcaf
--- /dev/null
+++ b/ext/zgerq2.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID zgerq2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgerq2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERQ2 computes an RQ factorization of a complex m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the unitary matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgerq2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (m));
+
+ zgerq2_(&m, &n, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgerq2", rblapack_zgerq2, -1);
+}
diff --git a/ext/zgerqf.c b/ext/zgerqf.c
new file mode 100644
index 0000000..5998497
--- /dev/null
+++ b/ext/zgerqf.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zgerqf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgerqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 tau, work, info, a = NumRu::Lapack.zgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERQF computes an RQ factorization of a complex M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGERQ2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgerqf", rblapack_zgerqf, -1);
+}
diff --git a/ext/zgesc2.c b/ext/zgesc2.c
new file mode 100644
index 0000000..8fff3fd
--- /dev/null
+++ b/ext/zgesc2.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID zgesc2_(integer* n, doublecomplex* a, integer* lda, doublecomplex* rhs, integer* ipiv, integer* jpiv, doublereal* scale);
+
+
+static VALUE
+rblapack_zgesc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_rhs;
+ doublecomplex *rhs;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_rhs_out__;
+ doublecomplex *rhs_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 scale, rhs = NumRu::Lapack.zgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* ZGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by ZGETC2.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by ZGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) COMPLEX*16 array, dimension N.\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.zgesc2( a, rhs, ipiv, jpiv, [: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_a = argv[0];
+ rblapack_rhs = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_jpiv = argv[3];
+ if (argc == 4) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th 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 1 of a");
+ 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_rhs))
+ rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rhs) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_rhs) != NA_DCOMPLEX)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_DCOMPLEX);
+ rhs = NA_PTR_TYPE(rblapack_rhs, doublecomplex*);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublecomplex*);
+ MEMCPY(rhs_out__, rhs, doublecomplex, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ zgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
+
+ rblapack_scale = rb_float_new((double)scale);
+ return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
+}
+
+void
+init_lapack_zgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgesc2", rblapack_zgesc2, -1);
+}
diff --git a/ext/zgesdd.c b/ext/zgesdd.c
new file mode 100644
index 0000000..943260f
--- /dev/null
+++ b/ext/zgesdd.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID zgesdd_(char* jobz, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublecomplex* u, integer* ldu, doublecomplex* vt, integer* ldvt, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zgesdd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_u;
+ doublecomplex *u;
+ VALUE rblapack_vt;
+ doublecomplex *vt;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ucol;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.zgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESDD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors, by using divide-and-conquer method. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**H, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**H are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**H are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* in the array A and all rows of V**H are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**H are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**H are computed.\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 >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**H (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX*16 array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* unitary matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) COMPLEX*16 array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N unitary matrix V**H;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX*16 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 JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n* if JOBZ = 'O',\n* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* if JOBZ = 'S' or 'A',\n* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, a workspace query is assumed. The optimal\n* size for the WORK array is calculated and stored in WORK(1),\n* and no other work except argument checking is performed.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* If JOBZ = 'N', LRWORK >= 5*min(M,N).\n* Otherwise,\n* LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The updating process of DBDSDC did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.zgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"N") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,"O") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
+ ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = ucol;
+ rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ rwork = ALLOC_N(doublereal, (MAX(1, (lsame_(&jobz,"N") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))));
+ iwork = ALLOC_N(integer, (8*MIN(m,n)));
+
+ zgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgesdd", rblapack_zgesdd, -1);
+}
diff --git a/ext/zgesv.c b/ext/zgesv.c
new file mode 100644
index 0000000..a55f271
--- /dev/null
+++ b/ext/zgesv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zgesv_(integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zgesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, info, a, b = NumRu::Lapack.zgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGETRF, ZGETRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.zgesv( 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgesv", rblapack_zgesv, -1);
+}
diff --git a/ext/zgesvd.c b/ext/zgesvd.c
new file mode 100644
index 0000000..16486d4
--- /dev/null
+++ b/ext/zgesvd.c
@@ -0,0 +1,146 @@
+#include "rb_lapack.h"
+
+extern VOID zgesvd_(char* jobu, char* jobvt, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublecomplex* u, integer* ldu, doublecomplex* vt, integer* ldvt, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgesvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobvt;
+ char jobvt;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_u;
+ doublecomplex *u;
+ VALUE rblapack_vt;
+ doublecomplex *vt;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldu;
+ integer ldvt;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.zgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESVD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**H, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**H:\n* = 'A': all N rows of V**H are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**H (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**H (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**H (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**H (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX*16 array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M unitary matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) COMPLEX*16 array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N unitary matrix\n* V**H;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n* unconverged superdiagonal elements of an upper bidiagonal\n* matrix B whose diagonal is in S (not necessarily sorted).\n* B satisfies A = U * B * VT, so it has the same singular\n* values as A, and singular vectors related by U and VT.\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 ZBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of RWORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.zgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobu = argv[0];
+ rblapack_jobvt = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
+ jobvt = StringValueCStr(rblapack_jobvt)[0];
+ ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(1, 2*MIN(m,n)+MAX(m,n));
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
+ rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvt;
+ shape[1] = n;
+ rblapack_vt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vt = NA_PTR_TYPE(rblapack_vt, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = MAX(n, MIN(m,n));
+ rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
+ {
+ VALUE __shape__[3];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
+ __shape__[2] = rblapack_a;
+ na_aset(3, __shape__, rblapack_a_out__);
+ }
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+ rwork = ALLOC_N(doublereal, (5*MIN(m,n)));
+
+ zgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ {
+ VALUE __shape__[2];
+ __shape__[0] = Qtrue;
+ __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
+ rblapack_a = na_aref(2, __shape__, rblapack_a);
+ }
+ return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgesvd", rblapack_zgesvd, -1);
+}
diff --git a/ext/zgesvx.c b/ext/zgesvx.c
new file mode 100644
index 0000000..0a816af
--- /dev/null
+++ b/ext/zgesvx.c
@@ -0,0 +1,278 @@
+#include "rb_lapack.h"
+
+extern VOID zgesvx_(char* fact, char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgesvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.zgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESVX uses the LU factorization to compute the solution to a complex\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (2*N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.zgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 9) {
+ rblapack_af = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_equed = argv[6];
+ rblapack_r = argv[7];
+ rblapack_c = argv[8];
+ } else if (rblapack_options != Qnil) {
+ rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
+ rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
+ rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
+ rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
+ rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
+ } else {
+ rblapack_af = Qnil;
+ rblapack_ipiv = Qnil;
+ rblapack_equed = Qnil;
+ rblapack_r = Qnil;
+ rblapack_c = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_ipiv != Qnil) {
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (option) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ }
+ if (rblapack_r != Qnil) {
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (option) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ }
+ ldx = n;
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_equed != Qnil) {
+ equed = StringValueCStr(rblapack_equed)[0];
+ }
+ ldaf = n;
+ 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);
+ nrhs = 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*);
+ if (rblapack_c != Qnil) {
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (option) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ }
+ if (rblapack_af != Qnil) {
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (option) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
+ if (NA_SHAPE0(rblapack_af) != ldaf)
+ rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2*n;
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ if (rblapack_af != Qnil) {
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ }
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ if (rblapack_ipiv != Qnil) {
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ }
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ if (rblapack_r != Qnil) {
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ }
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
+ if (rblapack_c != Qnil) {
+ MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
+ }
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
+}
+
+void
+init_lapack_zgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgesvx", rblapack_zgesvx, -1);
+}
diff --git a/ext/zgesvxx.c b/ext/zgesvxx.c
new file mode 100644
index 0000000..841a809
--- /dev/null
+++ b/ext/zgesvxx.c
@@ -0,0 +1,281 @@
+#include "rb_lapack.h"
+
+extern VOID zgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgesvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_r_out__;
+ doublereal *r_out__;
+ VALUE rblapack_c_out__;
+ doublereal *c_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.zgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESVXX uses the LU factorization to compute the solution to a\n* complex*16 system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In ZGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.zgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_r = argv[6];
+ rblapack_c = argv[7];
+ rblapack_b = argv[8];
+ rblapack_params = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_r))
+ rb_raise(rb_eArgError, "r (7th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_r) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ n_err_bnds = 3;
+ trans = StringValueCStr(rblapack_trans)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (10th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
+ MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
+ rblapack_r = rblapack_r_out__;
+ r = r_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_zgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgesvxx", rblapack_zgesvxx, -1);
+}
diff --git a/ext/zgetc2.c b/ext/zgetc2.c
new file mode 100644
index 0000000..b99d979
--- /dev/null
+++ b/ext/zgetc2.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID zgetc2_(integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);
+
+
+static VALUE
+rblapack_zgetc2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_info;
+ integer info;
+ 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 ipiv, jpiv, info, a = NumRu::Lapack.zgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGETC2 computes an LU factorization, using complete pivoting, of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is a level 1 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\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 n-by-n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* IPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce overflow if\n* one tries to solve for x in Ax = b. So U is perturbed\n* to avoid the overflow.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.zgetc2( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ {
+ int 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__;
+
+ zgetc2_(&n, a, &lda, ipiv, jpiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgetc2", rblapack_zgetc2, -1);
+}
diff --git a/ext/zgetf2.c b/ext/zgetf2.c
new file mode 100644
index 0000000..814f788
--- /dev/null
+++ b/ext/zgetf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID zgetf2_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zgetf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ 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 ipiv, info, a = NumRu::Lapack.zgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zgetf2( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ zgetf2_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgetf2", rblapack_zgetf2, -1);
+}
diff --git a/ext/zgetrf.c b/ext/zgetrf.c
new file mode 100644
index 0000000..c60e10a
--- /dev/null
+++ b/ext/zgetrf.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID zgetrf_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zgetrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ 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 ipiv, info, a = NumRu::Lapack.zgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zgetrf( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ zgetrf_(&m, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgetrf", rblapack_zgetrf, -1);
+}
diff --git a/ext/zgetri.c b/ext/zgetri.c
new file mode 100644
index 0000000..946c3f5
--- /dev/null
+++ b/ext/zgetri.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zgetri_(integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgetri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 work, info, a = NumRu::Lapack.zgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGETRI computes the inverse of a matrix using the LU factorization\n* computed by ZGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\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 factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 2 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
+ rblapack_a = argv[0];
+ rblapack_ipiv = argv[1];
+ if (argc == 3) {
+ rblapack_lwork = argv[2];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (2th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgetri", rblapack_zgetri, -1);
+}
diff --git a/ext/zgetrs.c b/ext/zgetrs.c
new file mode 100644
index 0000000..e602792
--- /dev/null
+++ b/ext/zgetrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zgetrs_(char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zgetrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGETRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by ZGETRF.\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)\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.zgetrs( trans, a, ipiv, b, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgetrs", rblapack_zgetrs, -1);
+}
diff --git a/ext/zggbak.c b/ext/zggbak.c
new file mode 100644
index 0000000..2f8d926
--- /dev/null
+++ b/ext/zggbak.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID zggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, integer* m, doublecomplex* v, integer* ldv, integer* info);
+
+
+static VALUE
+rblapack_zggbak(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ doublereal *lscale;
+ VALUE rblapack_rscale;
+ doublereal *rscale;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ doublecomplex *v_out__;
+
+ integer n;
+ integer ldv;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.zggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* ZGGBAK forms the right or left eigenvectors of a complex generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* ZGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to ZGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by ZGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by ZGGBAL.\n*\n* RSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by ZGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX*16 array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by ZTGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZDSCAL, ZSWAP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.zggbak( job, side, ilo, ihi, lscale, rscale, v, [: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_job = argv[0];
+ rblapack_side = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_lscale = argv[4];
+ rblapack_rscale = argv[5];
+ rblapack_v = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_lscale))
+ rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
+ if (NA_RANK(rblapack_lscale) != 1)
+ rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_lscale);
+ if (NA_TYPE(rblapack_lscale) != NA_DFLOAT)
+ rblapack_lscale = na_change_type(rblapack_lscale, NA_DFLOAT);
+ lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ m = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_rscale))
+ rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
+ if (NA_RANK(rblapack_rscale) != 1)
+ rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rscale) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
+ if (NA_TYPE(rblapack_rscale) != NA_DFLOAT)
+ rblapack_rscale = na_change_type(rblapack_rscale, NA_DFLOAT);
+ rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
+ ihi = NUM2INT(rblapack_ihi);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = m;
+ rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
+ MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ zggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_zggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggbak", rblapack_zggbak, -1);
+}
diff --git a/ext/zggbal.c b/ext/zggbal.c
new file mode 100644
index 0000000..2291f60
--- /dev/null
+++ b/ext/zggbal.c
@@ -0,0 +1,128 @@
+#include "rb_lapack.h"
+
+extern VOID zggbal_(char* job, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_zggbal(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ doublereal *lscale;
+ VALUE rblapack_rscale;
+ doublereal *rscale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.zggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGBAL balances a pair of general complex matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i=1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j) is the scaling factor\n* applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) REAL array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.zggbal( job, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 3)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_job = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th 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*);
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublereal, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
+
+ zggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
+
+ free(work);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggbal", rblapack_zggbal, -1);
+}
diff --git a/ext/zgges.c b/ext/zgges.c
new file mode 100644
index 0000000..a70df1b
--- /dev/null
+++ b/ext/zgges.c
@@ -0,0 +1,192 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(doublecomplex *arg0, doublecomplex *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+ rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID zgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* sdim, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vsl, integer* ldvsl, doublecomplex* vsr, integer* ldvsr, doublecomplex* work, integer* lwork, doublereal* rwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_zgges(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_vsl;
+ doublecomplex *vsl;
+ VALUE rblapack_vsr;
+ doublecomplex *vsr;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGES computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the generalized complex Schur\n* form (S, T), and optionally left and/or right Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T. The leading\n* columns of VSL and VSR then form an unitary basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* ZGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0, and even for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if S\n* and T are upper triangular and, in addition, the diagonal elements\n* of T are non-negative real numbers.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue ALPHA(j)/BETA(j) is selected if\n* SELCTG(ALPHA(j),BETA(j)) is true.\n*\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+2 (See INFO below).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),\n* j=1,...,N are the diagonals of the complex Schur form (A,B)\n* output by ZGGES. The BETA(j) will be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in ZHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering falied in ZTGSEN.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[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);
+ 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*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (8*n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ zgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgges", rblapack_zgges, -1);
+}
diff --git a/ext/zggesx.c b/ext/zggesx.c
new file mode 100644
index 0000000..3d58454
--- /dev/null
+++ b/ext/zggesx.c
@@ -0,0 +1,230 @@
+#include "rb_lapack.h"
+
+static logical
+rblapack_selctg(doublecomplex *arg0, doublecomplex *arg1){
+ VALUE rblapack_arg0, rblapack_arg1;
+
+ VALUE rblapack_ret;
+ logical ret;
+
+ rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
+ rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
+
+ rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);
+
+ ret = (rblapack_ret == Qtrue);
+ return ret;
+}
+
+extern VOID zggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* sdim, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vsl, integer* ldvsl, doublecomplex* vsr, integer* ldvsr, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* liwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_zggesx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvsl;
+ char jobvsl;
+ VALUE rblapack_jobvsr;
+ char jobvsr;
+ VALUE rblapack_sort;
+ char sort;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_sdim;
+ integer sdim;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_vsl;
+ doublecomplex *vsl;
+ VALUE rblapack_vsr;
+ doublecomplex *vsr;
+ VALUE rblapack_rconde;
+ doublereal *rconde;
+ VALUE rblapack_rcondv;
+ doublereal *rcondv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvsl;
+ integer ldvsr;
+
+ 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 sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.zggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n* and, optionally, the left and/or right matrices of Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if T is\n* upper triangular with non-negative diagonal and S is upper\n* triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3 see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are\n* the diagonals of the complex Schur form (S,T). BETA(j) will\n* be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition number for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n* not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N )\n* Real workspace.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+2.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in ZHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in ZTGSEN.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.zggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobvsl = argv[0];
+ rblapack_jobvsr = argv[1];
+ rblapack_sort = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 8) {
+ rblapack_lwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobvsl = StringValueCStr(rblapack_jobvsl)[0];
+ sort = StringValueCStr(rblapack_sort)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ jobvsr = StringValueCStr(rblapack_jobvsr)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ ldvsl = lsame_(&jobvsl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+2;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(2*n,n*n/2) : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvsr = lsame_(&jobvsr,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvsl;
+ shape[1] = n;
+ rblapack_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vsl = NA_PTR_TYPE(rblapack_vsl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvsr;
+ shape[1] = n;
+ rblapack_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vsr = NA_PTR_TYPE(rblapack_vsr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (8*n));
+ bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
+
+ zggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, rwork, iwork, &liwork, bwork, &info);
+
+ free(rwork);
+ free(bwork);
+ rblapack_sdim = INT2NUM(sdim);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(12, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggesx", rblapack_zggesx, -1);
+}
diff --git a/ext/zggev.c b/ext/zggev.c
new file mode 100644
index 0000000..7e7d6f9
--- /dev/null
+++ b/ext/zggev.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID zggev_(char* jobvl, char* jobvr, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zggev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+
+ 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 alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right generalized eigenvector v(j) corresponding to the\n* generalized eigenvalue lambda(j) of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left generalized eigenvector u(j) corresponding to the\n* generalized eigenvalues lambda(j) of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: =N+1: other then QZ iteration failed in DHGEQZ,\n* =N+2: error return from DTGEVC.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobvl = argv[0];
+ rblapack_jobvr = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobvl = StringValueCStr(rblapack_jobvl)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(1,2*n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 8*n;
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggev", rblapack_zggev, -1);
+}
diff --git a/ext/zggevx.c b/ext/zggevx.c
new file mode 100644
index 0000000..d3c8605
--- /dev/null
+++ b/ext/zggevx.c
@@ -0,0 +1,226 @@
+#include "rb_lapack.h"
+
+extern VOID zggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* abnrm, doublereal* bbnrm, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, logical* bwork, integer* info);
+
+
+static VALUE
+rblapack_zggevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_balanc;
+ char balanc;
+ VALUE rblapack_jobvl;
+ char jobvl;
+ VALUE rblapack_jobvr;
+ char jobvr;
+ VALUE rblapack_sense;
+ char sense;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_lscale;
+ doublereal *lscale;
+ VALUE rblapack_rscale;
+ doublereal *rscale;
+ VALUE rblapack_abnrm;
+ doublereal abnrm;
+ VALUE rblapack_bbnrm;
+ doublereal bbnrm;
+ VALUE rblapack_rconde;
+ doublereal *rconde;
+ VALUE rblapack_rcondv;
+ doublereal *rcondv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+ integer *iwork;
+ logical *bwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+ integer lrwork;
+
+ 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 alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.zggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B) the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* Optionally, it also computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* A * v(j) = lambda(j) * B * v(j) .\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed:\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the complex Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the complex\n* Schur form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n* eigenvalues.\n*\n* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio ALPHA/BETA.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. If the eigenvalues cannot be reordered to\n* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n* when the true value would be very small anyway.\n* If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* If SENSE = 'E', LWORK >= max(1,4*N).\n* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*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* RWORK (workspace) REAL array, dimension (lrwork)\n* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n* and at least max(1,2*N) otherwise.\n* Real workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be correct\n* for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in ZHGEQZ.\n* =N+2: error return from ZTGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.zggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_balanc = argv[0];
+ rblapack_jobvl = argv[1];
+ rblapack_jobvr = argv[2];
+ rblapack_sense = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ balanc = StringValueCStr(rblapack_balanc)[0];
+ jobvr = StringValueCStr(rblapack_jobvr)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ jobvl = StringValueCStr(rblapack_jobvl)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ ldvr = lsame_(&jobvr,"V") ? n : 1;
+ ldvl = lsame_(&jobvl,"V") ? n : 1;
+ sense = StringValueCStr(rblapack_sense)[0];
+ lrwork = ((lsame_(&balanc,"S")) || (lsame_(&balanc,"B"))) ? MAX(1,6*n) : MAX(1,2*n);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&sense,"E") ? 4*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+2*n : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = n;
+ rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = n;
+ rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (lrwork));
+ iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+2));
+ bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
+
+ zggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, rwork, iwork, bwork, &info);
+
+ free(rwork);
+ free(iwork);
+ free(bwork);
+ rblapack_ilo = INT2NUM(ilo);
+ rblapack_ihi = INT2NUM(ihi);
+ rblapack_abnrm = rb_float_new((double)abnrm);
+ rblapack_bbnrm = rb_float_new((double)bbnrm);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(16, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggevx", rblapack_zggevx, -1);
+}
diff --git a/ext/zggglm.c b/ext/zggglm.c
new file mode 100644
index 0000000..31b1278
--- /dev/null
+++ b/ext/zggglm.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID zggglm_(integer* n, integer* m, integer* p, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* d, doublecomplex* x, doublecomplex* y, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zggglm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_d_out__;
+ doublecomplex *d_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ integer p;
+ 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 x, y, work, info, a, b, d = NumRu::Lapack.zggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) COMPLEX*16 array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX*16 array, dimension (M)\n* Y (output) COMPLEX*16 array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.zggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_d = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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);
+ p = 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*);
+ if (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_y = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
+ MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+
+ zggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
+}
+
+void
+init_lapack_zggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggglm", rblapack_zggglm, -1);
+}
diff --git a/ext/zgghrd.c b/ext/zgghrd.c
new file mode 100644
index 0000000..2cd0b9a
--- /dev/null
+++ b/ext/zgghrd.c
@@ -0,0 +1,167 @@
+#include "rb_lapack.h"
+
+extern VOID zgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_zgghrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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, b, q, z = NumRu::Lapack.zgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n* Hessenberg form using unitary transformations, where A is a\n* general matrix and B is upper triangular. The form of the\n* generalized eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the unitary matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**H*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**H*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**H*x.\n*\n* The unitary matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n* If Q1 is the unitary matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then ZGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to ZGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**H B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n* from the QR factorization of B.\n* On exit, if COMPQ='I', the unitary matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1.\n* On exit, if COMPZ='I', the unitary matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and van Loan (Johns Hopkins Press).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.zgghrd( compq, compz, ilo, ihi, a, b, q, z, [: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_compq = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_zgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgghrd", rblapack_zgghrd, -1);
+}
diff --git a/ext/zgglse.c b/ext/zgglse.c
new file mode 100644
index 0000000..f3e98ea
--- /dev/null
+++ b/ext/zgglse.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID zgglse_(integer* m, integer* n, integer* p, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, doublecomplex* d, doublecomplex* x, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zgglse(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ VALUE rblapack_d_out__;
+ doublecomplex *d_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer m;
+ 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 x, work, info, a, b, c, d = NumRu::Lapack.zgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( ( A ) ) = N.\n* ( ( B ) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) COMPLEX*16 array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) COMPLEX*16 array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX*16 array, dimension (N)\n* On exit, X is the solution of the LSE problem.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* ZGEQRF, CGERQF, ZUNMQR and CUNMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.zgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ rblapack_d = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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);
+ p = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = m+n+p;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
+ MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+
+ zgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
+}
+
+void
+init_lapack_zgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgglse", rblapack_zgglse, -1);
+}
diff --git a/ext/zggqrf.c b/ext/zggqrf.c
new file mode 100644
index 0000000..b825e94
--- /dev/null
+++ b/ext/zggqrf.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID zggqrf_(integer* n, integer* m, integer* p, doublecomplex* a, integer* lda, doublecomplex* taua, doublecomplex* b, integer* ldb, doublecomplex* taub, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zggqrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ doublecomplex *taua;
+ VALUE rblapack_taub;
+ doublecomplex *taub;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer m;
+ integer ldb;
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.zggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n* and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the unitary matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) COMPLEX*16 array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the unitary\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) COMPLEX*16 array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of ZUNMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine ZUNGQR.\n* To use Q to update another matrix, use LAPACK subroutine ZUNMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine ZUNGRQ.\n* To use Z to update another matrix, use LAPACK subroutine ZUNMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMQR\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.zggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_n = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ p = 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*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(n,m);
+ rblapack_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(n,p);
+ rblapack_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = m;
+ 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = p;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggqrf", rblapack_zggqrf, -1);
+}
diff --git a/ext/zggrqf.c b/ext/zggrqf.c
new file mode 100644
index 0000000..e940ca5
--- /dev/null
+++ b/ext/zggrqf.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID zggrqf_(integer* m, integer* p, integer* n, doublecomplex* a, integer* lda, doublecomplex* taua, doublecomplex* b, integer* ldb, doublecomplex* taub, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zggrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_p;
+ integer p;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_taua;
+ doublecomplex *taua;
+ VALUE rblapack_taub;
+ doublecomplex *taub;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 taua, taub, work, info, a, b = NumRu::Lapack.zggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the unitary\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the unitary matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) COMPLEX*16 array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of ZUNMRQ.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine ZUNGRQ.\n* To use Q to update another matrix, use LAPACK subroutine ZUNMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine ZUNGQR.\n* To use Z to update another matrix, use LAPACK subroutine ZUNMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMRQ\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.zggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_m = argv[0];
+ rblapack_p = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ p = NUM2INT(rblapack_p);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MAX(MAX(n,m),p);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taua = NA_PTR_TYPE(rblapack_taua, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MIN(p,n);
+ rblapack_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taub = NA_PTR_TYPE(rblapack_taub, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggrqf", rblapack_zggrqf, -1);
+}
diff --git a/ext/zggsvd.c b/ext/zggsvd.c
new file mode 100644
index 0000000..c1a37c9
--- /dev/null
+++ b/ext/zggsvd.c
@@ -0,0 +1,184 @@
+#include "rb_lapack.h"
+
+extern VOID zggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* alpha, doublereal* beta, doublecomplex* u, integer* ldu, doublecomplex* v, integer* ldv, doublecomplex* q, integer* ldq, doublecomplex* work, doublereal* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zggsvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_alpha;
+ doublereal *alpha;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_u;
+ doublecomplex *u;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.zggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N complex matrix A and P-by-N complex matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are unitary matrices, and Z' means the conjugate\n* transpose of Z. Let K+L = the effective numerical rank of the\n* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n* matrices and of the following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the unitary\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n* equal to the CS decomposition of A and B. Furthermore, the GSVD can\n* be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) )\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains part of the triangular matrix R if\n* M-K-L < 0. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) COMPLEX*16 array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX*16 array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)+N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine ZTGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA DOUBLE PRECISION\n* TOLB DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n DOUBLE PRECISION DLAMCH, ZLANGE\n EXTERNAL LSAME, DLAMCH, ZLANGE\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, XERBLA, ZGGSVP, ZTGSJA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.zggsvd( jobu, jobv, jobq, a, b, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ 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*);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublecomplex, (MAX(3*n,m)*(p)+n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, rwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggsvd", rblapack_zggsvd, -1);
+}
diff --git a/ext/zggsvp.c b/ext/zggsvp.c
new file mode 100644
index 0000000..71818b8
--- /dev/null
+++ b/ext/zggsvp.c
@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID zggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* tola, doublereal* tolb, integer* k, integer* l, doublecomplex* u, integer* ldu, doublecomplex* v, integer* ldv, doublecomplex* q, integer* ldq, integer* iwork, doublereal* rwork, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zggsvp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_tola;
+ doublereal tola;
+ VALUE rblapack_tolb;
+ doublereal tolb;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_u;
+ doublecomplex *u;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ integer *iwork;
+ doublereal *rwork;
+ doublecomplex *tau;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 k, l, u, v, q, info, a, b = NumRu::Lapack.zggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGSVP computes unitary matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* conjugate transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* ZGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) COMPLEX*16 array, dimension (LDU,M)\n* If JOBU = 'U', U contains the unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX*16 array, dimension (LDV,P)\n* If JOBV = 'V', V contains the unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* TAU (workspace) COMPLEX*16 array, dimension (N)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine ZGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.zggsvp( jobu, jobv, jobq, a, b, tola, tolb, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_tola = argv[5];
+ rblapack_tolb = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[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);
+ 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*);
+ tolb = NUM2DBL(rblapack_tolb);
+ p = ldb;
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ tola = NUM2DBL(rblapack_tola);
+ ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
+ m = lda;
+ ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ iwork = ALLOC_N(integer, (n));
+ rwork = ALLOC_N(doublereal, (2*n));
+ tau = ALLOC_N(doublecomplex, (n));
+ work = ALLOC_N(doublecomplex, (MAX(3*n,m)*(p)));
+
+ zggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, rwork, tau, work, &info);
+
+ free(iwork);
+ free(rwork);
+ free(tau);
+ free(work);
+ rblapack_k = INT2NUM(k);
+ rblapack_l = INT2NUM(l);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zggsvp", rblapack_zggsvp, -1);
+}
diff --git a/ext/zgtcon.c b/ext/zgtcon.c
new file mode 100644
index 0000000..a2e7b60
--- /dev/null
+++ b/ext/zgtcon.c
@@ -0,0 +1,121 @@
+#include "rb_lapack.h"
+
+extern VOID zgtcon_(char* norm, integer* n, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zgtcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_du2;
+ doublecomplex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *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 rcond, info = NumRu::Lapack.zgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGTCON estimates the reciprocal of the condition number of a complex\n* tridiagonal matrix A using the LU factorization as computed by\n* ZGTTRF.\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by ZGTTRF.\n*\n* D (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX*16 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) DOUBLE PRECISION\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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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.zgtcon( 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgtcon", rblapack_zgtcon, -1);
+}
diff --git a/ext/zgtrfs.c b/ext/zgtrfs.c
new file mode 100644
index 0000000..6dc720a
--- /dev/null
+++ b/ext/zgtrfs.c
@@ -0,0 +1,209 @@
+#include "rb_lapack.h"
+
+extern VOID zgtrfs_(char* trans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* dlf, doublecomplex* df, doublecomplex* duf, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgtrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_dlf;
+ doublecomplex *dlf;
+ VALUE rblapack_df;
+ doublecomplex *df;
+ VALUE rblapack_duf;
+ doublecomplex *duf;
+ VALUE rblapack_du2;
+ doublecomplex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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.zgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGTRFS 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)\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by ZGTTRF.\n*\n* DF (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGTTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zgtrfs( 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_df = na_change_type(rblapack_df, NA_DCOMPLEX);
+ df = NA_PTR_TYPE(rblapack_df, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_dlf = na_change_type(rblapack_dlf, NA_DCOMPLEX);
+ dlf = NA_PTR_TYPE(rblapack_dlf, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_duf = na_change_type(rblapack_duf, NA_DCOMPLEX);
+ duf = NA_PTR_TYPE(rblapack_duf, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgtrfs", rblapack_zgtrfs, -1);
+}
diff --git a/ext/zgtsv.c b/ext/zgtsv.c
new file mode 100644
index 0000000..2a2fcb1
--- /dev/null
+++ b/ext/zgtsv.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern VOID zgtsv_(integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zgtsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ doublecomplex *dl_out__;
+ VALUE rblapack_d_out__;
+ doublecomplex *d_out__;
+ VALUE rblapack_du_out__;
+ doublecomplex *du_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, dl, d, du, b = NumRu::Lapack.zgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DL must contain the (n-1) subdiagonal elements of\n* A.\n* On exit, DL is overwritten by the (n-2) elements of the\n* second superdiagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) COMPLEX*16 array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DU must contain the (n-1) superdiagonal elements\n* of A.\n* On exit, DU is overwritten by the (n-1) elements of the first\n* superdiagonal of U.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.zgtsv( dl, d, du, b, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublecomplex*);
+ MEMCPY(dl_out__, dl, doublecomplex, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
+ MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_du_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublecomplex*);
+ MEMCPY(du_out__, du, doublecomplex, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
+}
+
+void
+init_lapack_zgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgtsv", rblapack_zgtsv, -1);
+}
diff --git a/ext/zgtsvx.c b/ext/zgtsvx.c
new file mode 100644
index 0000000..0c77648
--- /dev/null
+++ b/ext/zgtsvx.c
@@ -0,0 +1,256 @@
+#include "rb_lapack.h"
+
+extern VOID zgtsvx_(char* fact, char* trans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* dlf, doublecomplex* df, doublecomplex* duf, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zgtsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_dlf;
+ doublecomplex *dlf;
+ VALUE rblapack_df;
+ doublecomplex *df;
+ VALUE rblapack_duf;
+ doublecomplex *duf;
+ VALUE rblapack_du2;
+ doublecomplex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dlf_out__;
+ doublecomplex *dlf_out__;
+ VALUE rblapack_df_out__;
+ doublecomplex *df_out__;
+ VALUE rblapack_duf_out__;
+ doublecomplex *duf_out__;
+ VALUE rblapack_du2_out__;
+ doublecomplex *du2_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.zgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGTSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form\n* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n* be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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)\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The n diagonal elements of A.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input or output) COMPLEX*16 array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by ZGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) COMPLEX*16 array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) COMPLEX*16 array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) COMPLEX*16 array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by ZGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.zgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [: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_fact = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_dlf = argv[5];
+ rblapack_df = argv[6];
+ rblapack_duf = argv[7];
+ rblapack_du2 = argv[8];
+ rblapack_ipiv = argv[9];
+ rblapack_b = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (7th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (7th 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_DCOMPLEX)
+ rblapack_df = na_change_type(rblapack_df, NA_DCOMPLEX);
+ df = NA_PTR_TYPE(rblapack_df, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (10th 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*);
+ ldx = MAX(1,n);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ if (!NA_IsNArray(rblapack_duf))
+ rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
+ if (NA_RANK(rblapack_duf) != 1)
+ rb_raise(rb_eArgError, "rank of duf (8th 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_DCOMPLEX)
+ rblapack_duf = na_change_type(rblapack_duf, NA_DCOMPLEX);
+ duf = NA_PTR_TYPE(rblapack_duf, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (11th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ if (!NA_IsNArray(rblapack_du2))
+ rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_du2) != 1)
+ rb_raise(rb_eArgError, "rank of du2 (9th 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_DCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
+ if (!NA_IsNArray(rblapack_dlf))
+ rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
+ if (NA_RANK(rblapack_dlf) != 1)
+ rb_raise(rb_eArgError, "rank of dlf (6th 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_DCOMPLEX)
+ rblapack_dlf = na_change_type(rblapack_dlf, NA_DCOMPLEX);
+ dlf = NA_PTR_TYPE(rblapack_dlf, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dlf_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, doublecomplex*);
+ MEMCPY(dlf_out__, dlf, doublecomplex, NA_TOTAL(rblapack_dlf));
+ rblapack_dlf = rblapack_dlf_out__;
+ dlf = dlf_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublecomplex*);
+ MEMCPY(df_out__, df, doublecomplex, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_duf_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, doublecomplex*);
+ MEMCPY(duf_out__, duf, doublecomplex, NA_TOTAL(rblapack_duf));
+ rblapack_duf = rblapack_duf_out__;
+ duf = duf_out__;
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, doublecomplex*);
+ MEMCPY(du2_out__, du2, doublecomplex, NA_TOTAL(rblapack_du2));
+ rblapack_du2 = rblapack_du2_out__;
+ du2 = du2_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
+}
+
+void
+init_lapack_zgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgtsvx", rblapack_zgtsvx, -1);
+}
diff --git a/ext/zgttrf.c b/ext/zgttrf.c
new file mode 100644
index 0000000..66fd80d
--- /dev/null
+++ b/ext/zgttrf.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID zgttrf_(integer* n, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zgttrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_du2;
+ doublecomplex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_dl_out__;
+ doublecomplex *dl_out__;
+ VALUE rblapack_d_out__;
+ doublecomplex *d_out__;
+ VALUE rblapack_du_out__;
+ doublecomplex *du_out__;
+
+ 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 du2, ipiv, info, dl, d, du = NumRu::Lapack.zgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGTTRF computes an LU factorization of a complex tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) COMPLEX*16 array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) COMPLEX*16 array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.zgttrf( dl, d, du, [: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_dl = argv[0];
+ rblapack_d = argv[1];
+ rblapack_du = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (1th 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (3th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (3th 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n-2;
+ rblapack_du2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_dl_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublecomplex*);
+ MEMCPY(dl_out__, dl, doublecomplex, NA_TOTAL(rblapack_dl));
+ rblapack_dl = rblapack_dl_out__;
+ dl = dl_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
+ MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_du_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublecomplex*);
+ MEMCPY(du_out__, du, doublecomplex, NA_TOTAL(rblapack_du));
+ rblapack_du = rblapack_du_out__;
+ du = du_out__;
+
+ zgttrf_(&n, dl, d, du, du2, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
+}
+
+void
+init_lapack_zgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgttrf", rblapack_zgttrf, -1);
+}
diff --git a/ext/zgttrs.c b/ext/zgttrs.c
new file mode 100644
index 0000000..b05f622
--- /dev/null
+++ b/ext/zgttrs.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID zgttrs_(char* trans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zgttrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_du2;
+ doublecomplex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGTTRS solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by ZGTTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX*16 array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGTTS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zgttrs( trans, dl, d, du, du2, ipiv, b, [: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_trans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgttrs", rblapack_zgttrs, -1);
+}
diff --git a/ext/zgtts2.c b/ext/zgtts2.c
new file mode 100644
index 0000000..b164dbc
--- /dev/null
+++ b/ext/zgtts2.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID zgtts2_(integer* itrans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb);
+
+
+static VALUE
+rblapack_zgtts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itrans;
+ integer itrans;
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_du2;
+ doublecomplex *du2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.zgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* ZGTTS2 solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by ZGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A**T * X = B (Transpose)\n* = 2: A**H * X = B (Conjugate transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX*16 array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n COMPLEX*16 TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.zgtts2( itrans, dl, d, du, du2, ipiv, b, [: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_itrans = argv[0];
+ rblapack_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ rblapack_du2 = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itrans = NUM2INT(rblapack_itrans);
+ 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
+ du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_zgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zgtts2", rblapack_zgtts2, -1);
+}
diff --git a/ext/zhbev.c b/ext/zhbev.c
new file mode 100644
index 0000000..15080a0
--- /dev/null
+++ b/ext/zhbev.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID zhbev_(char* jobz, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhbev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ab = NumRu::Lapack.zhbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.zhbev( jobz, uplo, kd, ab, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (MAX(1,3*n-2)));
+
+ zhbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zhbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbev", rblapack_zhbev, -1);
+}
diff --git a/ext/zhbevd.c b/ext/zhbevd.c
new file mode 100644
index 0000000..5760df7
--- /dev/null
+++ b/ext/zhbevd.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID zhbevd_(char* jobz, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zhbevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, rwork, iwork, info, ab = NumRu::Lapack.zhbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab = NumRu::Lapack.zhbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 7) {
+ rblapack_lwork = argv[4];
+ rblapack_lrwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ kd = NUM2INT(rblapack_kd);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zhbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zhbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbevd", rblapack_zhbevd, -1);
+}
diff --git a/ext/zhbevx.c b/ext/zhbevx.c
new file mode 100644
index 0000000..cf28f7d
--- /dev/null
+++ b/ext/zhbevx.c
@@ -0,0 +1,160 @@
+#include "rb_lapack.h"
+
+extern VOID zhbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublecomplex* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_zhbevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, ifail, info, ab = NumRu::Lapack.zhbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N unitary matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.zhbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vu = argv[6];
+ rblapack_il = argv[7];
+ rblapack_iu = argv[8];
+ rblapack_abstol = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ vu = NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
+ range = StringValueCStr(rblapack_range)[0];
+ vl = NUM2DBL(rblapack_vl);
+ abstol = NUM2DBL(rblapack_abstol);
+ kd = NUM2INT(rblapack_kd);
+ il = NUM2INT(rblapack_il);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ zhbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zhbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbevx", rblapack_zhbevx, -1);
+}
diff --git a/ext/zhbgst.c b/ext/zhbgst.c
new file mode 100644
index 0000000..41bb1fd
--- /dev/null
+++ b/ext/zhbgst.c
@@ -0,0 +1,120 @@
+#include "rb_lapack.h"
+
+extern VOID zhbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublecomplex* x, integer* ldx, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhbgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_bb;
+ doublecomplex *bb;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ 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 x, info, ab = NumRu::Lapack.zhbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGST reduces a complex Hermitian-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**H*S by ZPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**H*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) COMPLEX*16 array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by ZPBSTF, stored in the first kb+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) COMPLEX*16 array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 x, info, ab = NumRu::Lapack.zhbgst( vect, uplo, ka, kb, ab, bb, [: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_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
+ kb = NUM2INT(rblapack_kb);
+ ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zhbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zhbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbgst", rblapack_zhbgst, -1);
+}
diff --git a/ext/zhbgv.c b/ext/zhbgv.c
new file mode 100644
index 0000000..704e93e
--- /dev/null
+++ b/ext/zhbgv.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID zhbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhbgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_bb;
+ doublecomplex *bb;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_bb_out__;
+ doublecomplex *bb_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, info, ab, bb = NumRu::Lapack.zhbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by ZPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSTERF, XERBLA, ZHBGST, ZHBTRD, ZPBSTF, ZSTEQR\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.zhbgv( jobz, uplo, ka, kb, ab, bb, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
+ kb = NUM2INT(rblapack_kb);
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublecomplex*);
+ MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (3*n));
+
+ zhbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_zhbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbgv", rblapack_zhbgv, -1);
+}
diff --git a/ext/zhbgvd.c b/ext/zhbgvd.c
new file mode 100644
index 0000000..d565ca8
--- /dev/null
+++ b/ext/zhbgvd.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID zhbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zhbgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_bb;
+ doublecomplex *bb;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_bb_out__;
+ doublecomplex *bb_out__;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldz;
+
+ 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 w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.zhbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by ZPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.zhbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ka = argv[2];
+ rblapack_kb = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_bb = argv[5];
+ if (argc == 9) {
+ rblapack_lwork = argv[6];
+ rblapack_lrwork = argv[7];
+ rblapack_liwork = argv[8];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ ka = NUM2INT(rblapack_ka);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ if (NA_SHAPE1(rblapack_bb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ kb = NUM2INT(rblapack_kb);
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublecomplex*);
+ MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+
+ zhbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_zhbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbgvd", rblapack_zhbgvd, -1);
+}
diff --git a/ext/zhbgvx.c b/ext/zhbgvx.c
new file mode 100644
index 0000000..e3a91b6
--- /dev/null
+++ b/ext/zhbgvx.c
@@ -0,0 +1,189 @@
+#include "rb_lapack.h"
+
+extern VOID zhbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublecomplex* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_zhbgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ka;
+ integer ka;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_bb;
+ doublecomplex *bb;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_bb_out__;
+ doublecomplex *bb_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer ldab;
+ integer n;
+ integer ldbb;
+ integer ldq;
+ integer ldz;
+
+ 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, m, w, z, ifail, info, ab, bb = NumRu::Lapack.zhbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by ZPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n* <= N: then i eigenvectors failed to converge. Their\n* indices are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.zhbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ka = argv[3];
+ rblapack_kb = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_bb = argv[6];
+ rblapack_vl = argv[7];
+ rblapack_vu = argv[8];
+ rblapack_il = argv[9];
+ rblapack_iu = argv[10];
+ rblapack_abstol = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kb = NUM2INT(rblapack_kb);
+ if (!NA_IsNArray(rblapack_bb))
+ rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
+ if (NA_RANK(rblapack_bb) != 2)
+ rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
+ ldbb = NA_SHAPE0(rblapack_bb);
+ n = NA_SHAPE1(rblapack_bb);
+ if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
+ rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
+ bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
+ vu = NUM2DBL(rblapack_vu);
+ iu = NUM2INT(rblapack_iu);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ il = NUM2INT(rblapack_il);
+ ldz = lsame_(&jobz,"V") ? n : 1;
+ ka = NUM2INT(rblapack_ka);
+ abstol = NUM2DBL(rblapack_abstol);
+ vl = NUM2DBL(rblapack_vl);
+ ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldbb;
+ shape[1] = n;
+ rblapack_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublecomplex*);
+ MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rblapack_bb));
+ rblapack_bb = rblapack_bb_out__;
+ bb = bb_out__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ zhbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
+}
+
+void
+init_lapack_zhbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbgvx", rblapack_zhbgvx, -1);
+}
diff --git a/ext/zhbtrd.c b/ext/zhbtrd.c
new file mode 100644
index 0000000..225c59b
--- /dev/null
+++ b/ext/zhbtrd.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID zhbtrd_(char* vect, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* d, doublereal* e, doublecomplex* q, integer* ldq, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zhbtrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ doublecomplex *work;
+
+ integer ldab;
+ integer n;
+ integer ldq;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.zhbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBTRD reduces a complex Hermitian band matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.zhbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zhbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
+}
+
+void
+init_lapack_zhbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhbtrd", rblapack_zhbtrd, -1);
+}
diff --git a/ext/zhecon.c b/ext/zhecon.c
new file mode 100644
index 0000000..389c32a
--- /dev/null
+++ b/ext/zhecon.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID zhecon_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zhecon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+
+ 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 rcond, info = NumRu::Lapack.zhecon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHECON estimates the reciprocal of the condition number of a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHETRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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.zhecon( uplo, a, ipiv, anorm, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zhecon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zhecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhecon", rblapack_zhecon, -1);
+}
diff --git a/ext/zheequb.c b/ext/zheequb.c
new file mode 100644
index 0000000..334af8d
--- /dev/null
+++ b/ext/zheequb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zheequb_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zheequb(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_info;
+ integer info;
+ doublecomplex *work;
+
+ 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 s, scond, amax, info = NumRu::Lapack.zheequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zheequb( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ work = ALLOC_N(doublecomplex, (3*n));
+
+ zheequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
+
+ free(work);
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zheequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zheequb", rblapack_zheequb, -1);
+}
diff --git a/ext/zheev.c b/ext/zheev.c
new file mode 100644
index 0000000..2420b2e
--- /dev/null
+++ b/ext/zheev.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID zheev_(char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zheev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+
+ 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 w, work, info, a = NumRu::Lapack.zheev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEV computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for ZHETRD returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.zheev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
+
+ zheev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zheev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zheev", rblapack_zheev, -1);
+}
diff --git a/ext/zheevd.c b/ext/zheevd.c
new file mode 100644
index 0000000..632089e
--- /dev/null
+++ b/ext/zheevd.c
@@ -0,0 +1,143 @@
+#include "rb_lapack.h"
+
+extern VOID zheevd_(char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zheevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ 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 w, work, rwork, iwork, info, a = NumRu::Lapack.zheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a = NumRu::Lapack.zheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 6) {
+ rblapack_lwork = argv[3];
+ rblapack_lrwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+
+ zheevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zheevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zheevd", rblapack_zheevd, -1);
+}
diff --git a/ext/zheevr.c b/ext/zheevr.c
new file mode 100644
index 0000000..958279d
--- /dev/null
+++ b/ext/zheevr.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID zheevr_(char* jobz, char* range, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, integer* isuppz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zheevr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.zheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* ZHEEVR first reduces the matrix A to tridiagonal form T with a call\n* to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute\n* eigenspectrum using Relatively Robust Representations. ZSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see DSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of ZSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** ZSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* furutre releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for ZHETRD and for\n* ZUNMTR as returned by ILAENV.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal\n* (and minimal) LRWORK.\n*\n* LRWORK (input) INTEGER\n* The length of the array RWORK. LRWORK >= max(1,24*N).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal\n* (and minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.zheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 12) {
+ rblapack_lwork = argv[9];
+ rblapack_lrwork = argv[10];
+ rblapack_liwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = 10*n;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lrwork == Qnil)
+ lrwork = 24*n;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+
+ zheevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zheevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zheevr", rblapack_zheevr, -1);
+}
diff --git a/ext/zheevx.c b/ext/zheevx.c
new file mode 100644
index 0000000..1570c52
--- /dev/null
+++ b/ext/zheevx.c
@@ -0,0 +1,160 @@
+#include "rb_lapack.h"
+
+extern VOID zheevx_(char* jobz, char* range, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_zheevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a = NumRu::Lapack.zheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 2*N.\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for ZHETRD and for\n* ZUNMTR as returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.zheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int 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__;
+ rwork = ALLOC_N(doublereal, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ zheevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zheevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zheevx", rblapack_zheevx, -1);
+}
diff --git a/ext/zhegs2.c b/ext/zhegs2.c
new file mode 100644
index 0000000..4777398
--- /dev/null
+++ b/ext/zhegs2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID zhegs2_(integer* itype, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zhegs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.zhegs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGS2 reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by ZPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.zhegs2( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ {
+ int 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__;
+
+ zhegs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zhegs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhegs2", rblapack_zhegs2, -1);
+}
diff --git a/ext/zhegst.c b/ext/zhegst.c
new file mode 100644
index 0000000..fccf47d
--- /dev/null
+++ b/ext/zhegst.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID zhegst_(integer* itype, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zhegst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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.zhegst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by ZPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, a = NumRu::Lapack.zhegst( itype, uplo, a, b, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ {
+ int 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__;
+
+ zhegst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zhegst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhegst", rblapack_zhegst, -1);
+}
diff --git a/ext/zhegv.c b/ext/zhegv.c
new file mode 100644
index 0000000..e9c111b
--- /dev/null
+++ b/ext/zhegv.c
@@ -0,0 +1,140 @@
+#include "rb_lapack.h"
+
+extern VOID zhegv_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhegv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, info, a, b = NumRu::Lapack.zhegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the Hermitian positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for ZHETRD returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPOTRF or ZHEEV returned an error code:\n* <= N: if INFO = i, ZHEEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.zhegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
+
+ zhegv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zhegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhegv", rblapack_zhegv, -1);
+}
diff --git a/ext/zhegvd.c b/ext/zhegvd.c
new file mode 100644
index 0000000..6347ebe
--- /dev/null
+++ b/ext/zhegvd.c
@@ -0,0 +1,173 @@
+#include "rb_lapack.h"
+
+extern VOID zhegvd_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zhegvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 w, work, rwork, iwork, info, a, b = NumRu::Lapack.zhegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N + 1.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: ZPOTRF or ZHEEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if ZHEEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a, b = NumRu::Lapack.zhegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 8) {
+ rblapack_lwork = argv[5];
+ rblapack_lrwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zhegvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zhegvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhegvd", rblapack_zhegvd, -1);
+}
diff --git a/ext/zhegvx.c b/ext/zhegvx.c
new file mode 100644
index 0000000..389c32d
--- /dev/null
+++ b/ext/zhegvx.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID zhegvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_zhegvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldz;
+
+ 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 m, w, z, work, ifail, info, a, b = NumRu::Lapack.zhegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n**\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for ZHETRD returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPOTRF or ZHEEVX returned an error code:\n* <= N: if INFO = i, ZHEEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.zhegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vu = argv[7];
+ rblapack_il = argv[8];
+ rblapack_iu = argv[9];
+ rblapack_abstol = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ iu = NUM2INT(rblapack_iu);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ vu = NUM2DBL(rblapack_vu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ zhegvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zhegvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhegvx", rblapack_zhegvx, -1);
+}
diff --git a/ext/zherfs.c b/ext/zherfs.c
new file mode 100644
index 0000000..ed39b50
--- /dev/null
+++ b/ext/zherfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID zherfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zherfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.zherfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHERFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZHETRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zherfs( uplo, a, af, ipiv, 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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zherfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zherfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zherfs", rblapack_zherfs, -1);
+}
diff --git a/ext/zherfsx.c b/ext/zherfsx.c
new file mode 100644
index 0000000..27efc5e
--- /dev/null
+++ b/ext/zherfsx.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID zherfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zherfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHERFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ n_err_bnds = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zherfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_zherfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zherfsx", rblapack_zherfsx, -1);
+}
diff --git a/ext/zhesv.c b/ext/zhesv.c
new file mode 100644
index 0000000..baaa013
--- /dev/null
+++ b/ext/zhesv.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID zhesv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zhesv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, work, info, a, b = NumRu::Lapack.zhesv( uplo, a, b, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**H or A = L*D*L**H as computed by\n* ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZHETRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* ZHETRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHETRF, ZHETRS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.zhesv( uplo, a, b, lwork, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ rblapack_lwork = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ lwork = NUM2INT(rblapack_lwork);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zhesv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zhesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhesv", rblapack_zhesv, -1);
+}
diff --git a/ext/zhesvx.c b/ext/zhesvx.c
new file mode 100644
index 0000000..9ee112f
--- /dev/null
+++ b/ext/zhesvx.c
@@ -0,0 +1,183 @@
+#include "rb_lapack.h"
+
+extern VOID zhesvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhesvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zhesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHESVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHETRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHETRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHETRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for ZHETRF.\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* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zhesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ ldx = MAX(1,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ rwork = ALLOC_N(doublereal, (n));
+
+ zhesvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
+}
+
+void
+init_lapack_zhesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhesvx", rblapack_zhesvx, -1);
+}
diff --git a/ext/zhesvxx.c b/ext/zhesvxx.c
new file mode 100644
index 0000000..6c822cf
--- /dev/null
+++ b/ext/zhesvxx.c
@@ -0,0 +1,258 @@
+#include "rb_lapack.h"
+
+extern VOID zhesvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhesvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zhesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHESVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex*16 system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZHESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZHESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZHESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZHESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by ZHETRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by ZHETRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zhesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zhesvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_zhesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhesvxx", rblapack_zhesvxx, -1);
+}
diff --git a/ext/zhetd2.c b/ext/zhetd2.c
new file mode 100644
index 0000000..7cf1949
--- /dev/null
+++ b/ext/zhetd2.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID zhetd2_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tau, integer* info);
+
+
+static VALUE
+rblapack_zhetd2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ 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 d, e, tau, info, a = NumRu::Lapack.zhetd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* ZHETD2 reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q' * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.zhetd2( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+
+ zhetd2_(&uplo, &n, a, &lda, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zhetd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhetd2", rblapack_zhetd2, -1);
+}
diff --git a/ext/zhetf2.c b/ext/zhetf2.c
new file mode 100644
index 0000000..fca06ae
--- /dev/null
+++ b/ext/zhetf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID zhetf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zhetf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ 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 ipiv, info, a = NumRu::Lapack.zhetf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZHETF2 computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the conjugate transpose of U, and D is\n* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.210 and l.393\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zhetf2( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ zhetf2_(&uplo, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zhetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhetf2", rblapack_zhetf2, -1);
+}
diff --git a/ext/zhetrd.c b/ext/zhetrd.c
new file mode 100644
index 0000000..bdf2453
--- /dev/null
+++ b/ext/zhetrd.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID zhetrd_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zhetrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 d, e, tau, work, info, a = NumRu::Lapack.zhetrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRD reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.zhetrd( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zhetrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zhetrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhetrd", rblapack_zhetrd, -1);
+}
diff --git a/ext/zhetrf.c b/ext/zhetrf.c
new file mode 100644
index 0000000..7aadf4d
--- /dev/null
+++ b/ext/zhetrf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zhetrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zhetrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 ipiv, work, info, a = NumRu::Lapack.zhetrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRF computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHETF2, ZLAHEF\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.zhetrf( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zhetrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zhetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhetrf", rblapack_zhetrf, -1);
+}
diff --git a/ext/zhetri.c b/ext/zhetri.c
new file mode 100644
index 0000000..2291ee9
--- /dev/null
+++ b/ext/zhetri.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID zhetri_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zhetri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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.zhetri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRI computes the inverse of a complex Hermitian indefinite matrix\n* A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n* ZHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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 block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZHETRF.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* WORK (workspace) COMPLEX*16 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.zhetri( uplo, a, ipiv, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zhetri_(&uplo, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zhetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhetri", rblapack_zhetri, -1);
+}
diff --git a/ext/zhetrs.c b/ext/zhetrs.c
new file mode 100644
index 0000000..89fe385
--- /dev/null
+++ b/ext/zhetrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zhetrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zhetrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zhetrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.zhetrs( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zhetrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zhetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhetrs", rblapack_zhetrs, -1);
+}
diff --git a/ext/zhetrs2.c b/ext/zhetrs2.c
new file mode 100644
index 0000000..b19354f
--- /dev/null
+++ b/ext/zhetrs2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID zhetrs2_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, real* work, integer* info);
+
+
+static VALUE
+rblapack_zhetrs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zhetrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRS2 solves a system of linear equations A*X = B with a real\n* Hermitian matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 info, b = NumRu::Lapack.zhetrs2( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (n));
+
+ zhetrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zhetrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhetrs2", rblapack_zhetrs2, -1);
+}
diff --git a/ext/zhfrk.c b/ext/zhfrk.c
new file mode 100644
index 0000000..c9ebbd7
--- /dev/null
+++ b/ext/zhfrk.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID zhfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, doublereal* alpha, doublecomplex* a, integer* lda, doublereal* beta, doublecomplex* c);
+
+
+static VALUE
+rblapack_zhfrk(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ integer ldc;
+
+ 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 c = NumRu::Lapack.zhfrk( transr, uplo, trans, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* ZHFRK performs one of the Hermitian rank--k operations\n*\n* C := alpha*A*conjg( A' ) + beta*C,\n*\n* or\n*\n* C := alpha*conjg( A' )*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n Hermitian\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.\n*\n* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with\n* TRANS = 'C' or 'c', K specifies the number of rows of the\n* matrix A. K must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX*16 array of DIMENSION (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n* C (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the matrix A in RFP Format. RFP Format is\n* described by TRANSR, UPLO and N. Note that the imaginary\n* parts of the diagonal elements need not be set, they are\n* assumed to be zero, and on exit they are set to zero.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.zhfrk( transr, uplo, trans, k, alpha, a, beta, c, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_k = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_a = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ alpha = NUM2DBL(rblapack_alpha);
+ beta = NUM2DBL(rblapack_beta);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
+ ldc = NA_SHAPE0(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ n = ((int)sqrtf(ldc*8+1.0f)-1)/2;
+ k = NUM2INT(rblapack_k);
+ lda = lsame_(&trans,"N") ? MAX(1,n) : MAX(1,k);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_a) != lda)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)");
+ if (NA_SHAPE1(rblapack_a) != (lsame_(&trans,"N") ? k : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ldc;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zhfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
+
+ return rblapack_c;
+}
+
+void
+init_lapack_zhfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhfrk", rblapack_zhfrk, -1);
+}
diff --git a/ext/zhgeqz.c b/ext/zhgeqz.c
new file mode 100644
index 0000000..8658fa3
--- /dev/null
+++ b/ext/zhgeqz.c
@@ -0,0 +1,208 @@
+#include "rb_lapack.h"
+
+extern VOID zhgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* t, integer* ldt, doublecomplex* alpha, doublecomplex* beta, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhgeqz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_t_out__;
+ doublecomplex *t_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+ doublereal *rwork;
+
+ integer ldh;
+ integer n;
+ integer ldt;
+ integer ldq;
+ integer ldz;
+
+ 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 alpha, beta, work, info, h, t, q, z = NumRu::Lapack.zhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the single-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a complex matrix pair (A,B):\n* \n* A = Q1*H*Z1**H, B = Q1*T*Z1**H,\n* \n* as computed by ZGGHRD.\n* \n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**H, T = Q*P*Z**H,\n* \n* where Q and Z are unitary matrices and S and P are upper triangular.\n* \n* Optionally, the unitary matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* unitary matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced\n* the matrix pair (A,B) to generalized Hessenberg form, then the output\n* matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n* Schur factorization of (A,B):\n* \n* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T)\n* (equivalently, of (A,B)) are computed as a pair of complex values\n* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an\n* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* The values of alpha and beta for the i-th eigenvalue can be read\n* directly from the generalized Schur form: alpha = S(i,i),\n* beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Computer eigenvalues and the Schur form.\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain a unitary matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper triangular\n* matrix S from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of H matches that of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of T matches that of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(i) = S(i,i) in the generalized Schur\n* factorization.\n*\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The real non-negative scalars beta that define the\n* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized\n* Schur factorization.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of right Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,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* RWORK (workspace) DOUBLE PRECISION 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* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* We assume that complex ABS works as long as its value is less than\n* overflow.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, work, info, h, t, q, z = NumRu::Lapack.zhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_compz = argv[2];
+ rblapack_ilo = argv[3];
+ rblapack_ihi = argv[4];
+ rblapack_h = argv[5];
+ rblapack_t = argv[6];
+ rblapack_q = argv[7];
+ rblapack_z = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ compz = StringValueCStr(rblapack_compz)[0];
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ n = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (8th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
+ MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ rwork = ALLOC_N(doublereal, (n));
+
+ zhgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alpha, beta, q, &ldq, z, &ldz, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_zhgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhgeqz", rblapack_zhgeqz, -1);
+}
diff --git a/ext/zhpcon.c b/ext/zhpcon.c
new file mode 100644
index 0000000..72edbed
--- /dev/null
+++ b/ext/zhpcon.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID zhpcon_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zhpcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *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 rcond, info = NumRu::Lapack.zhpcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPCON estimates the reciprocal of the condition number of a complex\n* Hermitian packed matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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.zhpcon( uplo, ap, ipiv, anorm, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zhpcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zhpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpcon", rblapack_zhpcon, -1);
+}
diff --git a/ext/zhpev.c b/ext/zhpev.c
new file mode 100644
index 0000000..cb65485
--- /dev/null
+++ b/ext/zhpev.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID zhpev_(char* jobz, char* uplo, integer* n, doublecomplex* ap, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhpev(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap = NumRu::Lapack.zhpev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.zhpev( jobz, uplo, ap, [: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_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
+ ldap = NA_SHAPE0(rblapack_ap);
+ if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(doublecomplex, (MAX(1, 2*n-1)));
+ rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
+
+ zhpev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zhpev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpev", rblapack_zhpev, -1);
+}
diff --git a/ext/zhpevd.c b/ext/zhpevd.c
new file mode 100644
index 0000000..db1541f
--- /dev/null
+++ b/ext/zhpevd.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID zhpevd_(char* jobz, char* uplo, integer* n, doublecomplex* ap, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zhpevd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, work, rwork, iwork, info, ap = NumRu::Lapack.zhpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ap = NumRu::Lapack.zhpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 6) {
+ rblapack_lwork = argv[3];
+ rblapack_lrwork = argv[4];
+ rblapack_liwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
+ ldap = NA_SHAPE0(rblapack_ap);
+ if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zhpevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zhpevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpevd", rblapack_zhpevd, -1);
+}
diff --git a/ext/zhpevx.c b/ext/zhpevx.c
new file mode 100644
index 0000000..c830a6c
--- /dev/null
+++ b/ext/zhpevx.c
@@ -0,0 +1,144 @@
+#include "rb_lapack.h"
+
+extern VOID zhpevx_(char* jobz, char* range, char* uplo, integer* n, doublecomplex* ap, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_zhpevx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap = NumRu::Lapack.zhpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A in packed storage.\n* Eigenvalues/vectors can be selected by specifying either a range of\n* values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and\n* the index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.zhpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ zhpevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zhpevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpevx", rblapack_zhpevx, -1);
+}
diff --git a/ext/zhpgst.c b/ext/zhpgst.c
new file mode 100644
index 0000000..836e684
--- /dev/null
+++ b/ext/zhpgst.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID zhpgst_(integer* itype, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, integer* info);
+
+
+static VALUE
+rblapack_zhpgst(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_bp;
+ doublecomplex *bp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *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.zhpgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by ZPPTRF.\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, ap = NumRu::Lapack.zhpgst( itype, uplo, n, ap, bp, [: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_itype = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
+ 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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zhpgst_(&itype, &uplo, &n, ap, bp, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zhpgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpgst", rblapack_zhpgst, -1);
+}
diff --git a/ext/zhpgv.c b/ext/zhpgv.c
new file mode 100644
index 0000000..7462ecb
--- /dev/null
+++ b/ext/zhpgv.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID zhpgv_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhpgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_bp;
+ doublecomplex *bp;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ VALUE rblapack_bp_out__;
+ doublecomplex *bp_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, info, ap, bp = NumRu::Lapack.zhpgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPPTRF or ZHPEV returned an error code:\n* <= N: if INFO = i, ZHPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEV, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.zhpgv( itype, jobz, uplo, ap, bp, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublecomplex*);
+ MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(doublecomplex, (MAX(1, 2*n-1)));
+ rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
+
+ zhpgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_zhpgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpgv", rblapack_zhpgv, -1);
+}
diff --git a/ext/zhpgvd.c b/ext/zhpgvd.c
new file mode 100644
index 0000000..754e240
--- /dev/null
+++ b/ext/zhpgvd.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+extern VOID zhpgvd_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zhpgvd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_bp;
+ doublecomplex *bp;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ VALUE rblapack_bp_out__;
+ doublecomplex *bp_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 w, z, iwork, info, ap, bp = NumRu::Lapack.zhpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: ZPPTRF or ZHPEVD returned an error code:\n* <= N: if INFO = i, ZHPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEVD, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, z, iwork, info, ap, bp = NumRu::Lapack.zhpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 8)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_bp = argv[4];
+ if (argc == 8) {
+ rblapack_lwork = argv[5];
+ rblapack_lrwork = argv[6];
+ rblapack_liwork = argv[7];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ jobz = StringValueCStr(rblapack_jobz)[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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ if (rblapack_lwork == Qnil)
+ lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublecomplex*);
+ MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
+ rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
+
+ zhpgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_zhpgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpgvd", rblapack_zhpgvd, -1);
+}
diff --git a/ext/zhpgvx.c b/ext/zhpgvx.c
new file mode 100644
index 0000000..4b1ed43
--- /dev/null
+++ b/ext/zhpgvx.c
@@ -0,0 +1,170 @@
+#include "rb_lapack.h"
+
+extern VOID zhpgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_zhpgvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_itype;
+ integer itype;
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_bp;
+ doublecomplex *bp;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ VALUE rblapack_bp_out__;
+ doublecomplex *bp_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer ldap;
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, ifail, info, ap, bp = NumRu::Lapack.zhpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite. Eigenvalues and eigenvectors can be selected by\n* specifying either a range of values or a range of indices for the\n* desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPPTRF or ZHPEVX returned an error code:\n* <= N: if INFO = i, ZHPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEVX, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.zhpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [: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_itype = argv[0];
+ rblapack_jobz = argv[1];
+ rblapack_range = argv[2];
+ rblapack_uplo = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_bp = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vu = argv[7];
+ rblapack_il = argv[8];
+ rblapack_iu = argv[9];
+ rblapack_abstol = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ itype = NUM2INT(rblapack_itype);
+ range = StringValueCStr(rblapack_range)[0];
+ 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);
+ ldap = NA_SHAPE0(rblapack_ap);
+ if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_bp))
+ rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
+ if (NA_RANK(rblapack_bp) != 1)
+ rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
+ rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
+ bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
+ iu = NUM2INT(rblapack_iu);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ vu = NUM2DBL(rblapack_vu);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&jobz,"N") ? 0 : n;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublecomplex*);
+ MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rblapack_bp));
+ rblapack_bp = rblapack_bp_out__;
+ bp = bp_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (7*n));
+ iwork = ALLOC_N(integer, (5*n));
+
+ zhpgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
+}
+
+void
+init_lapack_zhpgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpgvx", rblapack_zhpgvx, -1);
+}
diff --git a/ext/zhprfs.c b/ext/zhprfs.c
new file mode 100644
index 0000000..bb3b7d6
--- /dev/null
+++ b/ext/zhprfs.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID zhprfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_afp;
+ doublecomplex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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.zhprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by ZHPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZHPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zhprfs( uplo, ap, afp, ipiv, 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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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 (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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ 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);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zhprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zhprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhprfs", rblapack_zhprfs, -1);
+}
diff --git a/ext/zhpsv.c b/ext/zhpsv.c
new file mode 100644
index 0000000..4f04ee0
--- /dev/null
+++ b/ext/zhpsv.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID zhpsv_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zhpsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+ 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 ipiv, info, ap, b = NumRu::Lapack.zhpsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is Hermitian and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZHPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPTRF, ZHPTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.zhpsv( uplo, ap, b, [: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_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ n = ldb;
+ 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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zhpsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_zhpsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpsv", rblapack_zhpsv, -1);
+}
diff --git a/ext/zhpsvx.c b/ext/zhpsvx.c
new file mode 100644
index 0000000..5ed7a46
--- /dev/null
+++ b/ext/zhpsvx.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID zhpsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zhpsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_afp;
+ doublecomplex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_afp_out__;
+ doublecomplex *afp_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zhpsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n* A = L*D*L**H to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N Hermitian matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHPTRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zhpsvx( fact, uplo, ap, afp, ipiv, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ ldx = MAX(1,n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublecomplex*);
+ MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zhpsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
+}
+
+void
+init_lapack_zhpsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhpsvx", rblapack_zhpsvx, -1);
+}
diff --git a/ext/zhptrd.c b/ext/zhptrd.c
new file mode 100644
index 0000000..5edffcd
--- /dev/null
+++ b/ext/zhptrd.c
@@ -0,0 +1,100 @@
+#include "rb_lapack.h"
+
+extern VOID zhptrd_(char* uplo, integer* n, doublecomplex* ap, doublereal* d, doublereal* e, doublecomplex* tau, integer* info);
+
+
+static VALUE
+rblapack_zhptrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+
+ 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 d, e, tau, info, ap = NumRu::Lapack.zhptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRD reduces a complex Hermitian matrix A stored in packed form to\n* real symmetric tridiagonal form T by a unitary similarity\n* transformation: Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.zhptrd( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zhptrd_(&uplo, &n, ap, d, e, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zhptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhptrd", rblapack_zhptrd, -1);
+}
diff --git a/ext/zhptrf.c b/ext/zhptrf.c
new file mode 100644
index 0000000..0a12698
--- /dev/null
+++ b/ext/zhptrf.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID zhptrf_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zhptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+
+ 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 ipiv, info, ap = NumRu::Lapack.zhptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRF computes the factorization of a complex Hermitian packed\n* matrix A using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.zhptrf( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zhptrf_(&uplo, &n, ap, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zhptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhptrf", rblapack_zhptrf, -1);
+}
diff --git a/ext/zhptri.c b/ext/zhptri.c
new file mode 100644
index 0000000..e93f255
--- /dev/null
+++ b/ext/zhptri.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID zhptri_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zhptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ doublecomplex *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 info, ap = NumRu::Lapack.zhptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRI computes the inverse of a complex Hermitian indefinite matrix\n* A in packed storage using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZHPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* WORK (workspace) COMPLEX*16 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zhptri( uplo, ap, ipiv, [: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_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zhptri_(&uplo, &n, ap, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zhptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhptri", rblapack_zhptri, -1);
+}
diff --git a/ext/zhptrs.c b/ext/zhptrs.c
new file mode 100644
index 0000000..01a5734
--- /dev/null
+++ b/ext/zhptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID zhptrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zhptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zhptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A stored in packed format using the factorization\n* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.zhptrs( uplo, ap, ipiv, b, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zhptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zhptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhptrs", rblapack_zhptrs, -1);
+}
diff --git a/ext/zhsein.c b/ext/zhsein.c
new file mode 100644
index 0000000..a694c8a
--- /dev/null
+++ b/ext/zhsein.c
@@ -0,0 +1,185 @@
+#include "rb_lapack.h"
+
+extern VOID zhsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, doublecomplex* h, integer* ldh, doublecomplex* w, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* mm, integer* m, doublecomplex* work, doublereal* rwork, integer* ifaill, integer* ifailr, integer* info);
+
+
+static VALUE
+rblapack_zhsein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_eigsrc;
+ char eigsrc;
+ VALUE rblapack_initv;
+ char initv;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_ifaill;
+ integer *ifaill;
+ VALUE rblapack_ifailr;
+ integer *ifailr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_w_out__;
+ doublecomplex *w_out__;
+ VALUE rblapack_vl_out__;
+ doublecomplex *vl_out__;
+ VALUE rblapack_vr_out__;
+ doublecomplex *vr_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer n;
+ integer ldh;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.zhsein( side, eigsrc, initv, select, h, w, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* ZHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a complex upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in W:\n* = 'Q': the eigenvalues were found using ZHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows ZHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, ZHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* eigenvector corresponding to the eigenvalue W(j),\n* SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX*16 array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the eigenvalues of H.\n* On exit, the real parts of W may have been altered since\n* close eigenvalues are perturbed slightly in searching for\n* independent eigenvectors.\n*\n* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors (= the number of .TRUE. elements in\n* SELECT).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.zhsein( side, eigsrc, initv, select, h, w, vl, vr, [: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_side = argv[0];
+ rblapack_eigsrc = argv[1];
+ rblapack_initv = argv[2];
+ rblapack_select = argv[3];
+ rblapack_h = argv[4];
+ rblapack_w = argv[5];
+ rblapack_vl = argv[6];
+ rblapack_vr = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ initv = StringValueCStr(rblapack_initv)[0];
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ mm = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ eigsrc = StringValueCStr(rblapack_eigsrc)[0];
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (6th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_w) != NA_DCOMPLEX)
+ rblapack_w = na_change_type(rblapack_w, NA_DCOMPLEX);
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (8th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (8th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublecomplex*);
+ MEMCPY(w_out__, w, doublecomplex, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublecomplex*);
+ MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublecomplex*);
+ MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(doublecomplex, (n*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zhsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, w, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, ifaill, ifailr, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_w, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_zhsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhsein", rblapack_zhsein, -1);
+}
diff --git a/ext/zhseqr.c b/ext/zhseqr.c
new file mode 100644
index 0000000..52bc22f
--- /dev/null
+++ b/ext/zhseqr.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID zhseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zhseqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer ldh;
+ 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 w, work, info, h, z = NumRu::Lapack.zhseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an unitary matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to ZGEBAL, and then passed to ZGEHRD\n* when the matrix output by ZGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', H contains the upper\n* triangular matrix T from the Schur decomposition (the\n* Schur form). If INFO = 0 and JOB = 'E', the contents of\n* H are unspecified on exit. (The output value of H when\n* INFO.GT.0 is given under the description of INFO below.)\n*\n* Unlike earlier versions of ZHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues. If JOB = 'S', the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the unitary matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the unitary matrix generated by ZUNGHR\n* after the call to ZGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then ZHSEQR does a workspace query.\n* In this case, ZHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, ZHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* ZLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.zhseqr( job, compz, ilo, ihi, h, z, ldz, [: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_job = argv[0];
+ rblapack_compz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_z = argv[5];
+ rblapack_ldz = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ ldz = NUM2INT(rblapack_ldz);
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
+ if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = lsame_(&compz,"N") ? 0 : ldz;
+ shape[1] = lsame_(&compz,"N") ? 0 : n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zhseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, w, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zhseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zhseqr", rblapack_zhseqr, -1);
+}
diff --git a/ext/zla_gbamv.c b/ext/zla_gbamv.c
new file mode 100644
index 0000000..a46bdcb
--- /dev/null
+++ b/ext/zla_gbamv.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID zla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, doublereal* alpha, doublereal* ab, integer* ldab, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);
+
+
+static VALUE
+rblapack_zla_gbamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_ab;
+ doublereal *ab;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublereal *y_out__;
+
+ integer ldab;
+ 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 y = NumRu::Lapack.zla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [: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_m = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_alpha = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_x = argv[6];
+ rblapack_incx = argv[7];
+ rblapack_beta = argv[8];
+ rblapack_y = argv[9];
+ rblapack_incy = argv[10];
+ if (argc == 11) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+ kl = NUM2INT(rblapack_kl);
+ alpha = NUM2DBL(rblapack_alpha);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ beta = NUM2DBL(rblapack_beta);
+ ldab = MAX(1, m);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_ab) != ldab)
+ rb_raise(rb_eRuntimeError, "shape 0 of ab must be MAX(1, m)");
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
+ ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (10th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ zla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_zla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gbamv", rblapack_zla_gbamv, -1);
+}
diff --git a/ext/zla_gbrcond_c.c b/ext/zla_gbrcond_c.c
new file mode 100644
index 0000000..ab6e1d5
--- /dev/null
+++ b/ext/zla_gbrcond_c.c
@@ -0,0 +1,142 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_gbrcond_c_(char* trans, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_gbrcond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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, __out__ = NumRu::Lapack.zla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GBRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_c = argv[6];
+ rblapack_capply = argv[7];
+ rblapack_work = argv[8];
+ rblapack_rwork = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (10th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (9th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ capply = (rblapack_capply == Qtrue);
+
+ __out__ = zla_gbrcond_c_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_gbrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gbrcond_c", rblapack_zla_gbrcond_c, -1);
+}
diff --git a/ext/zla_gbrcond_x.c b/ext/zla_gbrcond_x.c
new file mode 100644
index 0000000..c0b7356
--- /dev/null
+++ b/ext/zla_gbrcond_x.c
@@ -0,0 +1,138 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_gbrcond_x_(char* trans, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_gbrcond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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, __out__ = NumRu::Lapack.zla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GBRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_trans = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_x = argv[6];
+ rblapack_work = argv[7];
+ rblapack_rwork = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of afb");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (9th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ kl = NUM2INT(rblapack_kl);
+ 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 1 of afb");
+ 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_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (8th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_gbrcond_x_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_gbrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gbrcond_x", rblapack_zla_gbrcond_x, -1);
+}
diff --git a/ext/zla_gbrfsx_extended.c b/ext/zla_gbrfsx_extended.c
new file mode 100644
index 0000000..0a63e00
--- /dev/null
+++ b/ext/zla_gbrfsx_extended.c
@@ -0,0 +1,295 @@
+#include "rb_lapack.h"
+
+extern VOID zla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_zla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_res;
+ doublecomplex *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublecomplex *dy;
+ VALUE rblapack_y_tail;
+ doublecomplex *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ doublereal *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ doublereal *err_bnds_comp_out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* AB (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGBTRF.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 23 && argc != 23)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 23)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_kl = argv[2];
+ rblapack_ku = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_afb = argv[5];
+ rblapack_ipiv = argv[6];
+ rblapack_colequ = argv[7];
+ rblapack_c = argv[8];
+ rblapack_b = argv[9];
+ rblapack_y = argv[10];
+ rblapack_n_norms = argv[11];
+ rblapack_err_bnds_norm = argv[12];
+ rblapack_err_bnds_comp = argv[13];
+ rblapack_res = argv[14];
+ rblapack_ayb = argv[15];
+ rblapack_dy = argv[16];
+ rblapack_y_tail = argv[17];
+ rblapack_rcond = argv[18];
+ rblapack_ithresh = argv[19];
+ rblapack_rthresh = argv[20];
+ rblapack_dz_ub = argv[21];
+ rblapack_ignore_cwise = argv[22];
+ if (argc == 23) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ ldab = n;
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ colequ = (rblapack_colequ == Qtrue);
+ 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);
+ nrhs = 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*);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (14th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (14th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ rcond = NUM2DBL(rblapack_rcond);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ trans_type = NUM2INT(rblapack_trans_type);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (11th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ if (NA_SHAPE1(rblapack_y) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ n = ldab;
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be ldab");
+ 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_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (13th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (16th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be ldab");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (18th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (18th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be ldab");
+ if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
+ ldafb = MAX(1,n);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_afb) != ldafb)
+ rb_raise(rb_eRuntimeError, "shape 0 of afb must be MAX(1,n)");
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be ldab");
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (15th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be ldab");
+ if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be ldab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (17th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be ldab");
+ if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ zla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_zla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gbrfsx_extended", rblapack_zla_gbrfsx_extended, -1);
+}
diff --git a/ext/zla_gbrpvgrw.c b/ext/zla_gbrpvgrw.c
new file mode 100644
index 0000000..e5596c9
--- /dev/null
+++ b/ext/zla_gbrpvgrw.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb);
+
+
+static VALUE
+rblapack_zla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+
+ 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 __out__ = NumRu::Lapack.zla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* ZLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_gbrpvgrw( kl, ku, ncols, ab, afb, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ncols = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ ku = NUM2INT(rblapack_ku);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+
+ __out__ = zla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gbrpvgrw", rblapack_zla_gbrpvgrw, -1);
+}
diff --git a/ext/zla_geamv.c b/ext/zla_geamv.c
new file mode 100644
index 0000000..d7f6ab8
--- /dev/null
+++ b/ext/zla_geamv.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID zla_geamv_(integer* trans, integer* m, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);
+
+
+static VALUE
+rblapack_zla_geamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ integer trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_x;
+ doublereal *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 y = NumRu::Lapack.zla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX*16 array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X - COMPLEX*16 array of DIMENSION at least\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_trans = argv[0];
+ rblapack_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_a = argv[3];
+ rblapack_x = argv[4];
+ rblapack_incx = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_y = argv[7];
+ rblapack_incy = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = NUM2INT(rblapack_trans);
+ alpha = NUM2DBL(rblapack_alpha);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ m = NUM2INT(rblapack_m);
+ beta = NUM2DBL(rblapack_beta);
+ lda = MAX(1, 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);
+ if (NA_SHAPE0(rblapack_a) != lda)
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be MAX(1, m)");
+ 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*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_DFLOAT)
+ rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
+ x = NA_PTR_TYPE(rblapack_x, doublereal*);
+ {
+ int shape[1];
+ shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ zla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_zla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_geamv", rblapack_zla_geamv, -1);
+}
diff --git a/ext/zla_gercond_c.c b/ext/zla_gercond_c.c
new file mode 100644
index 0000000..8448ade
--- /dev/null
+++ b/ext/zla_gercond_c.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_gercond_c_(char* trans, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_gercond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_c = argv[4];
+ rblapack_capply = argv[5];
+ rblapack_work = argv[6];
+ rblapack_rwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_gercond_c_(&trans, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_gercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gercond_c", rblapack_zla_gercond_c, -1);
+}
diff --git a/ext/zla_gercond_x.c b/ext/zla_gercond_x.c
new file mode 100644
index 0000000..f97f91f
--- /dev/null
+++ b/ext/zla_gercond_x.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_gercond_x_(char* trans, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_gercond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_gercond_x( trans, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gercond_x( trans, a, af, ipiv, x, work, rwork, [: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_trans = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_x = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_gercond_x_(&trans, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_gercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gercond_x", rblapack_zla_gercond_x, -1);
+}
diff --git a/ext/zla_gerfsx_extended.c b/ext/zla_gerfsx_extended.c
new file mode 100644
index 0000000..00c1f36
--- /dev/null
+++ b/ext/zla_gerfsx_extended.c
@@ -0,0 +1,281 @@
+#include "rb_lapack.h"
+
+extern VOID zla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* errs_n, doublereal* errs_c, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_zla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_trans_type;
+ integer trans_type;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_errs_n;
+ doublereal *errs_n;
+ VALUE rblapack_errs_c;
+ doublereal *errs_c;
+ VALUE rblapack_res;
+ doublecomplex *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublecomplex *dy;
+ VALUE rblapack_y_tail;
+ doublecomplex *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_out__;
+ VALUE rblapack_errs_n_out__;
+ doublereal *errs_n_out__;
+ VALUE rblapack_errs_c_out__;
+ doublereal *errs_c_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_norms;
+
+ 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 berr_out, info, y, errs_n, errs_c = NumRu::Lapack.zla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, errs_n, errs_c = NumRu::Lapack.zla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 20 && argc != 20)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_trans_type = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_errs_n = argv[9];
+ rblapack_errs_c = argv[10];
+ rblapack_res = argv[11];
+ rblapack_ayb = argv[12];
+ rblapack_dy = argv[13];
+ rblapack_y_tail = argv[14];
+ rblapack_rcond = argv[15];
+ rblapack_ithresh = argv[16];
+ rblapack_rthresh = argv[17];
+ rblapack_dz_ub = argv[18];
+ rblapack_ignore_cwise = argv[19];
+ if (argc == 20) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ 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_res))
+ rb_raise(rb_eArgError, "res (12th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
+ rcond = NUM2DBL(rblapack_rcond);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ trans_type = NUM2INT(rblapack_trans_type);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ n_norms = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_errs_n))
+ rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
+ if (NA_RANK(rblapack_errs_n) != 2)
+ rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_errs_n) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_errs_n) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be 3");
+ if (NA_TYPE(rblapack_errs_n) != NA_DFLOAT)
+ rblapack_errs_n = na_change_type(rblapack_errs_n, NA_DFLOAT);
+ errs_n = NA_PTR_TYPE(rblapack_errs_n, doublereal*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_errs_c))
+ rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
+ if (NA_RANK(rblapack_errs_c) != 2)
+ rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_errs_c) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of errs_c must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_errs_c) != n_norms)
+ rb_raise(rb_eRuntimeError, "shape 1 of errs_c must be 3");
+ if (NA_TYPE(rblapack_errs_c) != NA_DFLOAT)
+ rblapack_errs_c = na_change_type(rblapack_errs_c, NA_DFLOAT);
+ errs_c = NA_PTR_TYPE(rblapack_errs_c, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_errs_n_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ errs_n_out__ = NA_PTR_TYPE(rblapack_errs_n_out__, doublereal*);
+ MEMCPY(errs_n_out__, errs_n, doublereal, NA_TOTAL(rblapack_errs_n));
+ rblapack_errs_n = rblapack_errs_n_out__;
+ errs_n = errs_n_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_norms;
+ rblapack_errs_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ errs_c_out__ = NA_PTR_TYPE(rblapack_errs_c_out__, doublereal*);
+ MEMCPY(errs_c_out__, errs_c, doublereal, NA_TOTAL(rblapack_errs_c));
+ rblapack_errs_c = rblapack_errs_c_out__;
+ errs_c = errs_c_out__;
+
+ zla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_errs_n, rblapack_errs_c);
+}
+
+void
+init_lapack_zla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_gerfsx_extended", rblapack_zla_gerfsx_extended, -1);
+}
diff --git a/ext/zla_heamv.c b/ext/zla_heamv.c
new file mode 100644
index 0000000..b756ad4
--- /dev/null
+++ b/ext/zla_heamv.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID zla_heamv_(integer* uplo, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublecomplex* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);
+
+
+static VALUE
+rblapack_zla_heamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ integer uplo;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 y = NumRu::Lapack.zla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX*16 array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X - COMPLEX*16 array of DIMENSION at least\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = NUM2INT(rblapack_uplo);
+ 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);
+ if (lda != (MAX(1, n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
+ 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*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha = NUM2DBL(rblapack_alpha);
+ beta = NUM2DBL(rblapack_beta);
+ lda = MAX(1, n);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + (n-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + (n-1)*abs(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_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ zla_heamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_zla_heamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_heamv", rblapack_zla_heamv, -1);
+}
diff --git a/ext/zla_hercond_c.c b/ext/zla_hercond_c.c
new file mode 100644
index 0000000..434efc0
--- /dev/null
+++ b/ext/zla_hercond_c.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_hercond_c_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_hercond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_HERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [: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_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_c = argv[4];
+ rblapack_capply = argv[5];
+ rblapack_work = argv[6];
+ rblapack_rwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_hercond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_hercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_hercond_c", rblapack_zla_hercond_c, -1);
+}
diff --git a/ext/zla_hercond_x.c b/ext/zla_hercond_x.c
new file mode 100644
index 0000000..34113c4
--- /dev/null
+++ b/ext/zla_hercond_x.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_hercond_x_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_hercond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_HERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_x = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_hercond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_hercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_hercond_x", rblapack_zla_hercond_x, -1);
+}
diff --git a/ext/zla_herfsx_extended.c b/ext/zla_herfsx_extended.c
new file mode 100644
index 0000000..b7d83f5
--- /dev/null
+++ b/ext/zla_herfsx_extended.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID zla_herfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_zla_herfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_res;
+ doublecomplex *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublecomplex *dy;
+ VALUE rblapack_y_tail;
+ doublecomplex *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ doublereal *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ doublereal *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_HERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZHERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZHETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZHETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 21 && argc != 21)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_n_norms = argv[9];
+ rblapack_err_bnds_norm = argv[10];
+ rblapack_err_bnds_comp = argv[11];
+ rblapack_res = argv[12];
+ rblapack_ayb = argv[13];
+ rblapack_dy = argv[14];
+ rblapack_y_tail = argv[15];
+ rblapack_rcond = argv[16];
+ rblapack_ithresh = argv[17];
+ rblapack_rthresh = argv[18];
+ rblapack_dz_ub = argv[19];
+ rblapack_ignore_cwise = argv[20];
+ if (argc == 21) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ 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_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (13th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
+ rcond = NUM2DBL(rblapack_rcond);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ colequ = (rblapack_colequ == Qtrue);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ zla_herfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_zla_herfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_herfsx_extended", rblapack_zla_herfsx_extended, -1);
+}
diff --git a/ext/zla_herpvgrw.c b/ext/zla_herpvgrw.c
new file mode 100644
index 0000000..9895c90
--- /dev/null
+++ b/ext/zla_herpvgrw.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_herpvgrw_(char* uplo, integer* n, integer* info, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* work);
+
+
+static VALUE
+rblapack_zla_herpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.zla_herpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* ZLA_HERPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from ZHETRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER, LSAME\n COMPLEX*16 ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, ZLASET\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX, MIN\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_herpvgrw( uplo, info, a, af, ipiv, work, [: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_info = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_work = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ info = NUM2INT(rblapack_info);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_herpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zla_herpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_herpvgrw", rblapack_zla_herpvgrw, -1);
+}
diff --git a/ext/zla_lin_berr.c b/ext/zla_lin_berr.c
new file mode 100644
index 0000000..4b1145d
--- /dev/null
+++ b/ext/zla_lin_berr.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID zla_lin_berr_(integer* n, integer* nz, integer* nrhs, doublereal* res, doublereal* ayb, doublecomplex* berr);
+
+
+static VALUE
+rblapack_zla_lin_berr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nz;
+ integer nz;
+ VALUE rblapack_res;
+ doublereal *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_berr;
+ doublecomplex *berr;
+
+ integer n;
+ integer nrhs;
+
+ 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 berr = NumRu::Lapack.zla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* ZLA_LIN_BERR computes componentwise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z.\n*\n\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see zla_gerfsx_extended.f).\n* \n* BERR (output) COMPLEX*16 array, dimension (NRHS)\n* The componentwise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION TMP\n INTEGER I, J\n COMPLEX*16 CDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX\n* ..\n* .. External Functions ..\n EXTERNAL DLAMCH\n DOUBLE PRECISION DLAMCH\n DOUBLE PRECISION SAFE1\n* ..\n* .. Statement Functions ..\n COMPLEX*16 CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr = NumRu::Lapack.zla_lin_berr( nz, res, ayb, [: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_nz = argv[0];
+ rblapack_res = argv[1];
+ rblapack_ayb = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nz = NUM2INT(rblapack_nz);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 2)
+ rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
+ n = NA_SHAPE0(rblapack_ayb);
+ nrhs = NA_SHAPE1(rblapack_ayb);
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (2th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 2)
+ rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
+ if (NA_SHAPE1(rblapack_res) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
+ if (NA_TYPE(rblapack_res) != NA_DFLOAT)
+ rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
+ res = NA_PTR_TYPE(rblapack_res, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublecomplex*);
+
+ zla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
+
+ return rblapack_berr;
+}
+
+void
+init_lapack_zla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_lin_berr", rblapack_zla_lin_berr, -1);
+}
diff --git a/ext/zla_porcond_c.c b/ext/zla_porcond_c.c
new file mode 100644
index 0000000..f6aaecf
--- /dev/null
+++ b/ext/zla_porcond_c.c
@@ -0,0 +1,122 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_porcond_c_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_porcond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_PORCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_c = argv[3];
+ rblapack_capply = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_porcond_c_(&uplo, &n, a, &lda, af, &ldaf, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_porcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_porcond_c", rblapack_zla_porcond_c, -1);
+}
diff --git a/ext/zla_porcond_x.c b/ext/zla_porcond_x.c
new file mode 100644
index 0000000..3e3b46d
--- /dev/null
+++ b/ext/zla_porcond_x.c
@@ -0,0 +1,118 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_porcond_x_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_porcond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_porcond_x( uplo, a, af, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_PORCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_porcond_x( uplo, a, af, x, work, rwork, [: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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_x = argv[3];
+ rblapack_work = argv[4];
+ rblapack_rwork = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (6th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (5th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_porcond_x_(&uplo, &n, a, &lda, af, &ldaf, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_porcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_porcond_x", rblapack_zla_porcond_x, -1);
+}
diff --git a/ext/zla_porfsx_extended.c b/ext/zla_porfsx_extended.c
new file mode 100644
index 0000000..cd25484
--- /dev/null
+++ b/ext/zla_porfsx_extended.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID zla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_zla_porfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_res;
+ doublecomplex *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublecomplex *dy;
+ VALUE rblapack_y_tail;
+ doublecomplex *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ doublereal *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ doublereal *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 20 && argc != 20)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_colequ = argv[4];
+ rblapack_c = argv[5];
+ rblapack_b = argv[6];
+ rblapack_y = argv[7];
+ rblapack_n_norms = argv[8];
+ rblapack_err_bnds_norm = argv[9];
+ rblapack_err_bnds_comp = argv[10];
+ rblapack_res = argv[11];
+ rblapack_ayb = argv[12];
+ rblapack_dy = argv[13];
+ rblapack_y_tail = argv[14];
+ rblapack_rcond = argv[15];
+ rblapack_ithresh = argv[16];
+ rblapack_rthresh = argv[17];
+ rblapack_dz_ub = argv[18];
+ rblapack_ignore_cwise = argv[19];
+ if (argc == 20) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ colequ = (rblapack_colequ == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
+ if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (12th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ if (NA_SHAPE1(rblapack_y) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ rcond = NUM2DBL(rblapack_rcond);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ zla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_zla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_porfsx_extended", rblapack_zla_porfsx_extended, -1);
+}
diff --git a/ext/zla_porpvgrw.c b/ext/zla_porpvgrw.c
new file mode 100644
index 0000000..658f477
--- /dev/null
+++ b/ext/zla_porpvgrw.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_porpvgrw_(char* uplo, integer* ncols, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublecomplex* work);
+
+
+static VALUE
+rblapack_zla_porpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.zla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* ZLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n COMPLEX*16 ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, ZLASET\n LOGICAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_porpvgrw( uplo, ncols, a, af, work, [: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_ncols = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_work = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (5th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_porpvgrw", rblapack_zla_porpvgrw, -1);
+}
diff --git a/ext/zla_rpvgrw.c b/ext/zla_rpvgrw.c
new file mode 100644
index 0000000..11f0466
--- /dev/null
+++ b/ext/zla_rpvgrw.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_rpvgrw_(integer* n, integer* ncols, doublereal* a, integer* lda, doublereal* af, integer* ldaf);
+
+
+static VALUE
+rblapack_zla_rpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ncols;
+ integer ncols;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_af;
+ doublereal *af;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.zla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n* \n* ZLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN, ABS, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_rpvgrw( ncols, a, af, [: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_ncols = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ncols = NUM2INT(rblapack_ncols);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DFLOAT)
+ rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
+ af = NA_PTR_TYPE(rblapack_af, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DFLOAT)
+ rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
+ a = NA_PTR_TYPE(rblapack_a, doublereal*);
+
+ __out__ = zla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_rpvgrw", rblapack_zla_rpvgrw, -1);
+}
diff --git a/ext/zla_syamv.c b/ext/zla_syamv.c
new file mode 100644
index 0000000..bd41457
--- /dev/null
+++ b/ext/zla_syamv.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID zla_syamv_(integer* uplo, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublecomplex* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);
+
+
+static VALUE
+rblapack_zla_syamv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ integer uplo;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_y;
+ doublereal *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublereal *y_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 y = NumRu::Lapack.zla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX*16 array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X - COMPLEX*16 array of DIMENSION at least\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = NUM2INT(rblapack_uplo);
+ 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);
+ if (lda != (MAX(1, n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
+ 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*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha = NUM2DBL(rblapack_alpha);
+ beta = NUM2DBL(rblapack_beta);
+ lda = MAX(1, n);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-1)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(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_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_DFLOAT)
+ rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
+ y = NA_PTR_TYPE(rblapack_y, doublereal*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
+ MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
+ rblapack_y = rblapack_y_out__;
+ y = y_out__;
+
+ zla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_zla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_syamv", rblapack_zla_syamv, -1);
+}
diff --git a/ext/zla_syrcond_c.c b/ext/zla_syrcond_c.c
new file mode 100644
index 0000000..6b15e0c
--- /dev/null
+++ b/ext/zla_syrcond_c.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_syrcond_c_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_syrcond_c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_capply;
+ logical capply;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_SYRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [: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_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_c = argv[4];
+ rblapack_capply = argv[5];
+ rblapack_work = argv[6];
+ rblapack_rwork = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_rwork))
+ rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ capply = (rblapack_capply == Qtrue);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (7th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_syrcond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_syrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_syrcond_c", rblapack_zla_syrcond_c, -1);
+}
diff --git a/ext/zla_syrcond_x.c b/ext/zla_syrcond_x.c
new file mode 100644
index 0000000..470cc4b
--- /dev/null
+++ b/ext/zla_syrcond_x.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_syrcond_x_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);
+
+
+static VALUE
+rblapack_zla_syrcond_x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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, __out__ = NumRu::Lapack.zla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_SYRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_x = argv[4];
+ rblapack_work = argv[5];
+ rblapack_rwork = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
+ 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_rwork))
+ rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
+ if (NA_RANK(rblapack_rwork) != 1)
+ rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_rwork) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
+ if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
+ rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ 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_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_syrcond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
+
+ rblapack_info = INT2NUM(info);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rb_ary_new3(2, rblapack_info, rblapack___out__);
+}
+
+void
+init_lapack_zla_syrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_syrcond_x", rblapack_zla_syrcond_x, -1);
+}
diff --git a/ext/zla_syrfsx_extended.c b/ext/zla_syrfsx_extended.c
new file mode 100644
index 0000000..a4064c7
--- /dev/null
+++ b/ext/zla_syrfsx_extended.c
@@ -0,0 +1,283 @@
+#include "rb_lapack.h"
+
+extern VOID zla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);
+
+
+static VALUE
+rblapack_zla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_prec_type;
+ integer prec_type;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_colequ;
+ logical colequ;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_n_norms;
+ integer n_norms;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_res;
+ doublecomplex *res;
+ VALUE rblapack_ayb;
+ doublereal *ayb;
+ VALUE rblapack_dy;
+ doublecomplex *dy;
+ VALUE rblapack_y_tail;
+ doublecomplex *y_tail;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ithresh;
+ integer ithresh;
+ VALUE rblapack_rthresh;
+ doublereal rthresh;
+ VALUE rblapack_dz_ub;
+ doublereal dz_ub;
+ VALUE rblapack_ignore_cwise;
+ logical ignore_cwise;
+ VALUE rblapack_berr_out;
+ doublereal *berr_out;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_out__;
+ VALUE rblapack_err_bnds_norm_out__;
+ doublereal *err_bnds_norm_out__;
+ VALUE rblapack_err_bnds_comp_out__;
+ doublereal *err_bnds_comp_out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldy;
+ integer n_err_bnds;
+
+ 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 berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 21 && argc != 21)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
+ rblapack_prec_type = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_colequ = argv[5];
+ rblapack_c = argv[6];
+ rblapack_b = argv[7];
+ rblapack_y = argv[8];
+ rblapack_n_norms = argv[9];
+ rblapack_err_bnds_norm = argv[10];
+ rblapack_err_bnds_comp = argv[11];
+ rblapack_res = argv[12];
+ rblapack_ayb = argv[13];
+ rblapack_dy = argv[14];
+ rblapack_y_tail = argv[15];
+ rblapack_rcond = argv[16];
+ rblapack_ithresh = argv[17];
+ rblapack_rthresh = argv[18];
+ rblapack_dz_ub = argv[19];
+ rblapack_ignore_cwise = argv[20];
+ if (argc == 21) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ prec_type = NUM2INT(rblapack_prec_type);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_c))
+ rb_raise(rb_eArgError, "c (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (9th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 2)
+ rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
+ ldy = NA_SHAPE0(rblapack_y);
+ nrhs = NA_SHAPE1(rblapack_y);
+ 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_err_bnds_norm))
+ rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_norm) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
+ n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
+ if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
+ rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ if (!NA_IsNArray(rblapack_res))
+ rb_raise(rb_eArgError, "res (13th argument) must be NArray");
+ if (NA_RANK(rblapack_res) != 1)
+ rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_res) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
+ rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
+ res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
+ if (!NA_IsNArray(rblapack_dy))
+ rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
+ if (NA_RANK(rblapack_dy) != 1)
+ rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_dy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
+ rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
+ dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
+ rcond = NUM2DBL(rblapack_rcond);
+ rthresh = NUM2DBL(rblapack_rthresh);
+ ignore_cwise = (rblapack_ignore_cwise == Qtrue);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ colequ = (rblapack_colequ == Qtrue);
+ n_norms = NUM2INT(rblapack_n_norms);
+ if (!NA_IsNArray(rblapack_ayb))
+ rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
+ if (NA_RANK(rblapack_ayb) != 1)
+ rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ayb) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
+ rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
+ ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
+ ithresh = NUM2INT(rblapack_ithresh);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_err_bnds_comp))
+ rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
+ if (NA_RANK(rblapack_err_bnds_comp) != 2)
+ rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
+ if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
+ rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
+ if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
+ rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ dz_ub = NUM2DBL(rblapack_dz_ub);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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 y");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_y_tail))
+ rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
+ if (NA_RANK(rblapack_y_tail) != 1)
+ rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y_tail) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
+ rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
+ y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = nrhs;
+ rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
+ MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
+ rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
+ err_bnds_norm = err_bnds_norm_out__;
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
+ MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
+ rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
+ err_bnds_comp = err_bnds_comp_out__;
+
+ zla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
+}
+
+void
+init_lapack_zla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_syrfsx_extended", rblapack_zla_syrfsx_extended, -1);
+}
diff --git a/ext/zla_syrpvgrw.c b/ext/zla_syrpvgrw.c
new file mode 100644
index 0000000..fc8f368
--- /dev/null
+++ b/ext/zla_syrpvgrw.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern doublereal zla_syrpvgrw_(char* uplo, integer* n, integer* info, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* work);
+
+
+static VALUE
+rblapack_zla_syrpvgrw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+
+ 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 __out__ = NumRu::Lapack.zla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* ZLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from ZSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX, MIN\n* ..\n* .. External Subroutines ..\n EXTERNAL LSAME, ZLASET\n LOGICAL LSAME\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_syrpvgrw( uplo, info, a, af, ipiv, work, [: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_info = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_work = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ info = NUM2INT(rblapack_info);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_work))
+ rb_raise(rb_eArgError, "work (6th argument) must be NArray");
+ if (NA_RANK(rblapack_work) != 1)
+ rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_work) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
+ if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
+ rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+
+ __out__ = zla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_syrpvgrw", rblapack_zla_syrpvgrw, -1);
+}
diff --git a/ext/zla_wwaddw.c b/ext/zla_wwaddw.c
new file mode 100644
index 0000000..5c1fe88
--- /dev/null
+++ b/ext/zla_wwaddw.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID zla_wwaddw_(integer* n, doublecomplex* x, doublecomplex* y, doublecomplex* w);
+
+
+static VALUE
+rblapack_zla_wwaddw(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_out__;
+
+ 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 x, y = NumRu::Lapack.zla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) COMPLEX*16 array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) COMPLEX*16 array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n COMPLEX*16 S\n INTEGER I\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.zla_wwaddw( x, y, w, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ rblapack_w = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ 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_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_DCOMPLEX)
+ rblapack_w = na_change_type(rblapack_w, NA_DCOMPLEX);
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (2th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ 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__;
+
+ zla_wwaddw_(&n, x, y, w);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_zla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zla_wwaddw", rblapack_zla_wwaddw, -1);
+}
diff --git a/ext/zlabrd.c b/ext/zlabrd.c
new file mode 100644
index 0000000..1425db6
--- /dev/null
+++ b/ext/zlabrd.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID zlabrd_(integer* m, integer* n, integer* nb, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tauq, doublecomplex* taup, doublecomplex* x, integer* ldx, doublecomplex* y, integer* ldy);
+
+
+static VALUE
+rblapack_zlabrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tauq;
+ doublecomplex *tauq;
+ VALUE rblapack_taup;
+ doublecomplex *taup;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldx;
+ integer ldy;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.zlabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* ZLABRD reduces the first NB rows and columns of a complex general\n* m by n matrix A to upper or lower real bidiagonal form by a unitary\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by ZGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the unitary matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) COMPLEX*16 array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX*16 array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,M).\n*\n* Y (output) COMPLEX*16 array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.zlabrd( m, nb, a, [: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_m = argv[0];
+ rblapack_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldy = MAX(1,n);
+ nb = NUM2INT(rblapack_nb);
+ ldx = MAX(1,m);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = MAX(1,nb);
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int 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__;
+
+ zlabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
+
+ return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_zlabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlabrd", rblapack_zlabrd, -1);
+}
diff --git a/ext/zlacgv.c b/ext/zlacgv.c
new file mode 100644
index 0000000..42911f2
--- /dev/null
+++ b/ext/zlacgv.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID zlacgv_(integer* n, doublecomplex* x, integer* incx);
+
+
+static VALUE
+rblapack_zlacgv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_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 = NumRu::Lapack.zlacgv( n, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACGV( N, X, INCX )\n\n* Purpose\n* =======\n*\n* ZLACGV conjugates a complex vector of length N.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vector X. N >= 0.\n*\n* X (input/output) COMPLEX*16 array, dimension\n* (1+(N-1)*abs(INCX))\n* On entry, the vector of length N to be conjugated.\n* On exit, X is overwritten with conjg(X).\n*\n* INCX (input) INTEGER\n* The spacing between successive elements of X.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IOFF\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.zlacgv( n, x, incx, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ 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)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*abs(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__;
+
+ zlacgv_(&n, x, &incx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_zlacgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlacgv", rblapack_zlacgv, -1);
+}
diff --git a/ext/zlacn2.c b/ext/zlacn2.c
new file mode 100644
index 0000000..402b1cb
--- /dev/null
+++ b/ext/zlacn2.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zlacn2_(integer* n, doublecomplex* v, doublecomplex* x, doublereal* est, integer* kase, integer* isave);
+
+
+static VALUE
+rblapack_zlacn2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_est;
+ doublereal est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_isave;
+ integer *isave;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_isave_out__;
+ integer *isave_out__;
+ doublecomplex *v;
+
+ 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 x, est, kase, isave = NumRu::Lapack.zlacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* ZLACN2 estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX*16 array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and ZLACN2 must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to ZLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to ZLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from ZLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to ZLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* This is a thread safe version of ZLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* ZLACON ZLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.zlacn2( x, est, kase, isave, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ rblapack_isave = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ kase = NUM2INT(rblapack_kase);
+ est = NUM2DBL(rblapack_est);
+ if (!NA_IsNArray(rblapack_isave))
+ rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
+ if (NA_RANK(rblapack_isave) != 1)
+ rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isave) != (3))
+ rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
+ if (NA_TYPE(rblapack_isave) != NA_LINT)
+ rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
+ isave = NA_PTR_TYPE(rblapack_isave, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = 3;
+ rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
+ MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
+ rblapack_isave = rblapack_isave_out__;
+ isave = isave_out__;
+ v = ALLOC_N(doublecomplex, (n));
+
+ zlacn2_(&n, v, x, &est, &kase, isave);
+
+ free(v);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
+}
+
+void
+init_lapack_zlacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlacn2", rblapack_zlacn2, -1);
+}
diff --git a/ext/zlacon.c b/ext/zlacon.c
new file mode 100644
index 0000000..b8d2ec8
--- /dev/null
+++ b/ext/zlacon.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID zlacon_(integer* n, doublecomplex* v, doublecomplex* x, doublereal* est, integer* kase);
+
+
+static VALUE
+rblapack_zlacon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_est;
+ doublereal est;
+ VALUE rblapack_kase;
+ integer kase;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *v;
+
+ 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 x, est, kase = NumRu::Lapack.zlacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACON( N, V, X, EST, KASE )\n\n* Purpose\n* =======\n*\n* ZLACON estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX*16 array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and ZLACON must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to ZLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to ZLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from ZLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.zlacon( x, est, kase, [: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_x = argv[0];
+ rblapack_est = argv[1];
+ rblapack_kase = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ kase = NUM2INT(rblapack_kase);
+ est = NUM2DBL(rblapack_est);
+ {
+ int shape[1];
+ shape[0] = n;
+ 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__;
+ v = ALLOC_N(doublecomplex, (n));
+
+ zlacon_(&n, v, x, &est, &kase);
+
+ free(v);
+ rblapack_est = rb_float_new((double)est);
+ rblapack_kase = INT2NUM(kase);
+ return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
+}
+
+void
+init_lapack_zlacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlacon", rblapack_zlacon, -1);
+}
diff --git a/ext/zlacp2.c b/ext/zlacp2.c
new file mode 100644
index 0000000..4b4d3e1
--- /dev/null
+++ b/ext/zlacp2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID zlacp2_(char* uplo, integer* m, integer* n, doublereal* a, integer* lda, doublecomplex* b, integer* ldb);
+
+
+static VALUE
+rblapack_zlacp2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublereal *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.zlacp2( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* ZLACP2 copies all or part of a real two-dimensional matrix A to a\n* complex matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX*16 array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.zlacp2( uplo, m, a, [: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_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ 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*);
+ m = NUM2INT(rblapack_m);
+ ldb = MAX(1,m);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+
+ zlacp2_(&uplo, &m, &n, a, &lda, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_zlacp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlacp2", rblapack_zlacp2, -1);
+}
diff --git a/ext/zlacpy.c b/ext/zlacpy.c
new file mode 100644
index 0000000..6026bd5
--- /dev/null
+++ b/ext/zlacpy.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID zlacpy_(char* uplo, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb);
+
+
+static VALUE
+rblapack_zlacpy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.zlacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* ZLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX*16 array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.zlacpy( uplo, m, a, [: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_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = NUM2INT(rblapack_m);
+ ldb = MAX(1,m);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+
+ zlacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_zlacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlacpy", rblapack_zlacpy, -1);
+}
diff --git a/ext/zlacrm.c b/ext/zlacrm.c
new file mode 100644
index 0000000..2f5a816
--- /dev/null
+++ b/ext/zlacrm.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID zlacrm_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* b, integer* ldb, doublecomplex* c, integer* ldc, doublereal* rwork);
+
+
+static VALUE
+rblapack_zlacrm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublereal *b;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ 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.zlacrm( m, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n* Purpose\n* =======\n*\n* ZLACRM performs a very simple matrix-matrix multiplication:\n* C := A * B,\n* where A is M by N and complex; B is N by N and real;\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) COMPLEX*16 array, dimension (LDA, N)\n* A contains the M by N 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 N by N matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >=max(1,N).\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,N).\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.zlacrm( m, a, b, [: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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ n = NA_SHAPE1(rblapack_b);
+ if (NA_TYPE(rblapack_b) != NA_DFLOAT)
+ rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
+ b = NA_PTR_TYPE(rblapack_b, doublereal*);
+ 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldc = MAX(1,n);
+ {
+ int 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));
+
+ zlacrm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
+
+ free(rwork);
+ return rblapack_c;
+}
+
+void
+init_lapack_zlacrm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlacrm", rblapack_zlacrm, -1);
+}
diff --git a/ext/zlacrt.c b/ext/zlacrt.c
new file mode 100644
index 0000000..00b5115
--- /dev/null
+++ b/ext/zlacrt.c
@@ -0,0 +1,108 @@
+#include "rb_lapack.h"
+
+extern VOID zlacrt_(integer* n, doublecomplex* cx, integer* incx, doublecomplex* cy, integer* incy, doublecomplex* c, doublecomplex* s);
+
+
+static VALUE
+rblapack_zlacrt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ doublecomplex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_cy;
+ doublecomplex *cy;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_c;
+ doublecomplex c;
+ VALUE rblapack_s;
+ doublecomplex s;
+ VALUE rblapack_cx_out__;
+ doublecomplex *cx_out__;
+ VALUE rblapack_cy_out__;
+ doublecomplex *cy_out__;
+
+ 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 cx, cy = NumRu::Lapack.zlacrt( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* ZLACRT performs the operation\n*\n* ( c s )( x ) ==> ( x )\n* ( -s c )( y ) ( y )\n*\n* where c and s are complex and the vectors x and y are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector x.\n* On output, CX is overwritten with c*x + s*y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CX. INCX <> 0.\n*\n* CY (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector y.\n* On output, CY is overwritten with -s*x + c*y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCY <> 0.\n*\n* C (input) COMPLEX*16\n* S (input) COMPLEX*16\n* C and S define the matrix\n* [ C S ].\n* [ -S C ]\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX*16 CTEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.zlacrt( cx, incx, cy, incy, c, s, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_cy = argv[2];
+ rblapack_incy = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
+ if (!NA_IsNArray(rblapack_cy))
+ rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
+ if (NA_RANK(rblapack_cy) != 1)
+ rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
+ if (NA_TYPE(rblapack_cy) != NA_DCOMPLEX)
+ rblapack_cy = na_change_type(rblapack_cy, NA_DCOMPLEX);
+ cy = NA_PTR_TYPE(rblapack_cy, doublecomplex*);
+ c.r = NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
+ c.i = NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
+ incx = NUM2INT(rblapack_incx);
+ s.r = NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
+ s.i = NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
+ incy = NUM2INT(rblapack_incy);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, doublecomplex*);
+ MEMCPY(cx_out__, cx, doublecomplex, NA_TOTAL(rblapack_cx));
+ rblapack_cx = rblapack_cx_out__;
+ cx = cx_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cy_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, doublecomplex*);
+ MEMCPY(cy_out__, cy, doublecomplex, NA_TOTAL(rblapack_cy));
+ rblapack_cy = rblapack_cy_out__;
+ cy = cy_out__;
+
+ zlacrt_(&n, cx, &incx, cy, &incy, &c, &s);
+
+ return rb_ary_new3(2, rblapack_cx, rblapack_cy);
+}
+
+void
+init_lapack_zlacrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlacrt", rblapack_zlacrt, -1);
+}
diff --git a/ext/zladiv.c b/ext/zladiv.c
new file mode 100644
index 0000000..414599c
--- /dev/null
+++ b/ext/zladiv.c
@@ -0,0 +1,57 @@
+#include "rb_lapack.h"
+
+extern VOID zladiv_(doublecomplex *__out__, doublecomplex* x, doublecomplex* y);
+
+
+static VALUE
+rblapack_zladiv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublecomplex x;
+ VALUE rblapack_y;
+ doublecomplex y;
+ VALUE rblapack___out__;
+ doublecomplex __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 __out__ = NumRu::Lapack.zladiv( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n COMPLEX*16 FUNCTION ZLADIV( X, Y )\n\n* Purpose\n* =======\n*\n* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y\n* will not overflow on an intermediary step unless the results\n* overflows.\n*\n\n* Arguments\n* =========\n*\n* X (input) COMPLEX*16\n* Y (input) COMPLEX*16\n* The complex scalars X and Y.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION ZI, ZR\n* ..\n* .. External Subroutines ..\n EXTERNAL DLADIV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, DCMPLX, DIMAG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zladiv( x, y, [: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_x = argv[0];
+ rblapack_y = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ x.r = NUM2DBL(rb_funcall(rblapack_x, rb_intern("real"), 0));
+ x.i = NUM2DBL(rb_funcall(rblapack_x, rb_intern("imag"), 0));
+ y.r = NUM2DBL(rb_funcall(rblapack_y, rb_intern("real"), 0));
+ y.i = NUM2DBL(rb_funcall(rblapack_y, rb_intern("imag"), 0));
+
+ zladiv_(&__out__, &x, &y);
+
+ rblapack___out__ = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(__out__.r)), rb_float_new((double)(__out__.i)));
+ return rblapack___out__;
+}
+
+void
+init_lapack_zladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zladiv", rblapack_zladiv, -1);
+}
diff --git a/ext/zlaed0.c b/ext/zlaed0.c
new file mode 100644
index 0000000..b904885
--- /dev/null
+++ b/ext/zlaed0.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID zlaed0_(integer* qsiz, integer* n, doublereal* d, doublereal* e, doublecomplex* q, integer* ldq, doublecomplex* qstore, integer* ldqs, doublereal* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zlaed0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ doublecomplex *qstore;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+ integer ldqs;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, q = NumRu::Lapack.zlaed0( qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using the divide and conquer method, ZLAED0 computes all eigenvalues\n* of a symmetric tridiagonal matrix which is one diagonal block of\n* those from reducing a dense or band Hermitian matrix and\n* corresponding eigenvectors of the dense or band matrix.\n*\n\n* Arguments\n* =========\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, Q must contain an QSIZ x N matrix whose columns\n* unitarily orthonormal. It is a part of the unitary matrix\n* that reduces the full dense Hermitian matrix to a\n* (reducible) symmetric tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IWORK (workspace) INTEGER array,\n* the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* RWORK (workspace) DOUBLE PRECISION array,\n* dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* QSTORE (workspace) COMPLEX*16 array, dimension (LDQS, N)\n* Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE.\n* LDQS >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* =====================================================================\n*\n* Warning: N could be as big as QSIZ!\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, q = NumRu::Lapack.zlaed0( qsiz, d, e, q, [: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_qsiz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_q = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (4th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of q");
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ ldqs = MAX(1,n);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ qstore = ALLOC_N(doublecomplex, (ldqs)*(n));
+ rwork = ALLOC_N(doublereal, (1 + 3*n + 2*n*LG(n) + 3*pow(n,2)));
+ iwork = ALLOC_N(integer, (6 + 6*n + 5*n*LG(n)));
+
+ zlaed0_(&qsiz, &n, d, e, q, &ldq, qstore, &ldqs, rwork, iwork, &info);
+
+ free(qstore);
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_q);
+}
+
+void
+init_lapack_zlaed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaed0", rblapack_zlaed0, -1);
+}
diff --git a/ext/zlaed7.c b/ext/zlaed7.c
new file mode 100644
index 0000000..09b1035
--- /dev/null
+++ b/ext/zlaed7.c
@@ -0,0 +1,247 @@
+#include "rb_lapack.h"
+
+extern VOID zlaed7_(integer* n, integer* cutpnt, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, doublereal* d, doublecomplex* q, integer* ldq, doublereal* rho, integer* indxq, doublereal* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, doublecomplex* work, doublereal* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zlaed7(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_tlvls;
+ integer tlvls;
+ VALUE rblapack_curlvl;
+ integer curlvl;
+ VALUE rblapack_curpbm;
+ integer curpbm;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_qstore;
+ doublereal *qstore;
+ VALUE rblapack_qptr;
+ integer *qptr;
+ VALUE rblapack_prmptr;
+ integer *prmptr;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ VALUE rblapack_qstore_out__;
+ doublereal *qstore_out__;
+ VALUE rblapack_qptr_out__;
+ integer *qptr_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer n;
+ integer ldq;
+
+ 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 indxq, info, d, q, qstore, qptr = NumRu::Lapack.zlaed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense or banded\n* Hermitian matrix that has been reduced to tridiagonal form.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine DLAED4 (as called by SLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) DOUBLE PRECISION\n* Contains the subdiagonal element used to create the rank-1\n* modification.\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order,\n* ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array,\n* dimension (3*N+2*QSIZ*N)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (QSIZ*N)\n*\n* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, CURR, I, IDLMDA, INDX,\n $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n* ..\n* .. External Subroutines ..\n EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.zlaed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_cutpnt = argv[0];
+ rblapack_qsiz = argv[1];
+ rblapack_tlvls = argv[2];
+ rblapack_curlvl = argv[3];
+ rblapack_curpbm = argv[4];
+ rblapack_d = argv[5];
+ rblapack_q = argv[6];
+ rblapack_rho = argv[7];
+ rblapack_qstore = argv[8];
+ rblapack_qptr = argv[9];
+ rblapack_prmptr = argv[10];
+ rblapack_perm = argv[11];
+ rblapack_givptr = argv[12];
+ rblapack_givcol = argv[13];
+ rblapack_givnum = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ tlvls = NUM2INT(rblapack_tlvls);
+ curpbm = NUM2INT(rblapack_curpbm);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (6th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (6th 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 1 of q");
+ 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_qstore))
+ rb_raise(rb_eArgError, "qstore (9th argument) must be NArray");
+ if (NA_RANK(rblapack_qstore) != 1)
+ rb_raise(rb_eArgError, "rank of qstore (9th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
+ rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
+ if (NA_TYPE(rblapack_qstore) != NA_DFLOAT)
+ rblapack_qstore = na_change_type(rblapack_qstore, NA_DFLOAT);
+ qstore = NA_PTR_TYPE(rblapack_qstore, doublereal*);
+ if (!NA_IsNArray(rblapack_prmptr))
+ rb_raise(rb_eArgError, "prmptr (11th argument) must be NArray");
+ if (NA_RANK(rblapack_prmptr) != 1)
+ rb_raise(rb_eArgError, "rank of prmptr (11th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_prmptr) != NA_LINT)
+ rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
+ prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (13th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (15th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (15th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
+ if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ curlvl = NUM2INT(rblapack_curlvl);
+ if (!NA_IsNArray(rblapack_qptr))
+ rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_qptr) != 1)
+ rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_qptr) != (n+2))
+ rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
+ if (NA_TYPE(rblapack_qptr) != NA_LINT)
+ rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
+ qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (14th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (14th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
+ if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ rho = NUM2DBL(rblapack_rho);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
+ rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = pow(n,2)+1;
+ rblapack_qstore_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, doublereal*);
+ MEMCPY(qstore_out__, qstore, doublereal, NA_TOTAL(rblapack_qstore));
+ rblapack_qstore = rblapack_qstore_out__;
+ qstore = qstore_out__;
+ {
+ int shape[1];
+ shape[0] = n+2;
+ rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
+ MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
+ rblapack_qptr = rblapack_qptr_out__;
+ qptr = qptr_out__;
+ work = ALLOC_N(doublecomplex, (qsiz*n));
+ rwork = ALLOC_N(doublereal, (3*n+2*qsiz*n));
+ iwork = ALLOC_N(integer, (4*n));
+
+ zlaed7_(&n, &cutpnt, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, &rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
+}
+
+void
+init_lapack_zlaed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaed7", rblapack_zlaed7, -1);
+}
diff --git a/ext/zlaed8.c b/ext/zlaed8.c
new file mode 100644
index 0000000..72dd8d1
--- /dev/null
+++ b/ext/zlaed8.c
@@ -0,0 +1,198 @@
+#include "rb_lapack.h"
+
+extern VOID zlaed8_(integer* k, integer* n, integer* qsiz, doublecomplex* q, integer* ldq, doublereal* d, doublereal* rho, integer* cutpnt, doublereal* z, doublereal* dlamda, doublecomplex* q2, integer* ldq2, doublereal* w, integer* indxp, integer* indx, integer* indxq, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, integer* info);
+
+
+static VALUE
+rblapack_zlaed8(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_qsiz;
+ integer qsiz;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_rho;
+ doublereal rho;
+ VALUE rblapack_cutpnt;
+ integer cutpnt;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_indxq;
+ integer *indxq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_dlamda;
+ doublereal *dlamda;
+ VALUE rblapack_q2;
+ doublecomplex *q2;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ integer *indxp;
+ integer *indx;
+
+ integer ldq;
+ integer n;
+ integer ldq2;
+
+ 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 k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.zlaed8( qsiz, q, d, rho, cutpnt, z, indxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n* Purpose\n* =======\n*\n* ZLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* Contains the number of non-deflated eigenvalues.\n* This is the order of the related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the dense or band matrix to tridiagonal form.\n* QSIZ >= N if ICOMPQ = 1.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined. On exit, D contains the trailing (N-K) updated\n* eigenvalues (those which were deflated) sorted into increasing\n* order.\n*\n* RHO (input/output) DOUBLE PRECISION\n* Contains the off diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined. RHO is modified during the computation to\n* the value required by DLAED3.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. MIN(1,N) <= CUTPNT <= N.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* On input this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix). The contents of Z are\n* destroyed during the updating process.\n*\n* DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n* Contains a copy of the first K eigenvalues which will be used\n* by DLAED3 to form the secular equation.\n*\n* Q2 (output) COMPLEX*16 array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* Contains a copy of the first K eigenvectors which will be used\n* by DLAED7 in a matrix multiply (DGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max( 1, N ).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* This will hold the first k values of the final\n* deflation-altered z-vector and will be passed to DLAED3.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output INDXP(1:K)\n* points to the nondeflated D-values and INDXP(K+1:N)\n* points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that elements in\n* the second half of this permutation must first have CUTPNT\n* added to their values in order to be accurate.\n*\n* PERM (output) INTEGER array, dimension (N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* Contains the number of Givens rotations which took place in\n* this subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.zlaed8( qsiz, q, d, rho, cutpnt, z, indxq, [: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_qsiz = argv[0];
+ rblapack_q = argv[1];
+ rblapack_d = argv[2];
+ rblapack_rho = argv[3];
+ rblapack_cutpnt = argv[4];
+ rblapack_z = argv[5];
+ rblapack_indxq = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ qsiz = NUM2INT(rblapack_qsiz);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ cutpnt = NUM2INT(rblapack_cutpnt);
+ if (!NA_IsNArray(rblapack_indxq))
+ rb_raise(rb_eArgError, "indxq (7th argument) must be NArray");
+ if (NA_RANK(rblapack_indxq) != 1)
+ rb_raise(rb_eArgError, "rank of indxq (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indxq) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indxq) != NA_LINT)
+ rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
+ indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (2th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (6th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ rho = NUM2DBL(rblapack_rho);
+ ldq2 = MAX( 1, n );
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldq2;
+ shape[1] = n;
+ rblapack_q2 = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q2 = NA_PTR_TYPE(rblapack_q2, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
+ }
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ {
+ int shape[2];
+ shape[0] = 2;
+ shape[1] = n;
+ rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ indxp = ALLOC_N(integer, (n));
+ indx = ALLOC_N(integer, (n));
+
+ zlaed8_(&k, &n, &qsiz, q, &ldq, d, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, indxp, indx, indxq, perm, &givptr, givcol, givnum, &info);
+
+ free(indxp);
+ free(indx);
+ rblapack_k = INT2NUM(k);
+ rblapack_givptr = INT2NUM(givptr);
+ rblapack_info = INT2NUM(info);
+ rblapack_rho = rb_float_new((double)rho);
+ return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_q, rblapack_d, rblapack_rho);
+}
+
+void
+init_lapack_zlaed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaed8", rblapack_zlaed8, -1);
+}
diff --git a/ext/zlaein.c b/ext/zlaein.c
new file mode 100644
index 0000000..72b0dbb
--- /dev/null
+++ b/ext/zlaein.c
@@ -0,0 +1,113 @@
+#include "rb_lapack.h"
+
+extern VOID zlaein_(logical* rightv, logical* noinit, integer* n, doublecomplex* h, integer* ldh, doublecomplex* w, doublecomplex* v, doublecomplex* b, integer* ldb, doublereal* rwork, doublereal* eps3, doublereal* smlnum, integer* info);
+
+
+static VALUE
+rblapack_zlaein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_rightv;
+ logical rightv;
+ VALUE rblapack_noinit;
+ logical noinit;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_w;
+ doublecomplex w;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_eps3;
+ doublereal eps3;
+ VALUE rblapack_smlnum;
+ doublereal smlnum;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_v_out__;
+ doublecomplex *v_out__;
+ doublecomplex *b;
+ doublereal *rwork;
+
+ integer ldh;
+ integer n;
+ integer ldb;
+
+ 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, v = NumRu::Lapack.zlaein( rightv, noinit, h, w, v, eps3, smlnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n* Purpose\n* =======\n*\n* ZLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue W of a complex upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in V\n* = .FALSE.: initial vector supplied in V.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX*16 array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input) COMPLEX*16\n* The eigenvalue of H whose corresponding right or left\n* eigenvector is to be computed.\n*\n* V (input/output) COMPLEX*16 array, dimension (N)\n* On entry, if NOINIT = .FALSE., V must contain a starting\n* vector for inverse iteration; otherwise V need not be set.\n* On exit, V contains the computed eigenvector, normalized so\n* that the component of largest magnitude has magnitude 1; here\n* the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n*\n* B (workspace) COMPLEX*16 array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* EPS3 (input) DOUBLE PRECISION\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) DOUBLE PRECISION\n* A machine-dependent value close to the underflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; V is set to the\n* last iterate.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.zlaein( rightv, noinit, h, w, v, eps3, smlnum, [: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_rightv = argv[0];
+ rblapack_noinit = argv[1];
+ rblapack_h = argv[2];
+ rblapack_w = argv[3];
+ rblapack_v = argv[4];
+ rblapack_eps3 = argv[5];
+ rblapack_smlnum = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ rightv = (rblapack_rightv == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (3th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (5th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be the same as shape 1 of h");
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ smlnum = NUM2DBL(rblapack_smlnum);
+ noinit = (rblapack_noinit == Qtrue);
+ eps3 = NUM2DBL(rblapack_eps3);
+ w.r = NUM2DBL(rb_funcall(rblapack_w, rb_intern("real"), 0));
+ w.i = NUM2DBL(rb_funcall(rblapack_w, rb_intern("imag"), 0));
+ ldb = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
+ MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ b = ALLOC_N(doublecomplex, (ldb)*(n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zlaein_(&rightv, &noinit, &n, h, &ldh, &w, v, b, &ldb, rwork, &eps3, &smlnum, &info);
+
+ free(b);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_v);
+}
+
+void
+init_lapack_zlaein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaein", rblapack_zlaein, -1);
+}
diff --git a/ext/zlaesy.c b/ext/zlaesy.c
new file mode 100644
index 0000000..79690ea
--- /dev/null
+++ b/ext/zlaesy.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern VOID zlaesy_(doublecomplex* a, doublecomplex* b, doublecomplex* c, doublecomplex* rt1, doublecomplex* rt2, doublecomplex* evscal, doublecomplex* cs1, doublecomplex* sn1);
+
+
+static VALUE
+rblapack_zlaesy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex a;
+ VALUE rblapack_b;
+ doublecomplex b;
+ VALUE rblapack_c;
+ doublecomplex c;
+ VALUE rblapack_rt1;
+ doublecomplex rt1;
+ VALUE rblapack_rt2;
+ doublecomplex rt2;
+ VALUE rblapack_evscal;
+ doublecomplex evscal;
+ VALUE rblapack_cs1;
+ doublecomplex cs1;
+ VALUE rblapack_sn1;
+ doublecomplex sn1;
+
+
+ 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 rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.zlaesy( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* ZLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n* ( ( A, B );( B, C ) )\n* provided the norm of the matrix of eigenvectors is larger than\n* some threshold value.\n*\n* RT1 is the eigenvalue of larger absolute value, and RT2 of\n* smaller absolute value. If the eigenvectors are computed, then\n* on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n*\n* [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]\n* [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX*16\n* The ( 1, 1 ) element of input matrix.\n*\n* B (input) COMPLEX*16\n* The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element\n* is also given by B, since the 2-by-2 matrix is symmetric.\n*\n* C (input) COMPLEX*16\n* The ( 2, 2 ) element of input matrix.\n*\n* RT1 (output) COMPLEX*16\n* The eigenvalue of larger modulus.\n*\n* RT2 (output) COMPLEX*16\n* The eigenvalue of smaller modulus.\n*\n* EVSCAL (output) COMPLEX*16\n* The complex value by which the eigenvector matrix was scaled\n* to make it orthonormal. If EVSCAL is zero, the eigenvectors\n* were not computed. This means one of two things: the 2-by-2\n* matrix could not be diagonalized, or the norm of the matrix\n* of eigenvectors before scaling was larger than the threshold\n* value THRESH (set below).\n*\n* CS1 (output) COMPLEX*16\n* SN1 (output) COMPLEX*16\n* If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector\n* for RT1.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.zlaesy( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a.r = NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
+ a.i = NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
+ c.r = NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
+ c.i = NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
+ b.r = NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
+ b.i = NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));
+
+ zlaesy_(&a, &b, &c, &rt1, &rt2, &evscal, &cs1, &sn1);
+
+ rblapack_rt1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt1.r)), rb_float_new((double)(rt1.i)));
+ rblapack_rt2 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt2.r)), rb_float_new((double)(rt2.i)));
+ rblapack_evscal = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(evscal.r)), rb_float_new((double)(evscal.i)));
+ rblapack_cs1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(cs1.r)), rb_float_new((double)(cs1.i)));
+ rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
+ return rb_ary_new3(5, rblapack_rt1, rblapack_rt2, rblapack_evscal, rblapack_cs1, rblapack_sn1);
+}
+
+void
+init_lapack_zlaesy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaesy", rblapack_zlaesy, -1);
+}
diff --git a/ext/zlaev2.c b/ext/zlaev2.c
new file mode 100644
index 0000000..0ac042c
--- /dev/null
+++ b/ext/zlaev2.c
@@ -0,0 +1,71 @@
+#include "rb_lapack.h"
+
+extern VOID zlaev2_(doublecomplex* a, doublecomplex* b, doublecomplex* c, doublereal* rt1, doublereal* rt2, doublereal* cs1, doublecomplex* sn1);
+
+
+static VALUE
+rblapack_zlaev2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex a;
+ VALUE rblapack_b;
+ doublecomplex b;
+ VALUE rblapack_c;
+ doublecomplex c;
+ VALUE rblapack_rt1;
+ doublereal rt1;
+ VALUE rblapack_rt2;
+ doublereal rt2;
+ VALUE rblapack_cs1;
+ doublereal cs1;
+ VALUE rblapack_sn1;
+ doublecomplex sn1;
+
+
+ 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 rt1, rt2, cs1, sn1 = NumRu::Lapack.zlaev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n* [ A B ]\n* [ CONJG(B) C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX*16\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) COMPLEX*16\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) COMPLEX*16\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) DOUBLE PRECISION\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) DOUBLE PRECISION\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) DOUBLE PRECISION\n* SN1 (output) COMPLEX*16\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.zlaev2( a, b, c, [: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_a = argv[0];
+ rblapack_b = argv[1];
+ rblapack_c = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ a.r = NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
+ a.i = NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
+ c.r = NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
+ c.i = NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
+ b.r = NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
+ b.i = NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));
+
+ zlaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
+
+ rblapack_rt1 = rb_float_new((double)rt1);
+ rblapack_rt2 = rb_float_new((double)rt2);
+ rblapack_cs1 = rb_float_new((double)cs1);
+ rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
+ return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
+}
+
+void
+init_lapack_zlaev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaev2", rblapack_zlaev2, -1);
+}
diff --git a/ext/zlag2c.c b/ext/zlag2c.c
new file mode 100644
index 0000000..3720738
--- /dev/null
+++ b/ext/zlag2c.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID zlag2c_(integer* m, integer* n, doublecomplex* a, integer* lda, complex* sa, integer* ldsa, integer* info);
+
+
+static VALUE
+rblapack_zlag2c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_sa;
+ complex *sa;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer ldsa;
+
+ 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 sa, info = NumRu::Lapack.zlag2c( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* ZLAG2C checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SA (output) COMPLEX array, dimension (LDSA,N)\n* On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n* INFO>0, the content of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, DIMAG\n* ..\n* .. External Functions ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.zlag2c( m, 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_m = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ ldsa = MAX(1,m);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldsa;
+ shape[1] = n;
+ rblapack_sa = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ sa = NA_PTR_TYPE(rblapack_sa, complex*);
+
+ zlag2c_(&m, &n, a, &lda, sa, &ldsa, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_sa, rblapack_info);
+}
+
+void
+init_lapack_zlag2c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlag2c", rblapack_zlag2c, -1);
+}
diff --git a/ext/zlags2.c b/ext/zlags2.c
new file mode 100644
index 0000000..5ad5f45
--- /dev/null
+++ b/ext/zlags2.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID zlags2_(logical* upper, doublereal* a1, doublecomplex* a2, doublereal* a3, doublereal* b1, doublecomplex* b2, doublereal* b3, doublereal* csu, doublecomplex* snu, doublereal* csv, doublecomplex* snv, doublereal* csq, doublecomplex* snq);
+
+
+static VALUE
+rblapack_zlags2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_upper;
+ logical upper;
+ VALUE rblapack_a1;
+ doublereal a1;
+ VALUE rblapack_a2;
+ doublecomplex a2;
+ VALUE rblapack_a3;
+ doublereal a3;
+ VALUE rblapack_b1;
+ doublereal b1;
+ VALUE rblapack_b2;
+ doublecomplex b2;
+ VALUE rblapack_b3;
+ doublereal b3;
+ VALUE rblapack_csu;
+ doublereal csu;
+ VALUE rblapack_snu;
+ doublecomplex snu;
+ VALUE rblapack_csv;
+ doublereal csv;
+ VALUE rblapack_snv;
+ doublecomplex snv;
+ VALUE rblapack_csq;
+ doublereal csq;
+ VALUE rblapack_snq;
+ doublecomplex snq;
+
+
+ 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 csu, snu, csv, snv, csq, snq = NumRu::Lapack.zlags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n* where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ),\n* ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV )\n*\n* Q = ( CSQ SNQ )\n* ( -CONJG(SNQ) CSQ )\n*\n* Z' denotes the conjugate transpose of Z.\n*\n* The rows of the transformed A and B are parallel. Moreover, if the\n* input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n* of A is not zero. If the input matrices A and B are both not zero,\n* then the transformed (2,2) element of B is not zero, except when the\n* first rows of input A and B are parallel and the second rows are\n* zero.\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) DOUBLE PRECISION\n* A2 (input) COMPLEX*16\n* A3 (input) DOUBLE PRECISION\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) DOUBLE PRECISION\n* B2 (input) COMPLEX*16\n* B3 (input) DOUBLE PRECISION\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) DOUBLE PRECISION\n* SNU (output) COMPLEX*16\n* The desired unitary matrix U.\n*\n* CSV (output) DOUBLE PRECISION\n* SNV (output) COMPLEX*16\n* The desired unitary matrix V.\n*\n* CSQ (output) DOUBLE PRECISION\n* SNQ (output) COMPLEX*16\n* The desired unitary matrix Q.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.zlags2( upper, a1, a2, a3, b1, b2, b3, [: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_upper = argv[0];
+ rblapack_a1 = argv[1];
+ rblapack_a2 = argv[2];
+ rblapack_a3 = argv[3];
+ rblapack_b1 = argv[4];
+ rblapack_b2 = argv[5];
+ rblapack_b3 = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ upper = (rblapack_upper == Qtrue);
+ a2.r = NUM2DBL(rb_funcall(rblapack_a2, rb_intern("real"), 0));
+ a2.i = NUM2DBL(rb_funcall(rblapack_a2, rb_intern("imag"), 0));
+ b1 = NUM2DBL(rblapack_b1);
+ b3 = NUM2DBL(rblapack_b3);
+ a1 = NUM2DBL(rblapack_a1);
+ b2.r = NUM2DBL(rb_funcall(rblapack_b2, rb_intern("real"), 0));
+ b2.i = NUM2DBL(rb_funcall(rblapack_b2, rb_intern("imag"), 0));
+ a3 = NUM2DBL(rblapack_a3);
+
+ zlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
+
+ rblapack_csu = rb_float_new((double)csu);
+ rblapack_snu = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snu.r)), rb_float_new((double)(snu.i)));
+ rblapack_csv = rb_float_new((double)csv);
+ rblapack_snv = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snv.r)), rb_float_new((double)(snv.i)));
+ rblapack_csq = rb_float_new((double)csq);
+ rblapack_snq = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snq.r)), rb_float_new((double)(snq.i)));
+ return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
+}
+
+void
+init_lapack_zlags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlags2", rblapack_zlags2, -1);
+}
diff --git a/ext/zlagtm.c b/ext/zlagtm.c
new file mode 100644
index 0000000..010e1b9
--- /dev/null
+++ b/ext/zlagtm.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID zlagtm_(char* trans, integer* n, integer* nrhs, doublereal* alpha, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* x, integer* ldx, doublereal* beta, doublecomplex* b, integer* ldb);
+
+
+static VALUE
+rblapack_zlagtm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_alpha;
+ doublereal alpha;
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_beta;
+ doublereal beta;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldx;
+ integer nrhs;
+ integer ldb;
+
+ 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 b = NumRu::Lapack.zlagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* ZLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A**T * X + beta * B\n* = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B\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 X and B.\n*\n* ALPHA (input) DOUBLE PRECISION\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) COMPLEX*16 array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) DOUBLE PRECISION\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.zlagtm( trans, alpha, dl, d, du, x, beta, b, [: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_trans = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_dl = argv[2];
+ rblapack_d = argv[3];
+ rblapack_du = argv[4];
+ rblapack_x = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ 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_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ alpha = NUM2DBL(rblapack_alpha);
+ if (!NA_IsNArray(rblapack_du))
+ rb_raise(rb_eArgError, "du (5th argument) must be NArray");
+ if (NA_RANK(rblapack_du) != 1)
+ rb_raise(rb_eArgError, "rank of du (5th 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+ if (!NA_IsNArray(rblapack_dl))
+ rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
+ if (NA_RANK(rblapack_dl) != 1)
+ rb_raise(rb_eArgError, "rank of dl (3th 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ beta = NUM2DBL(rblapack_beta);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zlagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_zlagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlagtm", rblapack_zlagtm, -1);
+}
diff --git a/ext/zlahef.c b/ext/zlahef.c
new file mode 100644
index 0000000..5b1cc3f
--- /dev/null
+++ b/ext/zlahef.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zlahef_(char* uplo, integer* n, integer* nb, integer* kb, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* w, integer* ldw, integer* info);
+
+
+static VALUE
+rblapack_zlahef(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *w;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 kb, ipiv, info, a = NumRu::Lapack.zlahef( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* ZLAHEF computes a partial factorization of a complex Hermitian\n* matrix A using the Bunch-Kaufman diagonal pivoting method. The\n* partial factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the conjugate transpose of U.\n*\n* ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX*16 array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.zlahef( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+ w = ALLOC_N(doublecomplex, (ldw)*(MAX(n,nb)));
+
+ zlahef_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
+
+ free(w);
+ rblapack_kb = INT2NUM(kb);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zlahef(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlahef", rblapack_zlahef, -1);
+}
diff --git a/ext/zlahqr.c b/ext/zlahqr.c
new file mode 100644
index 0000000..4b773cf
--- /dev/null
+++ b/ext/zlahqr.c
@@ -0,0 +1,135 @@
+#include "rb_lapack.h"
+
+extern VOID zlahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* info);
+
+
+static VALUE
+rblapack_zlahqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer ldh;
+ 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 w, info, h, z = NumRu::Lapack.zlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* ZLAHQR is an auxiliary routine called by CHSEQR to update the\n* eigenvalues and Schur decomposition already computed by CHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows and\n* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n* ZLAHQR works primarily with the Hessenberg submatrix in rows\n* and columns ILO to IHI, but applies transformations to all of\n* H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., then H\n* is upper triangular in rows and columns ILO:IHI. If INFO\n* is zero and if WANTT is .FALSE., then the contents of H\n* are unspecified on exit. The output state of H in case\n* INF is positive is below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues ILO to IHI are stored in the\n* corresponding elements of W. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with W(i) = H(i,i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by CHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, ZLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of W contain\n* those eigenvalues which have been successfully\n* computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix\n* rows and columns ILO thorugh INFO of the final,\n* output value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of ZLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, info, h, z = NumRu::Lapack.zlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_iloz = argv[5];
+ rblapack_ihiz = argv[6];
+ rblapack_z = argv[7];
+ rblapack_ldz = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = NUM2INT(rblapack_ldz);
+ wantz = (rblapack_wantz == Qtrue);
+ iloz = NUM2INT(rblapack_iloz);
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? n : 0;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zlahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_w, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlahqr", rblapack_zlahqr, -1);
+}
diff --git a/ext/zlahr2.c b/ext/zlahr2.c
new file mode 100644
index 0000000..eed5fd0
--- /dev/null
+++ b/ext/zlahr2.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID zlahr2_(integer* n, integer* k, integer* nb, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* t, integer* ldt, doublecomplex* y, integer* ldy);
+
+
+static VALUE
+rblapack_zlahr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.zlahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by ZGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX*16 array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX*16 array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.zlahr2( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ ldy = n;
+ k = NUM2INT(rblapack_k);
+ ldt = nb;
+ 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-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ 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__;
+
+ zlahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_zlahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlahr2", rblapack_zlahr2, -1);
+}
diff --git a/ext/zlahrd.c b/ext/zlahrd.c
new file mode 100644
index 0000000..b444a36
--- /dev/null
+++ b/ext/zlahrd.c
@@ -0,0 +1,112 @@
+#include "rb_lapack.h"
+
+extern VOID zlahrd_(integer* n, integer* k, integer* nb, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* t, integer* ldt, doublecomplex* y, integer* ldy);
+
+
+static VALUE
+rblapack_zlahrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer ldt;
+ integer ldy;
+
+ 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 tau, t, y, a = NumRu::Lapack.zlahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by a unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine ZLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX*16 array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX*16 array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.zlahrd( n, k, nb, a, [: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_n = argv[0];
+ rblapack_k = argv[1];
+ rblapack_nb = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ nb = NUM2INT(rblapack_nb);
+ ldy = MAX(1,n);
+ k = NUM2INT(rblapack_k);
+ ldt = nb;
+ 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-k+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,nb);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = MAX(1,nb);
+ rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldy;
+ shape[1] = MAX(1,nb);
+ rblapack_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n-k+1;
+ 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__;
+
+ zlahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
+
+ return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
+}
+
+void
+init_lapack_zlahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlahrd", rblapack_zlahrd, -1);
+}
diff --git a/ext/zlaic1.c b/ext/zlaic1.c
new file mode 100644
index 0000000..1eed417
--- /dev/null
+++ b/ext/zlaic1.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID zlaic1_(integer* job, integer* j, doublecomplex* x, doublereal* sest, doublecomplex* w, doublecomplex* gamma, doublereal* sestpr, doublecomplex* s, doublecomplex* c);
+
+
+static VALUE
+rblapack_zlaic1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ integer job;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_sest;
+ doublereal sest;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_gamma;
+ doublecomplex gamma;
+ VALUE rblapack_sestpr;
+ doublereal sestpr;
+ VALUE rblapack_s;
+ doublecomplex s;
+ VALUE rblapack_c;
+ doublecomplex c;
+
+ integer j;
+
+ 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 sestpr, s, c = NumRu::Lapack.zlaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* ZLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then ZLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]\n* [ conjg(gamma) ]\n*\n* where alpha = conjg(x)'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) COMPLEX*16 array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) DOUBLE PRECISION\n* Estimated singular value of j by j matrix L\n*\n* W (input) COMPLEX*16 array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) COMPLEX*16\n* The diagonal element gamma.\n*\n* SESTPR (output) DOUBLE PRECISION\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) COMPLEX*16\n* Sine needed in forming xhat.\n*\n* C (output) COMPLEX*16\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.zlaic1( job, x, sest, w, gamma, [: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_job = argv[0];
+ rblapack_x = argv[1];
+ rblapack_sest = argv[2];
+ rblapack_w = argv[3];
+ rblapack_gamma = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = NUM2INT(rblapack_job);
+ sest = NUM2DBL(rblapack_sest);
+ gamma.r = NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("real"), 0));
+ gamma.i = NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("imag"), 0));
+ 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);
+ j = NA_SHAPE0(rblapack_x);
+ 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_w))
+ rb_raise(rb_eArgError, "w (4th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != j)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_w) != NA_DCOMPLEX)
+ rblapack_w = na_change_type(rblapack_w, NA_DCOMPLEX);
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+
+ zlaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
+
+ rblapack_sestpr = rb_float_new((double)sestpr);
+ rblapack_s = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(s.r)), rb_float_new((double)(s.i)));
+ rblapack_c = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(c.r)), rb_float_new((double)(c.i)));
+ return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
+}
+
+void
+init_lapack_zlaic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaic1", rblapack_zlaic1, -1);
+}
diff --git a/ext/zlals0.c b/ext/zlals0.c
new file mode 100644
index 0000000..37ea534
--- /dev/null
+++ b/ext/zlals0.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID zlals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, doublecomplex* b, integer* ldb, doublecomplex* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* poles, doublereal* difl, doublereal* difr, doublereal* z, integer* k, doublereal* c, doublereal* s, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zlals0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_nl;
+ integer nl;
+ VALUE rblapack_nr;
+ integer nr;
+ VALUE rblapack_sqre;
+ integer sqre;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givptr;
+ integer givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_poles;
+ doublereal *poles;
+ VALUE rblapack_difl;
+ doublereal *difl;
+ VALUE rblapack_difr;
+ doublereal *difr;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_s;
+ doublereal s;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *bx;
+ doublereal *rwork;
+
+ integer ldb;
+ integer nrhs;
+ integer n;
+ integer ldgcol;
+ integer ldgnum;
+ integer k;
+ integer ldbx;
+
+ 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, b = NumRu::Lapack.zlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) COMPLEX*16 array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension\n* ( K*(1+NRHS) + 2*NRHS )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_nl = argv[1];
+ rblapack_nr = argv[2];
+ rblapack_sqre = argv[3];
+ rblapack_b = argv[4];
+ rblapack_perm = argv[5];
+ rblapack_givptr = argv[6];
+ rblapack_givcol = argv[7];
+ rblapack_givnum = argv[8];
+ rblapack_poles = argv[9];
+ rblapack_difl = argv[10];
+ rblapack_difr = argv[11];
+ rblapack_z = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ nr = NUM2INT(rblapack_nr);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ givptr = NUM2INT(rblapack_givptr);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
+ ldgnum = NA_SHAPE0(rblapack_givnum);
+ if (NA_SHAPE1(rblapack_givnum) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
+ if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 1)
+ rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_difl);
+ if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (13th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 1)
+ rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_z) != k)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ s = NUM2DBL(rblapack_s);
+ nl = NUM2INT(rblapack_nl);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 1)
+ rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_perm);
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_poles) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
+ if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
+ c = NUM2DBL(rblapack_c);
+ sqre = NUM2INT(rblapack_sqre);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldgnum)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
+ if (NA_SHAPE1(rblapack_difr) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
+ if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_givcol);
+ if (NA_SHAPE1(rblapack_givcol) != (2))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ ldbx = n;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ bx = ALLOC_N(doublecomplex, (ldbx)*(nrhs));
+ rwork = ALLOC_N(doublereal, (k*(1+nrhs) + 2*nrhs));
+
+ zlals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, rwork, &info);
+
+ free(bx);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zlals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlals0", rblapack_zlals0, -1);
+}
diff --git a/ext/zlalsa.c b/ext/zlalsa.c
new file mode 100644
index 0000000..b16f71f
--- /dev/null
+++ b/ext/zlalsa.c
@@ -0,0 +1,270 @@
+#include "rb_lapack.h"
+
+extern VOID zlalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, doublecomplex* b, integer* ldb, doublecomplex* bx, integer* ldbx, doublereal* u, integer* ldu, doublereal* vt, integer* k, doublereal* difl, doublereal* difr, doublereal* z, doublereal* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, doublereal* givnum, doublereal* c, doublereal* s, doublereal* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zlalsa(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_icompq;
+ integer icompq;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_u;
+ doublereal *u;
+ VALUE rblapack_vt;
+ doublereal *vt;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_difl;
+ doublereal *difl;
+ VALUE rblapack_difr;
+ doublereal *difr;
+ VALUE rblapack_z;
+ doublereal *z;
+ VALUE rblapack_poles;
+ doublereal *poles;
+ VALUE rblapack_givptr;
+ integer *givptr;
+ VALUE rblapack_givcol;
+ integer *givcol;
+ VALUE rblapack_perm;
+ integer *perm;
+ VALUE rblapack_givnum;
+ doublereal *givnum;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_bx;
+ doublecomplex *bx;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer ldb;
+ integer nrhs;
+ integer ldu;
+ integer smlsiz;
+ integer n;
+ integer nlvl;
+ integer ldgcol;
+ integer ldbx;
+
+ 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 bx, info, b = NumRu::Lapack.zlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by ZLALSA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) COMPLEX*16 array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension at least\n* MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.zlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 15 && argc != 15)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
+ rblapack_icompq = argv[0];
+ rblapack_b = argv[1];
+ rblapack_u = argv[2];
+ rblapack_vt = argv[3];
+ rblapack_k = argv[4];
+ rblapack_difl = argv[5];
+ rblapack_difr = argv[6];
+ rblapack_z = argv[7];
+ rblapack_poles = argv[8];
+ rblapack_givptr = argv[9];
+ rblapack_givcol = argv[10];
+ rblapack_perm = argv[11];
+ rblapack_givnum = argv[12];
+ rblapack_c = argv[13];
+ rblapack_s = argv[14];
+ if (argc == 15) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ icompq = NUM2INT(rblapack_icompq);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (3th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ smlsiz = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_DFLOAT)
+ rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
+ u = NA_PTR_TYPE(rblapack_u, doublereal*);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (5th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_givptr))
+ rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
+ if (NA_RANK(rblapack_givptr) != 1)
+ rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_givptr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_givptr) != NA_LINT)
+ rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
+ givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (14th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ 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);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (15th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
+ if (!NA_IsNArray(rblapack_vt))
+ rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_vt) != 2)
+ rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_vt) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
+ rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
+ if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
+ rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
+ vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
+ if (!NA_IsNArray(rblapack_difr))
+ rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_difr) != 2)
+ rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difr) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
+ rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
+ difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
+ if (!NA_IsNArray(rblapack_poles))
+ rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
+ if (NA_RANK(rblapack_poles) != 2)
+ rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_poles) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
+ rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
+ poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
+ if (!NA_IsNArray(rblapack_perm))
+ rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
+ if (NA_RANK(rblapack_perm) != 2)
+ rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
+ ldgcol = NA_SHAPE0(rblapack_perm);
+ if (NA_SHAPE1(rblapack_perm) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_perm) != NA_LINT)
+ rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
+ perm = NA_PTR_TYPE(rblapack_perm, integer*);
+ ldbx = n;
+ if (!NA_IsNArray(rblapack_difl))
+ rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_difl) != 2)
+ rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_difl) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_difl) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
+ rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
+ difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
+ if (!NA_IsNArray(rblapack_givcol))
+ rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
+ if (NA_RANK(rblapack_givcol) != 2)
+ rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givcol) != ldgcol)
+ rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
+ if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givcol) != NA_LINT)
+ rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
+ givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_z) != nlvl)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
+ if (NA_TYPE(rblapack_z) != NA_DFLOAT)
+ rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
+ z = NA_PTR_TYPE(rblapack_z, doublereal*);
+ if (!NA_IsNArray(rblapack_givnum))
+ rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
+ if (NA_RANK(rblapack_givnum) != 2)
+ rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_givnum) != ldu)
+ rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
+ if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
+ rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
+ if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
+ rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
+ givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldbx;
+ shape[1] = nrhs;
+ rblapack_bx = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ bx = NA_PTR_TYPE(rblapack_bx, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ rwork = ALLOC_N(doublereal, (MAX(n,(smlsiz+1)*nrhs*3)));
+ iwork = ALLOC_N(integer, (3 * n));
+
+ zlalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, rwork, iwork, &info);
+
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zlalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlalsa", rblapack_zlalsa, -1);
+}
diff --git a/ext/zlalsd.c b/ext/zlalsd.c
new file mode 100644
index 0000000..39ff754
--- /dev/null
+++ b/ext/zlalsd.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID zlalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, doublereal* d, doublereal* e, doublecomplex* b, integer* ldb, doublereal* rcond, integer* rank, doublecomplex* work, doublereal* rwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zlalsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_smlsiz;
+ integer smlsiz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+ integer nlvl;
+
+ 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 rank, info, d, e, b = NumRu::Lapack.zlalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) DOUBLE PRECISION\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) COMPLEX*16 array, dimension at least\n* (N * NRHS).\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n* where\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*\n* IWORK (workspace) INTEGER array, dimension at least\n* (3*N*NLVL + 11*N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.zlalsd( uplo, smlsiz, d, e, b, rcond, [: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_smlsiz = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_b = argv[4];
+ rblapack_rcond = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ smlsiz = NUM2INT(rblapack_smlsiz);
+ rcond = NUM2DBL(rblapack_rcond);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ nlvl = ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublecomplex, (n * nrhs));
+ rwork = ALLOC_N(doublereal, (9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)));
+ iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
+
+ zlalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, rwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_zlalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlalsd", rblapack_zlalsd, -1);
+}
diff --git a/ext/zlangb.c b/ext/zlangb.c
new file mode 100644
index 0000000..ca23494
--- /dev/null
+++ b/ext/zlangb.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern doublereal zlangb_(char* norm, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* work);
+
+
+static VALUE
+rblapack_zlangb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer ldab;
+ 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 __out__ = NumRu::Lapack.zlangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* ZLANGB returns the value\n*\n* ZLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlangb( norm, kl, ku, ab, [: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_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ ku = NUM2INT(rblapack_ku);
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ work = ALLOC_N(doublereal, (MAX(1,lsame_(&norm,"I") ? n : 0)));
+
+ __out__ = zlangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlangb", rblapack_zlangb, -1);
+}
diff --git a/ext/zlange.c b/ext/zlange.c
new file mode 100644
index 0000000..fd74c11
--- /dev/null
+++ b/ext/zlange.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern doublereal zlange_(char* norm, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_zlange(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex matrix A.\n*\n* Description\n* ===========\n*\n* ZLANGE returns the value\n*\n* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* ZLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* ZLANGE is set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlange( norm, m, a, [: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_norm = argv[0];
+ rblapack_m = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlange_(&norm, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlange", rblapack_zlange, -1);
+}
diff --git a/ext/zlangt.c b/ext/zlangt.c
new file mode 100644
index 0000000..09c349d
--- /dev/null
+++ b/ext/zlangt.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern doublereal zlangt_(char* norm, integer* n, doublecomplex* dl, doublecomplex* d, doublecomplex* du);
+
+
+static VALUE
+rblapack_zlangt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_dl;
+ doublecomplex *dl;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_du;
+ doublecomplex *du;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ 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 __out__ = NumRu::Lapack.zlangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* ZLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* ZLANGT returns the value\n*\n* ZLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANGT is\n* set to zero.\n*\n* DL (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) sub-diagonal elements of A.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlangt( norm, dl, d, du, [: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_dl = argv[1];
+ rblapack_d = argv[2];
+ rblapack_du = argv[3];
+ if (argc == 4) {
+ } 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
+ dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
+ du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
+
+ __out__ = zlangt_(&norm, &n, dl, d, du);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlangt", rblapack_zlangt, -1);
+}
diff --git a/ext/zlanhb.c b/ext/zlanhb.c
new file mode 100644
index 0000000..7cfc6fe
--- /dev/null
+++ b/ext/zlanhb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern doublereal zlanhb_(char* norm, char* uplo, integer* n, integer* k, doublecomplex* ab, integer* ldab, doublereal* work);
+
+
+static VALUE
+rblapack_zlanhb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlanhb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n hermitian band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* ZLANHB returns the value\n*\n* ZLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangle of the hermitian band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhb( norm, uplo, k, ab, [: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_k = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ k = NUM2INT(rblapack_k);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlanhb_(&norm, &uplo, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlanhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlanhb", rblapack_zlanhb, -1);
+}
diff --git a/ext/zlanhe.c b/ext/zlanhe.c
new file mode 100644
index 0000000..0a89bf1
--- /dev/null
+++ b/ext/zlanhe.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern doublereal zlanhe_(char* norm, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_zlanhe(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlanhe( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A.\n*\n* Description\n* ===========\n*\n* ZLANHE returns the value\n*\n* ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHE as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHE is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The hermitian matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced. Note that the imaginary parts of the diagonal\n* elements need not be set and are assumed to be zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhe( norm, uplo, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlanhe_(&norm, &uplo, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlanhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlanhe", rblapack_zlanhe, -1);
+}
diff --git a/ext/zlanhf.c b/ext/zlanhf.c
new file mode 100644
index 0000000..8358a33
--- /dev/null
+++ b/ext/zlanhf.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern doublereal zlanhf_(char* norm, char* transr, char* uplo, integer* n, doublecomplex* a, doublereal* work);
+
+
+static VALUE
+rblapack_zlanhf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlanhf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* ZLANHF returns the value\n*\n* ZLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER\n* Specifies the value to be returned in ZLANHF as described\n* above.\n*\n* TRANSR (input) CHARACTER\n* Specifies whether the RFP format of A is normal or\n* conjugate-transposed format.\n* = 'N': RFP format is Normal\n* = 'C': RFP format is Conjugate-transposed\n*\n* UPLO (input) CHARACTER\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n*\n* UPLO = 'U' or 'u' RFP A came from an upper triangular\n* matrix\n*\n* UPLO = 'L' or 'l' RFP A came from a lower triangular\n* matrix\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHF is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n* as defined when TRANSR = 'N'. The contents of RFP A are\n* defined by UPLO as follows: If UPLO = 'U' the RFP A\n* contains the ( N*(N+1)/2 ) elements of upper packed A\n* either in normal or conjugate-transpose Format. If\n* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n* of lower packed A either in normal or conjugate-transpose\n* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n* TRANSR is 'N' the LDA is N+1 when N is even and is N when\n* is odd. See the Note below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhf( norm, transr, uplo, n, a, [: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_norm = argv[0];
+ rblapack_transr = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ work = ALLOC_N(doublereal, (lwork));
+
+ __out__ = zlanhf_(&norm, &transr, &uplo, &n, a, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlanhf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlanhf", rblapack_zlanhf, -1);
+}
diff --git a/ext/zlanhp.c b/ext/zlanhp.c
new file mode 100644
index 0000000..88e8e24
--- /dev/null
+++ b/ext/zlanhp.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern doublereal zlanhp_(char* norm, char* uplo, integer* n, doublecomplex* ap, doublereal* work);
+
+
+static VALUE
+rblapack_zlanhp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlanhp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* ZLANHP returns the value\n*\n* ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHP is\n* set to zero.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhp( norm, uplo, 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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlanhp_(&norm, &uplo, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlanhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlanhp", rblapack_zlanhp, -1);
+}
diff --git a/ext/zlanhs.c b/ext/zlanhs.c
new file mode 100644
index 0000000..b326519
--- /dev/null
+++ b/ext/zlanhs.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern doublereal zlanhs_(char* norm, integer* n, doublecomplex* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_zlanhs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* ZLANHS returns the value\n*\n* ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHS is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhs( norm, 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_norm = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlanhs_(&norm, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlanhs", rblapack_zlanhs, -1);
+}
diff --git a/ext/zlanht.c b/ext/zlanht.c
new file mode 100644
index 0000000..1e2cddc
--- /dev/null
+++ b/ext/zlanht.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern doublereal zlanht_(char* norm, integer* n, doublereal* d, doublecomplex* e);
+
+
+static VALUE
+rblapack_zlanht(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack___out__;
+ doublereal __out__;
+
+ 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 __out__ = NumRu::Lapack.zlanht( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* ZLANHT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* ZLANHT returns the value\n*\n* ZLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHT is\n* set to zero.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanht( norm, d, e, [: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_norm = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+
+ __out__ = zlanht_(&norm, &n, d, e);
+
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlanht(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlanht", rblapack_zlanht, -1);
+}
diff --git a/ext/zlansb.c b/ext/zlansb.c
new file mode 100644
index 0000000..e97f96b
--- /dev/null
+++ b/ext/zlansb.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern doublereal zlansb_(char* norm, char* uplo, integer* n, integer* k, doublecomplex* ab, integer* ldab, doublereal* work);
+
+
+static VALUE
+rblapack_zlansb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* ZLANSB returns the value\n*\n* ZLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlansb( norm, uplo, k, ab, [: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_k = argv[2];
+ rblapack_ab = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ k = NUM2INT(rblapack_k);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlansb", rblapack_zlansb, -1);
+}
diff --git a/ext/zlansp.c b/ext/zlansp.c
new file mode 100644
index 0000000..381d7e6
--- /dev/null
+++ b/ext/zlansp.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern doublereal zlansp_(char* norm, char* uplo, integer* n, doublecomplex* ap, doublereal* work);
+
+
+static VALUE
+rblapack_zlansp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* ZLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* ZLANSP returns the value\n*\n* ZLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANSP is\n* set to zero.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlansp( norm, uplo, 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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlansp_(&norm, &uplo, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlansp", rblapack_zlansp, -1);
+}
diff --git a/ext/zlansy.c b/ext/zlansy.c
new file mode 100644
index 0000000..9355ca1
--- /dev/null
+++ b/ext/zlansy.c
@@ -0,0 +1,74 @@
+#include "rb_lapack.h"
+
+extern doublereal zlansy_(char* norm, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_zlansy(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A.\n*\n* Description\n* ===========\n*\n* ZLANSY returns the value\n*\n* ZLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANSY is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlansy( norm, uplo, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlansy_(&norm, &uplo, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlansy", rblapack_zlansy, -1);
+}
diff --git a/ext/zlantb.c b/ext/zlantb.c
new file mode 100644
index 0000000..c1420f7
--- /dev/null
+++ b/ext/zlantb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern doublereal zlantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, doublecomplex* ab, integer* ldab, doublereal* work);
+
+
+static VALUE
+rblapack_zlantb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer ldab;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* ZLANTB returns the value\n*\n* ZLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlantb( norm, uplo, diag, k, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_k = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = lsame_(&norm,"I") ? n : 0;
+ k = NUM2INT(rblapack_k);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlantb", rblapack_zlantb, -1);
+}
diff --git a/ext/zlantp.c b/ext/zlantp.c
new file mode 100644
index 0000000..d074b1b
--- /dev/null
+++ b/ext/zlantp.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern doublereal zlantp_(char* norm, char* uplo, char* diag, integer* n, doublecomplex* ap, doublereal* work);
+
+
+static VALUE
+rblapack_zlantp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* ZLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* ZLANTP returns the value\n*\n* ZLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANTP is\n* set to zero.\n*\n* AP (input) COMPLEX*16 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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlantp( norm, uplo, diag, n, ap, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_ap = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ lwork = lsame_(&norm,"I") ? n : 0;
+ 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) != (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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlantp_(&norm, &uplo, &diag, &n, ap, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlantp", rblapack_zlantp, -1);
+}
diff --git a/ext/zlantr.c b/ext/zlantr.c
new file mode 100644
index 0000000..470f73e
--- /dev/null
+++ b/ext/zlantr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern doublereal zlantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* work);
+
+
+static VALUE
+rblapack_zlantr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack___out__;
+ doublereal __out__;
+ doublereal *work;
+
+ integer lda;
+ integer n;
+ integer lwork;
+
+ 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 __out__ = NumRu::Lapack.zlantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* ZLANTR returns the value\n*\n* ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, ZLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, ZLANTR is set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlantr( norm, uplo, diag, m, a, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_m = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ m = NUM2INT(rblapack_m);
+ lwork = lsame_(&norm,"I") ? m : 0;
+ work = ALLOC_N(doublereal, (MAX(1,lwork)));
+
+ __out__ = zlantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
+
+ free(work);
+ rblapack___out__ = rb_float_new((double)__out__);
+ return rblapack___out__;
+}
+
+void
+init_lapack_zlantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlantr", rblapack_zlantr, -1);
+}
diff --git a/ext/zlapll.c b/ext/zlapll.c
new file mode 100644
index 0000000..0846ef5
--- /dev/null
+++ b/ext/zlapll.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID zlapll_(integer* n, doublecomplex* x, integer* incx, doublecomplex* y, integer* incy, doublereal* ssmin);
+
+
+static VALUE
+rblapack_zlapll(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_ssmin;
+ doublereal ssmin;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_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 ssmin, x, y = NumRu::Lapack.zlapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) DOUBLE PRECISION\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.zlapll( n, x, incx, y, incy, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ 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__;
+
+ zlapll_(&n, x, &incx, y, &incy, &ssmin);
+
+ rblapack_ssmin = rb_float_new((double)ssmin);
+ return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_zlapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlapll", rblapack_zlapll, -1);
+}
diff --git a/ext/zlapmr.c b/ext/zlapmr.c
new file mode 100644
index 0000000..3c48bca
--- /dev/null
+++ b/ext/zlapmr.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zlapmr_(logical* forwrd, integer* m, integer* n, doublecomplex* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_zlapmr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ integer ldx;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.zlapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* ZLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n COMPLEX*16 TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.zlapmr( forwrd, x, k, [: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_forwrd = argv[0];
+ rblapack_x = argv[1];
+ rblapack_k = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (3th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_k);
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ zlapmr_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_zlapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlapmr", rblapack_zlapmr, -1);
+}
diff --git a/ext/zlapmt.c b/ext/zlapmt.c
new file mode 100644
index 0000000..8f66d32
--- /dev/null
+++ b/ext/zlapmt.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID zlapmt_(logical* forwrd, integer* m, integer* n, doublecomplex* x, integer* ldx, integer* k);
+
+
+static VALUE
+rblapack_zlapmt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_forwrd;
+ logical forwrd;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_k;
+ integer *k;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_k_out__;
+ integer *k_out__;
+
+ 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 x, k = NumRu::Lapack.zlapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* ZLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, IN, J\n COMPLEX*16 TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.zlapmt( forwrd, m, x, k, [: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_forwrd = argv[0];
+ rblapack_m = argv[1];
+ rblapack_x = argv[2];
+ rblapack_k = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ forwrd = (rblapack_forwrd == Qtrue);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_k))
+ rb_raise(rb_eArgError, "k (4th argument) must be NArray");
+ if (NA_RANK(rblapack_k) != 1)
+ rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_k) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
+ if (NA_TYPE(rblapack_k) != NA_LINT)
+ rblapack_k = na_change_type(rblapack_k, NA_LINT);
+ k = NA_PTR_TYPE(rblapack_k, integer*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
+ MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
+ rblapack_k = rblapack_k_out__;
+ k = k_out__;
+
+ zlapmt_(&forwrd, &m, &n, x, &ldx, k);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_k);
+}
+
+void
+init_lapack_zlapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlapmt", rblapack_zlapmt, -1);
+}
diff --git a/ext/zlaqgb.c b/ext/zlaqgb.c
new file mode 100644
index 0000000..881ea86
--- /dev/null
+++ b/ext/zlaqgb.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqgb_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqgb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.zlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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, ab = NumRu::Lapack.zlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [: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_kl = argv[0];
+ rblapack_ku = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_r = argv[3];
+ rblapack_c = argv[4];
+ rblapack_rowcnd = argv[5];
+ rblapack_colcnd = argv[6];
+ rblapack_amax = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ kl = NUM2INT(rblapack_kl);
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ colcnd = NUM2DBL(rblapack_colcnd);
+ ku = NUM2INT(rblapack_ku);
+ rowcnd = NUM2DBL(rblapack_rowcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (4th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ amax = NUM2DBL(rblapack_amax);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zlaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_zlaqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqgb", rblapack_zlaqgb, -1);
+}
diff --git a/ext/zlaqge.c b/ext/zlaqge.c
new file mode 100644
index 0000000..4a53108
--- /dev/null
+++ b/ext/zlaqge.c
@@ -0,0 +1,109 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqge_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqge(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_r;
+ doublereal *r;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_rowcnd;
+ doublereal rowcnd;
+ VALUE rblapack_colcnd;
+ doublereal colcnd;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.zlaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row 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.zlaqge( a, r, c, rowcnd, colcnd, amax, [: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_a = argv[0];
+ rblapack_r = argv[1];
+ rblapack_c = argv[2];
+ rblapack_rowcnd = argv[3];
+ rblapack_colcnd = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (3th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ colcnd = NUM2DBL(rblapack_colcnd);
+ if (!NA_IsNArray(rblapack_r))
+ rb_raise(rb_eArgError, "r (2th argument) must be NArray");
+ if (NA_RANK(rblapack_r) != 1)
+ rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_r);
+ if (NA_TYPE(rblapack_r) != NA_DFLOAT)
+ rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
+ r = NA_PTR_TYPE(rblapack_r, doublereal*);
+ amax = NUM2DBL(rblapack_amax);
+ rowcnd = NUM2DBL(rblapack_rowcnd);
+ {
+ int 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__;
+
+ zlaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_a);
+}
+
+void
+init_lapack_zlaqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqge", rblapack_zlaqge, -1);
+}
diff --git a/ext/zlaqhb.c b/ext/zlaqhb.c
new file mode 100644
index 0000000..04651f6
--- /dev/null
+++ b/ext/zlaqhb.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqhb_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqhb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ 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 s, equed, ab = NumRu::Lapack.zlaqhb( uplo, kd, ab, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQHB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (output) 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 s, equed, ab = NumRu::Lapack.zlaqhb( uplo, kd, ab, 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_kd = argv[1];
+ rblapack_ab = 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_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ amax = NUM2DBL(rblapack_amax);
+ kd = NUM2INT(rblapack_kd);
+ scond = NUM2DBL(rblapack_scond);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zlaqhb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(3, rblapack_s, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_zlaqhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqhb", rblapack_zlaqhb, -1);
+}
diff --git a/ext/zlaqhe.c b/ext/zlaqhe.c
new file mode 100644
index 0000000..9094cac
--- /dev/null
+++ b/ext/zlaqhe.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqhe_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqhe(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.zlaqhe( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQHE equilibrates a Hermitian 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* Hermitian 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 Hermitian 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.zlaqhe( 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);
+ {
+ int 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__;
+
+ zlaqhe_(&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_zlaqhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqhe", rblapack_zlaqhe, -1);
+}
diff --git a/ext/zlaqhp.c b/ext/zlaqhp.c
new file mode 100644
index 0000000..b3bbcd6
--- /dev/null
+++ b/ext/zlaqhp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqhp_(char* uplo, integer* n, doublecomplex* ap, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqhp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+
+ 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, ap = NumRu::Lapack.zlaqhp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQHP equilibrates a Hermitian 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* Hermitian 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\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, ap = NumRu::Lapack.zlaqhp( uplo, ap, 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_ap = 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ scond = NUM2DBL(rblapack_scond);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zlaqhp_(&uplo, &n, ap, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ap);
+}
+
+void
+init_lapack_zlaqhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqhp", rblapack_zlaqhp, -1);
+}
diff --git a/ext/zlaqp2.c b/ext/zlaqp2.c
new file mode 100644
index 0000000..db8d342
--- /dev/null
+++ b/ext/zlaqp2.c
@@ -0,0 +1,158 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqp2_(integer* m, integer* n, integer* offset, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublereal* vn1, doublereal* vn2, doublecomplex* work);
+
+
+static VALUE
+rblapack_zlaqp2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ doublereal *vn1;
+ VALUE rblapack_vn2;
+ doublereal *vn2;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ doublereal *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ doublereal *vn2_out__;
+ doublecomplex *work;
+
+ 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 tau, a, jpvt, vn1, vn2 = NumRu::Lapack.zlaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* ZLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is\n* the triangular factor obtained; the elements in block\n* A(OFFSET+1:M,1:N) below the diagonal, together with the\n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.zlaqp2( m, offset, a, jpvt, vn1, vn2, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ {
+ int shape[1];
+ shape[0] = MIN(m,n);
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
+ MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
+ MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zlaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
+
+ free(work);
+ return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
+}
+
+void
+init_lapack_zlaqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqp2", rblapack_zlaqp2, -1);
+}
diff --git a/ext/zlaqps.c b/ext/zlaqps.c
new file mode 100644
index 0000000..1098957
--- /dev/null
+++ b/ext/zlaqps.c
@@ -0,0 +1,208 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublereal* vn1, doublereal* vn2, doublecomplex* auxv, doublecomplex* f, integer* ldf);
+
+
+static VALUE
+rblapack_zlaqps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_offset;
+ integer offset;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_jpvt;
+ integer *jpvt;
+ VALUE rblapack_vn1;
+ doublereal *vn1;
+ VALUE rblapack_vn2;
+ doublereal *vn2;
+ VALUE rblapack_auxv;
+ doublecomplex *auxv;
+ VALUE rblapack_f;
+ doublecomplex *f;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_jpvt_out__;
+ integer *jpvt_out__;
+ VALUE rblapack_vn1_out__;
+ doublereal *vn1_out__;
+ VALUE rblapack_vn2_out__;
+ doublereal *vn2_out__;
+ VALUE rblapack_auxv_out__;
+ doublecomplex *auxv_out__;
+ VALUE rblapack_f_out__;
+ doublecomplex *f_out__;
+
+ integer lda;
+ integer n;
+ integer nb;
+ 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 kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.zlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* ZLAQPS computes a step of QR factorization with column pivoting\n* of a complex M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) COMPLEX*16 array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) COMPLEX*16 array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) COMPLEX*16 array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.zlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [: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_m = argv[0];
+ rblapack_offset = argv[1];
+ rblapack_a = argv[2];
+ rblapack_jpvt = argv[3];
+ rblapack_vn1 = argv[4];
+ rblapack_vn2 = argv[5];
+ rblapack_auxv = argv[6];
+ rblapack_f = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_vn1))
+ rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vn1) != 1)
+ rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn1) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
+ rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
+ vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
+ if (!NA_IsNArray(rblapack_auxv))
+ rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_auxv) != 1)
+ rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
+ nb = NA_SHAPE0(rblapack_auxv);
+ if (NA_TYPE(rblapack_auxv) != NA_DCOMPLEX)
+ rblapack_auxv = na_change_type(rblapack_auxv, NA_DCOMPLEX);
+ auxv = NA_PTR_TYPE(rblapack_auxv, doublecomplex*);
+ offset = NUM2INT(rblapack_offset);
+ if (!NA_IsNArray(rblapack_vn2))
+ rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vn2) != 1)
+ rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_vn2) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
+ rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
+ vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
+ if (!NA_IsNArray(rblapack_jpvt))
+ rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
+ if (NA_RANK(rblapack_jpvt) != 1)
+ rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpvt) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_jpvt) != NA_LINT)
+ rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
+ jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
+ 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) != nb)
+ rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
+ if (NA_TYPE(rblapack_f) != NA_DCOMPLEX)
+ rblapack_f = na_change_type(rblapack_f, NA_DCOMPLEX);
+ f = NA_PTR_TYPE(rblapack_f, doublecomplex*);
+ kb = nb;
+ {
+ int shape[1];
+ shape[0] = kb;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
+ MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
+ rblapack_jpvt = rblapack_jpvt_out__;
+ jpvt = jpvt_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
+ MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
+ rblapack_vn1 = rblapack_vn1_out__;
+ vn1 = vn1_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
+ MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
+ rblapack_vn2 = rblapack_vn2_out__;
+ vn2 = vn2_out__;
+ {
+ int shape[1];
+ shape[0] = nb;
+ rblapack_auxv_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, doublecomplex*);
+ MEMCPY(auxv_out__, auxv, doublecomplex, NA_TOTAL(rblapack_auxv));
+ rblapack_auxv = rblapack_auxv_out__;
+ auxv = auxv_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = nb;
+ rblapack_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublecomplex*);
+ MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+
+ zlaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
+
+ rblapack_kb = INT2NUM(kb);
+ return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
+}
+
+void
+init_lapack_zlaqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqps", rblapack_zlaqps, -1);
+}
diff --git a/ext/zlaqr0.c b/ext/zlaqr0.c
new file mode 100644
index 0000000..3b7fe54
--- /dev/null
+++ b/ext/zlaqr0.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zlaqr0(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer ldh;
+ 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 w, work, info, h, z = NumRu::Lapack.zlaqr0( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to ZGEBAL, and then passed to ZGEHRD when the\n* matrix output by ZGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then ZLAQR0 does a workspace query.\n* In this case, ZLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, ZLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.zlaqr0( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_h = argv[4];
+ rblapack_iloz = argv[5];
+ rblapack_ihiz = argv[6];
+ rblapack_z = argv[7];
+ rblapack_ldz = argv[8];
+ if (argc == 10) {
+ rblapack_lwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (5th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = NUM2INT(rblapack_ldz);
+ wantz = (rblapack_wantz == Qtrue);
+ iloz = NUM2INT(rblapack_iloz);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihi = NUM2INT(rblapack_ihi);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? ihi : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihi : 0);
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? ihi : 0;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zlaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqr0", rblapack_zlaqr0, -1);
+}
diff --git a/ext/zlaqr1.c b/ext/zlaqr1.c
new file mode 100644
index 0000000..1a901aa
--- /dev/null
+++ b/ext/zlaqr1.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr1_(integer* n, doublecomplex* h, integer* ldh, doublecomplex* s1, doublecomplex* s2, doublecomplex* v);
+
+
+static VALUE
+rblapack_zlaqr1(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_s1;
+ doublecomplex s1;
+ VALUE rblapack_s2;
+ doublecomplex s2;
+ VALUE rblapack_v;
+ doublecomplex *v;
+
+ integer ldh;
+ 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 v = NumRu::Lapack.zlaqr1( h, s1, s2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - s1*I)*(H - s2*I)\n*\n* scaling to avoid overflows and most underflows.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) COMPLEX*16 array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* S1 (input) COMPLEX*16\n* S2 S1 and S2 are the shifts defining K in (*) above.\n*\n* V (output) COMPLEX*16 array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n v = NumRu::Lapack.zlaqr1( h, s1, s2, [: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_h = argv[0];
+ rblapack_s1 = argv[1];
+ rblapack_s2 = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (1th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ s2.r = NUM2DBL(rb_funcall(rblapack_s2, rb_intern("real"), 0));
+ s2.i = NUM2DBL(rb_funcall(rblapack_s2, rb_intern("imag"), 0));
+ s1.r = NUM2DBL(rb_funcall(rblapack_s1, rb_intern("real"), 0));
+ s1.i = NUM2DBL(rb_funcall(rblapack_s1, rb_intern("imag"), 0));
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_v = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+
+ zlaqr1_(&n, h, &ldh, &s1, &s2, v);
+
+ return rblapack_v;
+}
+
+void
+init_lapack_zlaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqr1", rblapack_zlaqr1, -1);
+}
diff --git a/ext/zlaqr2.c b/ext/zlaqr2.c
new file mode 100644
index 0000000..85644aa
--- /dev/null
+++ b/ext/zlaqr2.c
@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* ns, integer* nd, doublecomplex* sh, doublecomplex* v, integer* ldv, integer* nh, doublecomplex* t, integer* ldt, integer* nv, doublecomplex* wv, integer* ldwv, doublecomplex* work, integer* lwork);
+
+
+static VALUE
+rblapack_zlaqr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sh;
+ doublecomplex *sh;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+ doublecomplex *v;
+ doublecomplex *t;
+ doublecomplex *wv;
+ doublecomplex *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldwv;
+ integer ldt;
+
+ 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 ns, nd, sh, h, z = NumRu::Lapack.zlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to ZLAQR3 except that it avoids\n* recursion by calling ZLAHQR instead of ZLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX*16 array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX*16 array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX*16 array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX*16 array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; ZLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.zlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(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*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+ wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+ work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
+
+ zlaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqr2", rblapack_zlaqr2, -1);
+}
diff --git a/ext/zlaqr3.c b/ext/zlaqr3.c
new file mode 100644
index 0000000..f71bd11
--- /dev/null
+++ b/ext/zlaqr3.c
@@ -0,0 +1,174 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* ns, integer* nd, doublecomplex* sh, doublecomplex* v, integer* ldv, integer* nh, doublecomplex* t, integer* ldt, integer* nv, doublecomplex* wv, integer* ldwv, doublecomplex* work, integer* lwork);
+
+
+static VALUE
+rblapack_zlaqr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_nw;
+ integer nw;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ns;
+ integer ns;
+ VALUE rblapack_nd;
+ integer nd;
+ VALUE rblapack_sh;
+ doublecomplex *sh;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+ doublecomplex *v;
+ doublecomplex *t;
+ doublecomplex *wv;
+ doublecomplex *work;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ldv;
+ integer ldwv;
+ integer ldt;
+
+ 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 ns, nd, sh, h, z = NumRu::Lapack.zlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX*16 array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX*16 array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX*16 array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX*16 array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; ZLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.zlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 11 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ktop = argv[2];
+ rblapack_kbot = argv[3];
+ rblapack_nw = argv[4];
+ rblapack_h = argv[5];
+ rblapack_iloz = argv[6];
+ rblapack_ihiz = argv[7];
+ rblapack_z = argv[8];
+ rblapack_nh = argv[9];
+ rblapack_nv = argv[10];
+ if (argc == 12) {
+ rblapack_lwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ktop = NUM2INT(rblapack_ktop);
+ nw = NUM2INT(rblapack_nw);
+ iloz = NUM2INT(rblapack_iloz);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (9th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(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*);
+ nv = NUM2INT(rblapack_nv);
+ ldwv = nw;
+ ldv = nw;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (6th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ if (NA_SHAPE1(rblapack_h) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ nh = NUM2INT(rblapack_nh);
+ ldt = nw;
+ kbot = NUM2INT(rblapack_kbot);
+ if (rblapack_lwork == Qnil)
+ lwork = 2*nw;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ihiz = NUM2INT(rblapack_ihiz);
+ {
+ int shape[1];
+ shape[0] = MAX(1,kbot);
+ rblapack_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+ t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+ wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
+ work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
+
+ zlaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
+
+ free(v);
+ free(t);
+ free(wv);
+ free(work);
+ rblapack_ns = INT2NUM(ns);
+ rblapack_nd = INT2NUM(nd);
+ return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqr3", rblapack_zlaqr3, -1);
+}
diff --git a/ext/zlaqr4.c b/ext/zlaqr4.c
new file mode 100644
index 0000000..844a8b4
--- /dev/null
+++ b/ext/zlaqr4.c
@@ -0,0 +1,147 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zlaqr4(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer ldh;
+ integer n;
+ integer ldz;
+ integer ihi;
+
+ 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 w, work, info, h, z = NumRu::Lapack.zlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to ZGEBAL, and then passed to ZGEHRD when the\n* matrix output by ZGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then ZLAQR4 does a workspace query.\n* In this case, ZLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, ZLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.zlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [: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_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_h = argv[3];
+ rblapack_iloz = argv[4];
+ rblapack_ihiz = argv[5];
+ rblapack_z = 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;
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ ilo = NUM2INT(rblapack_ilo);
+ iloz = NUM2INT(rblapack_iloz);
+ wantz = (rblapack_wantz == Qtrue);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = wantz ? MAX(1,ihiz) : 1;
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (4th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldz)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be wantz ? MAX(1,ihiz) : 1");
+ ihi = NA_SHAPE1(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*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = ihi;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zlaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqr4", rblapack_zlaqr4, -1);
+}
diff --git a/ext/zlaqr5.c b/ext/zlaqr5.c
new file mode 100644
index 0000000..91fd949
--- /dev/null
+++ b/ext/zlaqr5.c
@@ -0,0 +1,179 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, doublecomplex* s, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, doublecomplex* v, integer* ldv, doublecomplex* u, integer* ldu, integer* nv, doublecomplex* wv, integer* ldwv, integer* nh, doublecomplex* wh, integer* ldwh);
+
+
+static VALUE
+rblapack_zlaqr5(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantt;
+ logical wantt;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_kacc22;
+ integer kacc22;
+ VALUE rblapack_ktop;
+ integer ktop;
+ VALUE rblapack_kbot;
+ integer kbot;
+ VALUE rblapack_s;
+ doublecomplex *s;
+ VALUE rblapack_h;
+ doublecomplex *h;
+ VALUE rblapack_iloz;
+ integer iloz;
+ VALUE rblapack_ihiz;
+ integer ihiz;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_nv;
+ integer nv;
+ VALUE rblapack_nh;
+ integer nh;
+ VALUE rblapack_s_out__;
+ doublecomplex *s_out__;
+ VALUE rblapack_h_out__;
+ doublecomplex *h_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+ doublecomplex *v;
+ doublecomplex *u;
+ doublecomplex *wv;
+ doublecomplex *wh;
+
+ integer nshfts;
+ integer ldh;
+ integer n;
+ integer ldv;
+ integer ldu;
+ integer ldwv;
+ integer ldwh;
+
+ 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 s, h, z = NumRu::Lapack.zlaqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by ZLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the unitary Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: ZLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* S (input/output) COMPLEX*16 array of size (NSHFTS)\n* S contains the shifts of origin that define the multi-\n* shift QR sweep. On output S may be reordered.\n*\n* H (input/output) COMPLEX*16 array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) COMPLEX*16 array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep unitary\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) COMPLEX*16 array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) COMPLEX*16 array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) COMPLEX*16 array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, h, z = NumRu::Lapack.zlaqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_wantt = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_kacc22 = argv[2];
+ rblapack_ktop = argv[3];
+ rblapack_kbot = argv[4];
+ rblapack_s = argv[5];
+ rblapack_h = argv[6];
+ rblapack_iloz = argv[7];
+ rblapack_ihiz = argv[8];
+ rblapack_z = argv[9];
+ rblapack_ldz = argv[10];
+ rblapack_nv = argv[11];
+ rblapack_nh = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantt = (rblapack_wantt == Qtrue);
+ kacc22 = NUM2INT(rblapack_kacc22);
+ kbot = NUM2INT(rblapack_kbot);
+ if (!NA_IsNArray(rblapack_h))
+ rb_raise(rb_eArgError, "h (7th argument) must be NArray");
+ if (NA_RANK(rblapack_h) != 2)
+ rb_raise(rb_eArgError, "rank of h (7th argument) must be %d", 2);
+ ldh = NA_SHAPE0(rblapack_h);
+ n = NA_SHAPE1(rblapack_h);
+ if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
+ rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
+ h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
+ ihiz = NUM2INT(rblapack_ihiz);
+ ldz = NUM2INT(rblapack_ldz);
+ nh = NUM2INT(rblapack_nh);
+ ldv = 3;
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ nshfts = NA_SHAPE0(rblapack_s);
+ 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_z))
+ rb_raise(rb_eArgError, "z (10th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ ldwh = 3*nshfts-3;
+ ldu = 3*nshfts-3;
+ ktop = NUM2INT(rblapack_ktop);
+ nv = NUM2INT(rblapack_nv);
+ iloz = NUM2INT(rblapack_iloz);
+ ldwv = nv;
+ {
+ int shape[1];
+ shape[0] = nshfts;
+ rblapack_s_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublecomplex*);
+ MEMCPY(s_out__, s, doublecomplex, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldh;
+ shape[1] = n;
+ rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
+ MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
+ rblapack_h = rblapack_h_out__;
+ h = h_out__;
+ {
+ int shape[2];
+ shape[0] = wantz ? ldz : 0;
+ shape[1] = wantz ? ihiz : 0;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ v = ALLOC_N(doublecomplex, (ldv)*(nshfts/2));
+ u = ALLOC_N(doublecomplex, (ldu)*(3*nshfts-3));
+ wv = ALLOC_N(doublecomplex, (ldwv)*(3*nshfts-3));
+ wh = ALLOC_N(doublecomplex, (ldwh)*(MAX(1,nh)));
+
+ zlaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, s, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
+
+ free(v);
+ free(u);
+ free(wv);
+ free(wh);
+ return rb_ary_new3(3, rblapack_s, rblapack_h, rblapack_z);
+}
+
+void
+init_lapack_zlaqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqr5", rblapack_zlaqr5, -1);
+}
diff --git a/ext/zlaqsb.c b/ext/zlaqsb.c
new file mode 100644
index 0000000..a833687
--- /dev/null
+++ b/ext/zlaqsb.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqsb_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqsb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.zlaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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, ab = NumRu::Lapack.zlaqsb( uplo, kd, ab, s, scond, amax, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_s = argv[3];
+ rblapack_scond = argv[4];
+ rblapack_amax = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ scond = NUM2DBL(rblapack_scond);
+ kd = NUM2INT(rblapack_kd);
+ amax = NUM2DBL(rblapack_amax);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zlaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ab);
+}
+
+void
+init_lapack_zlaqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqsb", rblapack_zlaqsb, -1);
+}
diff --git a/ext/zlaqsp.c b/ext/zlaqsp.c
new file mode 100644
index 0000000..947473c
--- /dev/null
+++ b/ext/zlaqsp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID zlaqsp_(char* uplo, integer* n, doublecomplex* ap, doublereal* s, doublereal* scond, doublereal* amax, char* equed);
+
+
+static VALUE
+rblapack_zlaqsp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+
+ 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, ap = NumRu::Lapack.zlaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQSP 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\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, ap = NumRu::Lapack.zlaqsp( uplo, ap, 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_ap = 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ scond = NUM2DBL(rblapack_scond);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zlaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
+
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(2, rblapack_equed, rblapack_ap);
+}
+
+void
+init_lapack_zlaqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaqsp", rblapack_zlaqsp, -1);
+}
diff --git a/ext/zlaqsy.c b/ext/zlaqsy.c
new file mode 100644
index 0000000..78b294d
--- /dev/null
+++ b/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);
+ {
+ int 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);
+}
diff --git a/ext/zlar1v.c b/ext/zlar1v.c
new file mode 100644
index 0000000..fa073e4
--- /dev/null
+++ b/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*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int 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);
+}
diff --git a/ext/zlar2v.c b/ext/zlar2v.c
new file mode 100644
index 0000000..367627b
--- /dev/null
+++ b/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*);
+ {
+ int 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__;
+ {
+ int 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__;
+ {
+ int 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);
+}
diff --git a/ext/zlarcm.c b/ext/zlarcm.c
new file mode 100644
index 0000000..f35f1f1
--- /dev/null
+++ b/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*);
+ {
+ int 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);
+}
diff --git a/ext/zlarf.c b/ext/zlarf.c
new file mode 100644
index 0000000..071bc92
--- /dev/null
+++ b/ext/zlarf.c
@@ -0,0 +1,102 @@
+#include "rb_lapack.h"
+
+extern VOID zlarf_(char* side, integer* m, integer* n, doublecomplex* v, integer* incv, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work);
+
+
+static VALUE
+rblapack_zlarf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ doublecomplex tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *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 c = NumRu::Lapack.zlarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* ZLARF applies a complex elementary reflector H to a complex M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX*16 array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarf( side, m, v, incv, tau, c, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_v = argv[2];
+ rblapack_incv = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ m = NUM2INT(rblapack_m);
+ tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (3th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zlarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_zlarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarf", rblapack_zlarf, -1);
+}
diff --git a/ext/zlarfb.c b/ext/zlarfb.c
new file mode 100644
index 0000000..fd47ef8
--- /dev/null
+++ b/ext/zlarfb.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID zlarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, doublecomplex* v, integer* ldv, doublecomplex* t, integer* ldt, doublecomplex* c, integer* ldc, doublecomplex* work, integer* ldwork);
+
+
+static VALUE
+rblapack_zlarfb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.zlarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* ZLARFB applies a complex block reflector H or its transpose H' to a\n* complex M-by-N matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) COMPLEX*16 array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX*16 array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarfb( side, trans, direct, storev, m, v, t, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_v = argv[5];
+ rblapack_t = argv[6];
+ rblapack_c = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (7th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (6th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (ldwork)*(k));
+
+ zlarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_zlarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarfb", rblapack_zlarfb, -1);
+}
diff --git a/ext/zlarfg.c b/ext/zlarfg.c
new file mode 100644
index 0000000..cbc6644
--- /dev/null
+++ b/ext/zlarfg.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID zlarfg_(integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* tau);
+
+
+static VALUE
+rblapack_zlarfg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ doublecomplex tau;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_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 tau, alpha, x = NumRu::Lapack.zlarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* ZLARFG generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, with beta real, and x is an\n* (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX*16\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX*16 array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX*16\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.zlarfg( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(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__;
+
+ zlarfg_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
+ rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_zlarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarfg", rblapack_zlarfg, -1);
+}
diff --git a/ext/zlarfgp.c b/ext/zlarfgp.c
new file mode 100644
index 0000000..5a42aba
--- /dev/null
+++ b/ext/zlarfgp.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID zlarfgp_(integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* tau);
+
+
+static VALUE
+rblapack_zlarfgp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_tau;
+ doublecomplex tau;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_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 tau, alpha, x = NumRu::Lapack.zlarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* ZLARFGP generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is real and non-negative, and\n* x is an (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX*16\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX*16 array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX*16\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.zlarfgp( n, alpha, x, incx, [: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_n = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-2)*abs(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__;
+
+ zlarfgp_(&n, &alpha, x, &incx, &tau);
+
+ rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
+ rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
+ return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
+}
+
+void
+init_lapack_zlarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarfgp", rblapack_zlarfgp, -1);
+}
diff --git a/ext/zlarft.c b/ext/zlarft.c
new file mode 100644
index 0000000..5b04dd6
--- /dev/null
+++ b/ext/zlarft.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID zlarft_(char* direct, char* storev, integer* n, integer* k, doublecomplex* v, integer* ldv, doublecomplex* tau, doublecomplex* t, integer* ldt);
+
+
+static VALUE
+rblapack_zlarft(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_v_out__;
+ doublecomplex *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.zlarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* ZLARFT forms the triangular factor T of a complex block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX*16 array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX*16 array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.zlarft( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
+ MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ zlarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_zlarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarft", rblapack_zlarft, -1);
+}
diff --git a/ext/zlarfx.c b/ext/zlarfx.c
new file mode 100644
index 0000000..fe293d7
--- /dev/null
+++ b/ext/zlarfx.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID zlarfx_(char* side, integer* m, integer* n, doublecomplex* v, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work);
+
+
+static VALUE
+rblapack_zlarfx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_tau;
+ doublecomplex tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer m;
+ 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 c = NumRu::Lapack.zlarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* ZLARFX applies a complex elementary reflector H to a complex m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarfx( side, v, tau, c, [: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_side = argv[0];
+ rblapack_v = argv[1];
+ rblapack_tau = argv[2];
+ rblapack_c = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (2th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (4th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zlarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_zlarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarfx", rblapack_zlarfx, -1);
+}
diff --git a/ext/zlargv.c b/ext/zlargv.c
new file mode 100644
index 0000000..100b330
--- /dev/null
+++ b/ext/zlargv.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID zlargv_(integer* n, doublecomplex* x, integer* incx, doublecomplex* y, integer* incy, doublereal* c, integer* incc);
+
+
+static VALUE
+rblapack_zlargv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_incc;
+ integer incc;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_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 c, x, y = NumRu::Lapack.zlargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* ZLARGV generates a vector of complex plane rotations with real\n* cosines, determined by elements of the complex vectors x and y.\n* For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( r(i) )\n* ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 )\n*\n* where c(i)**2 + ABS(s(i))**2 = 1\n*\n* The following conventions are used (these are the same as in ZLARTG,\n* but differ from the BLAS1 routine ZROTG):\n* If y(i)=0, then c(i)=1 and s(i)=0.\n* If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* Further Details\n* ======= =======\n*\n* 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.zlargv( n, x, incx, y, incy, incc, [: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_n = argv[0];
+ rblapack_x = argv[1];
+ rblapack_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = argv[4];
+ rblapack_incc = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ n = NUM2INT(rblapack_n);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ 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*);
+ incc = NUM2INT(rblapack_incc);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incc;
+ rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ 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__;
+
+ zlargv_(&n, x, &incx, y, &incy, c, &incc);
+
+ return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_zlargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlargv", rblapack_zlargv, -1);
+}
diff --git a/ext/zlarnv.c b/ext/zlarnv.c
new file mode 100644
index 0000000..7e90ea8
--- /dev/null
+++ b/ext/zlarnv.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID zlarnv_(integer* idist, integer* iseed, integer* n, doublecomplex* x);
+
+
+static VALUE
+rblapack_zlarnv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_idist;
+ integer idist;
+ VALUE rblapack_iseed;
+ integer *iseed;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_iseed_out__;
+ integer *iseed_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, iseed = NumRu::Lapack.zlarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* ZLARNV returns a vector of n random complex numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: real and imaginary parts each uniform (0,1)\n* = 2: real and imaginary parts each uniform (-1,1)\n* = 3: real and imaginary parts each normal (0,1)\n* = 4: uniformly distributed on the disc abs(z) < 1\n* = 5: uniformly distributed on the circle abs(z) = 1\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) COMPLEX*16 array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine DLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.zlarnv( idist, iseed, n, [: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_idist = argv[0];
+ rblapack_iseed = argv[1];
+ rblapack_n = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ idist = NUM2INT(rblapack_idist);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_iseed))
+ rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
+ if (NA_RANK(rblapack_iseed) != 1)
+ rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iseed) != (4))
+ rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
+ if (NA_TYPE(rblapack_iseed) != NA_LINT)
+ rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
+ iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,n);
+ rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 4;
+ rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
+ MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
+ rblapack_iseed = rblapack_iseed_out__;
+ iseed = iseed_out__;
+
+ zlarnv_(&idist, iseed, &n, x);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_iseed);
+}
+
+void
+init_lapack_zlarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarnv", rblapack_zlarnv, -1);
+}
diff --git a/ext/zlarrv.c b/ext/zlarrv.c
new file mode 100644
index 0000000..34ec952
--- /dev/null
+++ b/ext/zlarrv.c
@@ -0,0 +1,271 @@
+#include "rb_lapack.h"
+
+extern VOID zlarrv_(integer* n, doublereal* vl, doublereal* vu, doublereal* d, doublereal* l, doublereal* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, doublereal* minrgp, doublereal* rtol1, doublereal* rtol2, doublereal* w, doublereal* werr, doublereal* wgap, integer* iblock, integer* indexw, doublereal* gers, doublecomplex* z, integer* ldz, integer* isuppz, doublereal* work, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zlarrv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_l;
+ doublereal *l;
+ VALUE rblapack_pivmin;
+ doublereal pivmin;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_dol;
+ integer dol;
+ VALUE rblapack_dou;
+ integer dou;
+ VALUE rblapack_minrgp;
+ doublereal minrgp;
+ VALUE rblapack_rtol1;
+ doublereal rtol1;
+ VALUE rblapack_rtol2;
+ doublereal rtol2;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_werr;
+ doublereal *werr;
+ VALUE rblapack_wgap;
+ doublereal *wgap;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_indexw;
+ integer *indexw;
+ VALUE rblapack_gers;
+ doublereal *gers;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_l_out__;
+ doublereal *l_out__;
+ VALUE rblapack_w_out__;
+ doublereal *w_out__;
+ VALUE rblapack_werr_out__;
+ doublereal *werr_out__;
+ VALUE rblapack_wgap_out__;
+ doublereal *wgap_out__;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+
+ 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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.zlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by DLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by DLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (in) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) DOUBLE PRECISION\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from DLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in ZLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in DLARRB when refining a child's eigenvalues.\n* =-2: Problem in DLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in DLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.zlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 18 && argc != 18)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
+ rblapack_vl = argv[0];
+ rblapack_vu = argv[1];
+ rblapack_d = argv[2];
+ rblapack_l = argv[3];
+ rblapack_pivmin = argv[4];
+ rblapack_isplit = argv[5];
+ rblapack_m = argv[6];
+ rblapack_dol = argv[7];
+ rblapack_dou = argv[8];
+ rblapack_minrgp = argv[9];
+ rblapack_rtol1 = argv[10];
+ rblapack_rtol2 = argv[11];
+ rblapack_w = argv[12];
+ rblapack_werr = argv[13];
+ rblapack_wgap = argv[14];
+ rblapack_iblock = argv[15];
+ rblapack_indexw = argv[16];
+ rblapack_gers = argv[17];
+ if (argc == 18) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ vl = NUM2DBL(rblapack_vl);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ pivmin = NUM2DBL(rblapack_pivmin);
+ m = NUM2INT(rblapack_m);
+ dou = NUM2INT(rblapack_dou);
+ rtol1 = NUM2DBL(rblapack_rtol1);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (13th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ if (!NA_IsNArray(rblapack_wgap))
+ rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
+ if (NA_RANK(rblapack_wgap) != 1)
+ rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_wgap) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
+ rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
+ wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
+ if (!NA_IsNArray(rblapack_indexw))
+ rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
+ if (NA_RANK(rblapack_indexw) != 1)
+ rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_indexw) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_indexw) != NA_LINT)
+ rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
+ indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
+ vu = NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ minrgp = NUM2DBL(rblapack_minrgp);
+ if (!NA_IsNArray(rblapack_werr))
+ rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
+ if (NA_RANK(rblapack_werr) != 1)
+ rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_werr) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
+ rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
+ werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
+ if (!NA_IsNArray(rblapack_l))
+ rb_raise(rb_eArgError, "l (4th argument) must be NArray");
+ if (NA_RANK(rblapack_l) != 1)
+ rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_l) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_l) != NA_DFLOAT)
+ rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
+ l = NA_PTR_TYPE(rblapack_l, doublereal*);
+ rtol2 = NUM2DBL(rblapack_rtol2);
+ dol = NUM2INT(rblapack_dol);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ ldz = n;
+ if (!NA_IsNArray(rblapack_gers))
+ rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
+ if (NA_RANK(rblapack_gers) != 1)
+ rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_gers) != (2*n))
+ rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
+ if (NA_TYPE(rblapack_gers) != NA_DFLOAT)
+ rblapack_gers = na_change_type(rblapack_gers, NA_DFLOAT);
+ gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_l_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ l_out__ = NA_PTR_TYPE(rblapack_l_out__, doublereal*);
+ MEMCPY(l_out__, l, doublereal, NA_TOTAL(rblapack_l));
+ rblapack_l = rblapack_l_out__;
+ l = l_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
+ MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
+ rblapack_w = rblapack_w_out__;
+ w = w_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
+ MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
+ rblapack_werr = rblapack_werr_out__;
+ werr = werr_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
+ MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
+ rblapack_wgap = rblapack_wgap_out__;
+ wgap = wgap_out__;
+ work = ALLOC_N(doublereal, (12*n));
+ iwork = ALLOC_N(integer, (7*n));
+
+ zlarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
+}
+
+void
+init_lapack_zlarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarrv", rblapack_zlarrv, -1);
+}
diff --git a/ext/zlarscl2.c b/ext/zlarscl2.c
new file mode 100644
index 0000000..3c320a4
--- /dev/null
+++ b/ext/zlarscl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zlarscl2_(integer* m, integer* n, doublereal* d, doublecomplex* x, integer* ldx);
+
+
+static VALUE
+rblapack_zlarscl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.zlarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* ZLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.zlarscl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zlarscl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_zlarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarscl2", rblapack_zlarscl2, -1);
+}
diff --git a/ext/zlartg.c b/ext/zlartg.c
new file mode 100644
index 0000000..715e482
--- /dev/null
+++ b/ext/zlartg.c
@@ -0,0 +1,63 @@
+#include "rb_lapack.h"
+
+extern VOID zlartg_(doublecomplex* f, doublecomplex* g, doublereal* cs, doublecomplex* sn, doublecomplex* r);
+
+
+static VALUE
+rblapack_zlartg(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_f;
+ doublecomplex f;
+ VALUE rblapack_g;
+ doublecomplex g;
+ VALUE rblapack_cs;
+ doublereal cs;
+ VALUE rblapack_sn;
+ doublecomplex sn;
+ VALUE rblapack_r;
+ doublecomplex r;
+
+
+ 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 cs, sn, r = NumRu::Lapack.zlartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* ZLARTG generates a plane rotation so that\n*\n* [ CS SN ] [ F ] [ R ]\n* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a faster version of the BLAS1 routine ZROTG, except for\n* the following differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0, then CS=0 and SN is chosen so that R is real.\n*\n\n* Arguments\n* =========\n*\n* F (input) COMPLEX*16\n* The first component of vector to be rotated.\n*\n* G (input) COMPLEX*16\n* The second component of vector to be rotated.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) COMPLEX*16\n* The sine of the rotation.\n*\n* R (output) COMPLEX*16\n* The nonzero component of the rotated vector.\n*\n\n* Further Details\n* ======= =======\n*\n* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.zlartg( f, g, [: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_f = argv[0];
+ rblapack_g = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ f.r = NUM2DBL(rb_funcall(rblapack_f, rb_intern("real"), 0));
+ f.i = NUM2DBL(rb_funcall(rblapack_f, rb_intern("imag"), 0));
+ g.r = NUM2DBL(rb_funcall(rblapack_g, rb_intern("real"), 0));
+ g.i = NUM2DBL(rb_funcall(rblapack_g, rb_intern("imag"), 0));
+
+ zlartg_(&f, &g, &cs, &sn, &r);
+
+ rblapack_cs = rb_float_new((double)cs);
+ rblapack_sn = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn.r)), rb_float_new((double)(sn.i)));
+ rblapack_r = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(r.r)), rb_float_new((double)(r.i)));
+ return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
+}
+
+void
+init_lapack_zlartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlartg", rblapack_zlartg, -1);
+}
diff --git a/ext/zlartv.c b/ext/zlartv.c
new file mode 100644
index 0000000..e7c79df
--- /dev/null
+++ b/ext/zlartv.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID zlartv_(integer* n, doublecomplex* x, integer* incx, doublecomplex* y, integer* incy, doublereal* c, doublecomplex* s, integer* incc);
+
+
+static VALUE
+rblapack_zlartv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ 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_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 = NumRu::Lapack.zlartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* ZLARTV applies a vector of complex plane rotations with real cosines\n* to elements of the complex vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(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.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 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, IY\n COMPLEX*16 XI, YI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.zlartv( n, x, incx, y, incy, 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_incx = argv[2];
+ rblapack_y = argv[3];
+ rblapack_incy = 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);
+ incy = NUM2INT(rblapack_incy);
+ 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_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*);
+ if (!NA_IsNArray(rblapack_y))
+ rb_raise(rb_eArgError, "y (4th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
+ 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_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*);
+ {
+ int 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__;
+ {
+ int shape[1];
+ shape[0] = 1+(n-1)*incy;
+ 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__;
+
+ zlartv_(&n, x, &incx, y, &incy, c, s, &incc);
+
+ return rb_ary_new3(2, rblapack_x, rblapack_y);
+}
+
+void
+init_lapack_zlartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlartv", rblapack_zlartv, -1);
+}
diff --git a/ext/zlarz.c b/ext/zlarz.c
new file mode 100644
index 0000000..e993fd0
--- /dev/null
+++ b/ext/zlarz.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID zlarz_(char* side, integer* m, integer* n, integer* l, doublecomplex* v, integer* incv, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work);
+
+
+static VALUE
+rblapack_zlarz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ doublecomplex tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *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 c = NumRu::Lapack.zlarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* ZLARZ applies a complex elementary reflector H to a complex\n* M-by-N matrix C, from either the left or the right. H is represented\n* in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n* H is a product of k elementary reflectors as returned by ZTZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX*16 array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* ZTZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarz( side, m, l, v, incv, 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_m = argv[1];
+ rblapack_l = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ incv = NUM2INT(rblapack_incv);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ m = NUM2INT(rblapack_m);
+ tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zlarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_zlarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarz", rblapack_zlarz, -1);
+}
diff --git a/ext/zlarzb.c b/ext/zlarzb.c
new file mode 100644
index 0000000..0aa0b5c
--- /dev/null
+++ b/ext/zlarzb.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID zlarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, doublecomplex* v, integer* ldv, doublecomplex* t, integer* ldt, doublecomplex* c, integer* ldc, doublecomplex* work, integer* ldwork);
+
+
+static VALUE
+rblapack_zlarzb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer ldv;
+ integer nv;
+ integer ldt;
+ integer k;
+ integer ldc;
+ integer n;
+ integer ldwork;
+
+ 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.zlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* ZLARZB applies a complex block reflector H or its transpose H**H\n* to a complex distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX*16 array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX*16 array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_storev = argv[3];
+ rblapack_m = argv[4];
+ rblapack_l = argv[5];
+ rblapack_v = argv[6];
+ rblapack_t = argv[7];
+ rblapack_c = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (7th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ nv = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (9th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ l = NUM2INT(rblapack_l);
+ ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
+ storev = StringValueCStr(rblapack_storev)[0];
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (8th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ k = NA_SHAPE1(rblapack_t);
+ if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (ldwork)*(k));
+
+ zlarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
+
+ free(work);
+ return rblapack_c;
+}
+
+void
+init_lapack_zlarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarzb", rblapack_zlarzb, -1);
+}
diff --git a/ext/zlarzt.c b/ext/zlarzt.c
new file mode 100644
index 0000000..4e6c38a
--- /dev/null
+++ b/ext/zlarzt.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID zlarzt_(char* direct, char* storev, integer* n, integer* k, doublecomplex* v, integer* ldv, doublecomplex* tau, doublecomplex* t, integer* ldt);
+
+
+static VALUE
+rblapack_zlarzt(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_storev;
+ char storev;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_v_out__;
+ doublecomplex *v_out__;
+
+ integer ldv;
+ integer k;
+ integer ldt;
+
+ 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 t, v = NumRu::Lapack.zlarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* ZLARZT forms the triangular factor T of a complex block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX*16 array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX*16 array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.zlarzt( direct, storev, n, v, tau, [: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_direct = argv[0];
+ rblapack_storev = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ direct = StringValueCStr(rblapack_direct)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ storev = StringValueCStr(rblapack_storev)[0];
+ ldt = k;
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = k;
+ rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
+ rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
+ MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+
+ zlarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
+
+ return rb_ary_new3(2, rblapack_t, rblapack_v);
+}
+
+void
+init_lapack_zlarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlarzt", rblapack_zlarzt, -1);
+}
diff --git a/ext/zlascl.c b/ext/zlascl.c
new file mode 100644
index 0000000..01fa958
--- /dev/null
+++ b/ext/zlascl.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zlascl_(char* type, integer* kl, integer* ku, doublereal* cfrom, doublereal* cto, integer* m, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_zlascl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_type;
+ char type;
+ VALUE rblapack_kl;
+ integer kl;
+ VALUE rblapack_ku;
+ integer ku;
+ VALUE rblapack_cfrom;
+ doublereal cfrom;
+ VALUE rblapack_cto;
+ doublereal cto;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.zlascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZLASCL multiplies the M by N complex matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See ZGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) DOUBLE PRECISION\n* CTO (input) DOUBLE PRECISION\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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, a = NumRu::Lapack.zlascl( type, kl, ku, cfrom, cto, m, a, [: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_type = argv[0];
+ rblapack_kl = argv[1];
+ rblapack_ku = argv[2];
+ rblapack_cfrom = argv[3];
+ rblapack_cto = argv[4];
+ rblapack_m = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ type = StringValueCStr(rblapack_type)[0];
+ ku = NUM2INT(rblapack_ku);
+ cto = NUM2DBL(rblapack_cto);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ kl = NUM2INT(rblapack_kl);
+ m = NUM2INT(rblapack_m);
+ cfrom = NUM2DBL(rblapack_cfrom);
+ {
+ int 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__;
+
+ zlascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zlascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlascl", rblapack_zlascl, -1);
+}
diff --git a/ext/zlascl2.c b/ext/zlascl2.c
new file mode 100644
index 0000000..fed9a10
--- /dev/null
+++ b/ext/zlascl2.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zlascl2_(integer* m, integer* n, doublereal* d, doublecomplex* x, integer* ldx);
+
+
+static VALUE
+rblapack_zlascl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+
+ integer m;
+ 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 x = NumRu::Lapack.zlascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* ZLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x = NumRu::Lapack.zlascl2( d, x, [: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_d = argv[0];
+ rblapack_x = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ m = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (2th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ n = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = n;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zlascl2_(&m, &n, d, x, &ldx);
+
+ return rblapack_x;
+}
+
+void
+init_lapack_zlascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlascl2", rblapack_zlascl2, -1);
+}
diff --git a/ext/zlaset.c b/ext/zlaset.c
new file mode 100644
index 0000000..e9c148e
--- /dev/null
+++ b/ext/zlaset.c
@@ -0,0 +1,88 @@
+#include "rb_lapack.h"
+
+extern VOID zlaset_(char* uplo, integer* m, integer* n, doublecomplex* alpha, doublecomplex* beta, doublecomplex* a, integer* lda);
+
+
+static VALUE
+rblapack_zlaset(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_beta;
+ doublecomplex beta;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ 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 a = NumRu::Lapack.zlaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* ZLASET initializes a 2-D array A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set. The lower triangle\n* is unchanged.\n* = 'L': Lower triangular part is set. The upper triangle\n* is unchanged.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of A.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of A.\n*\n* ALPHA (input) COMPLEX*16\n* All the offdiagonal array elements are set to ALPHA.\n*\n* BETA (input) COMPLEX*16\n* All the diagonal array elements are set to BETA.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n* A(i,i) = BETA , 1 <= i <= min(m,n)\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.zlaset( uplo, m, alpha, beta, a, [: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_m = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_beta = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = NUM2INT(rblapack_m);
+ beta.r = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
+ beta.i = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
+ {
+ int 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__;
+
+ zlaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_zlaset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaset", rblapack_zlaset, -1);
+}
diff --git a/ext/zlasr.c b/ext/zlasr.c
new file mode 100644
index 0000000..f5e4e8d
--- /dev/null
+++ b/ext/zlasr.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID zlasr_(char* side, char* pivot, char* direct, integer* m, integer* n, doublereal* c, doublereal* s, doublecomplex* a, integer* lda);
+
+
+static VALUE
+rblapack_zlasr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_pivot;
+ char pivot;
+ VALUE rblapack_direct;
+ char direct;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_c;
+ doublereal *c;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ 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 a = NumRu::Lapack.zlasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* ZLASR applies a sequence of real plane rotations to a complex matrix\n* A, from either the left or the right.\n*\n* When SIDE = 'L', the transformation takes the form\n*\n* A := P*A\n*\n* and when SIDE = 'R', the transformation takes the form\n*\n* A := A*P**T\n*\n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.zlasr( side, pivot, direct, m, c, s, a, [: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_pivot = argv[1];
+ rblapack_direct = argv[2];
+ rblapack_m = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ rblapack_a = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ direct = StringValueCStr(rblapack_direct)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (7th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ pivot = StringValueCStr(rblapack_pivot)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (5th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 1)
+ rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_c) != (m-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
+ if (NA_TYPE(rblapack_c) != NA_DFLOAT)
+ rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
+ c = NA_PTR_TYPE(rblapack_c, doublereal*);
+ {
+ int 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__;
+
+ zlasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_zlasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlasr", rblapack_zlasr, -1);
+}
diff --git a/ext/zlassq.c b/ext/zlassq.c
new file mode 100644
index 0000000..b96a5db
--- /dev/null
+++ b/ext/zlassq.c
@@ -0,0 +1,70 @@
+#include "rb_lapack.h"
+
+extern VOID zlassq_(integer* n, doublecomplex* x, integer* incx, doublereal* scale, doublereal* sumsq);
+
+
+static VALUE
+rblapack_zlassq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_sumsq;
+ doublereal sumsq;
+
+ 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 scale, sumsq = NumRu::Lapack.zlassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* ZLASSQ returns the values scl and ssq such that\n*\n* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n* assumed to be at least unity and the value of ssq will then satisfy\n*\n* 1.0 .le. ssq .le. ( sumsq + 2*n ).\n*\n* scale is assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n* i\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n* SCALE and SUMSQ are overwritten by scl and ssq respectively.\n*\n* The routine makes only one pass through the vector X.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector x as described above.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) DOUBLE PRECISION\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with the value scl .\n*\n* SUMSQ (input/output) DOUBLE PRECISION\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with the value ssq .\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.zlassq( x, incx, scale, sumsq, [: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_x = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_scale = argv[2];
+ rblapack_sumsq = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (1th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ scale = NUM2DBL(rblapack_scale);
+ incx = NUM2INT(rblapack_incx);
+ sumsq = NUM2DBL(rblapack_sumsq);
+
+ zlassq_(&n, x, &incx, &scale, &sumsq);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_sumsq = rb_float_new((double)sumsq);
+ return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
+}
+
+void
+init_lapack_zlassq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlassq", rblapack_zlassq, -1);
+}
diff --git a/ext/zlaswp.c b/ext/zlaswp.c
new file mode 100644
index 0000000..ef1e26a
--- /dev/null
+++ b/ext/zlaswp.c
@@ -0,0 +1,94 @@
+#include "rb_lapack.h"
+
+extern VOID zlaswp_(integer* n, doublecomplex* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);
+
+
+static VALUE
+rblapack_zlaswp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_k1;
+ integer k1;
+ VALUE rblapack_k2;
+ integer k2;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_incx;
+ integer incx;
+ 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 a = NumRu::Lapack.zlaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* ZLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n COMPLEX*16 TEMP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.zlaswp( a, k1, k2, ipiv, incx, [: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_a = argv[0];
+ rblapack_k1 = argv[1];
+ rblapack_k2 = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_incx = argv[4];
+ if (argc == 5) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ k2 = NUM2INT(rblapack_k2);
+ incx = NUM2INT(rblapack_incx);
+ k1 = NUM2INT(rblapack_k1);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
+ rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ zlaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_zlaswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlaswp", rblapack_zlaswp, -1);
+}
diff --git a/ext/zlasyf.c b/ext/zlasyf.c
new file mode 100644
index 0000000..4f2196e
--- /dev/null
+++ b/ext/zlasyf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zlasyf_(char* uplo, integer* n, integer* nb, integer* kb, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* w, integer* ldw, integer* info);
+
+
+static VALUE
+rblapack_zlasyf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_kb;
+ integer kb;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *w;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 kb, ipiv, info, a = NumRu::Lapack.zlasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* ZLASYF computes a partial factorization of a complex symmetric matrix\n* A using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the transpose of U.\n*\n* ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX*16 array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.zlasyf( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+ w = ALLOC_N(doublecomplex, (ldw)*(MAX(1,nb)));
+
+ zlasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
+
+ free(w);
+ rblapack_kb = INT2NUM(kb);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zlasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlasyf", rblapack_zlasyf, -1);
+}
diff --git a/ext/zlat2c.c b/ext/zlat2c.c
new file mode 100644
index 0000000..a75f1bf
--- /dev/null
+++ b/ext/zlat2c.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID zlat2c_(char* uplo, integer* n, doublecomplex* a, integer* lda, complex* sa, integer* ldsa, integer* info);
+
+
+static VALUE
+rblapack_zlat2c(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_sa;
+ complex *sa;
+ VALUE rblapack_info;
+ integer info;
+
+ integer lda;
+ integer n;
+ integer ldsa;
+
+ 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 sa, info = NumRu::Lapack.zlat2c( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX\n* triangular matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* ZLAT2C checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\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* N (input) INTEGER\n* The number of rows and columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N triangular coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SA (output) COMPLEX array, dimension (LDSA,N)\n* Only the UPLO part of SA is referenced. On exit, if INFO=0,\n* the N-by-N coefficient matrix SA; if INFO>0, the content of\n* the UPLO part of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of the UPLO part of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, DIMAG\n* ..\n* .. External Functions ..\n REAL SLAMCH\n LOGICAL LSAME\n EXTERNAL SLAMCH, LSAME\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.zlat2c( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldsa = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldsa;
+ shape[1] = n;
+ rblapack_sa = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
+ }
+ sa = NA_PTR_TYPE(rblapack_sa, complex*);
+
+ zlat2c_(&uplo, &n, a, &lda, sa, &ldsa, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_sa, rblapack_info);
+}
+
+void
+init_lapack_zlat2c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlat2c", rblapack_zlat2c, -1);
+}
diff --git a/ext/zlatbs.c b/ext/zlatbs.c
new file mode 100644
index 0000000..be99c6d
--- /dev/null
+++ b/ext/zlatbs.c
@@ -0,0 +1,130 @@
+#include "rb_lapack.h"
+
+extern VOID zlatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublecomplex* x, doublereal* scale, doublereal* cnorm, integer* info);
+
+
+static VALUE
+rblapack_zlatbs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_cnorm;
+ doublereal *cnorm;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_cnorm_out__;
+ doublereal *cnorm_out__;
+
+ integer ldab;
+ 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 scale, info, x, cnorm = NumRu::Lapack.zlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* ZLATBS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine ZTBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, ZTBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call ZTBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.zlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [: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_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_kd = argv[4];
+ rblapack_ab = argv[5];
+ rblapack_x = argv[6];
+ rblapack_cnorm = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
+ MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ zlatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_zlatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlatbs", rblapack_zlatbs, -1);
+}
diff --git a/ext/zlatdf.c b/ext/zlatdf.c
new file mode 100644
index 0000000..4cbfc23
--- /dev/null
+++ b/ext/zlatdf.c
@@ -0,0 +1,119 @@
+#include "rb_lapack.h"
+
+extern VOID zlatdf_(integer* ijob, integer* n, doublecomplex* z, integer* ldz, doublecomplex* rhs, doublereal* rdsum, doublereal* rdscal, integer* ipiv, integer* jpiv);
+
+
+static VALUE
+rblapack_zlatdf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_rhs;
+ doublecomplex *rhs;
+ VALUE rblapack_rdsum;
+ doublereal rdsum;
+ VALUE rblapack_rdscal;
+ doublereal rdscal;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_jpiv;
+ integer *jpiv;
+ VALUE rblapack_rhs_out__;
+ doublecomplex *rhs_out__;
+
+ integer ldz;
+ 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 rhs, rdsum, rdscal = NumRu::Lapack.zlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* ZLATDF computes the contribution to the reciprocal Dif-estimate\n* by solving for x in Z * x = b, where b is chosen such that the norm\n* of x is as large as possible. It is assumed that LU decomposition\n* of Z has been computed by ZGETC2. On entry RHS = f holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by ZGETC2 has the form\n* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n* triangular with unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using ZGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value of\n* 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where\n* all entries of the r.h.s. b is choosen as either +1 or\n* -1. Default.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by ZGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) DOUBLE PRECISION array, dimension (N).\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries according to the value of IJOB (see above).\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by ZTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n* ZTGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report UMINF-95.05, Department of\n* Computing Science, Umea University, S-901 87 Umea, Sweden,\n* 1995.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.zlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [: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_ijob = argv[0];
+ rblapack_z = argv[1];
+ rblapack_rhs = argv[2];
+ rblapack_rdsum = argv[3];
+ rblapack_rdscal = argv[4];
+ rblapack_ipiv = argv[5];
+ rblapack_jpiv = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ if (!NA_IsNArray(rblapack_rhs))
+ rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
+ if (NA_RANK(rblapack_rhs) != 1)
+ rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_rhs);
+ if (NA_TYPE(rblapack_rhs) != NA_DCOMPLEX)
+ rblapack_rhs = na_change_type(rblapack_rhs, NA_DCOMPLEX);
+ rhs = NA_PTR_TYPE(rblapack_rhs, doublecomplex*);
+ rdscal = NUM2DBL(rblapack_rdscal);
+ if (!NA_IsNArray(rblapack_jpiv))
+ rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
+ if (NA_RANK(rblapack_jpiv) != 1)
+ rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_jpiv) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
+ if (NA_TYPE(rblapack_jpiv) != NA_LINT)
+ rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
+ jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (2th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
+ 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_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 rhs");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ rdsum = NUM2DBL(rblapack_rdsum);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_rhs_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublecomplex*);
+ MEMCPY(rhs_out__, rhs, doublecomplex, NA_TOTAL(rblapack_rhs));
+ rblapack_rhs = rblapack_rhs_out__;
+ rhs = rhs_out__;
+
+ zlatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
+
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_zlatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlatdf", rblapack_zlatdf, -1);
+}
diff --git a/ext/zlatps.c b/ext/zlatps.c
new file mode 100644
index 0000000..43e496c
--- /dev/null
+++ b/ext/zlatps.c
@@ -0,0 +1,124 @@
+#include "rb_lapack.h"
+
+extern VOID zlatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublecomplex* ap, doublecomplex* x, doublereal* scale, doublereal* cnorm, integer* info);
+
+
+static VALUE
+rblapack_zlatps(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_cnorm;
+ doublereal *cnorm;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_cnorm_out__;
+ doublereal *cnorm_out__;
+
+ 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 scale, info, x, cnorm = NumRu::Lapack.zlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* ZLATPS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A**T denotes the\n* transpose of A, A**H denotes the conjugate transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 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*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, ZTPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.zlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (6th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
+ if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ 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) != (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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
+ MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ zlatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_zlatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlatps", rblapack_zlatps, -1);
+}
diff --git a/ext/zlatrd.c b/ext/zlatrd.c
new file mode 100644
index 0000000..9c4c9c4
--- /dev/null
+++ b/ext/zlatrd.c
@@ -0,0 +1,105 @@
+#include "rb_lapack.h"
+
+extern VOID zlatrd_(char* uplo, integer* n, integer* nb, doublecomplex* a, integer* lda, doublereal* e, doublecomplex* tau, doublecomplex* w, integer* ldw);
+
+
+static VALUE
+rblapack_zlatrd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer ldw;
+
+ 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 e, tau, w, a = NumRu::Lapack.zlatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n* Hermitian tridiagonal form by a unitary similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by ZHETRD.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) COMPLEX*16 array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a Hermitian rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.zlatrd( uplo, nb, a, [: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_nb = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ nb = NUM2INT(rblapack_nb);
+ ldw = MAX(1,n);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldw;
+ shape[1] = MAX(n,nb);
+ rblapack_w = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int 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__;
+
+ zlatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
+
+ return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
+}
+
+void
+init_lapack_zlatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlatrd", rblapack_zlatrd, -1);
+}
diff --git a/ext/zlatrs.c b/ext/zlatrs.c
new file mode 100644
index 0000000..fa9cc42
--- /dev/null
+++ b/ext/zlatrs.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID zlatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublecomplex* a, integer* lda, doublecomplex* x, doublereal* scale, doublereal* cnorm, integer* info);
+
+
+static VALUE
+rblapack_zlatrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_normin;
+ char normin;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_cnorm;
+ doublereal *cnorm;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_cnorm_out__;
+ doublereal *cnorm_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 scale, info, x, cnorm = NumRu::Lapack.zlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* ZLATRS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A**T denotes the transpose of A, A**H denotes the\n* conjugate transpose of A, x and b are n-element vectors, and s is a\n* scaling factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, ZTRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.zlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_normin = argv[3];
+ rblapack_a = argv[4];
+ rblapack_x = argv[5];
+ rblapack_cnorm = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_cnorm))
+ rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
+ if (NA_RANK(rblapack_cnorm) != 1)
+ rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cnorm) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
+ rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
+ cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
+ 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) != 1)
+ rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ normin = StringValueCStr(rblapack_normin)[0];
+ {
+ int shape[1];
+ shape[0] = n;
+ 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__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
+ MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
+ rblapack_cnorm = rblapack_cnorm_out__;
+ cnorm = cnorm_out__;
+
+ zlatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
+}
+
+void
+init_lapack_zlatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlatrs", rblapack_zlatrs, -1);
+}
diff --git a/ext/zlatrz.c b/ext/zlatrz.c
new file mode 100644
index 0000000..3388b38
--- /dev/null
+++ b/ext/zlatrz.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID zlatrz_(integer* m, integer* n, integer* l, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work);
+
+
+static VALUE
+rblapack_zlatrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.zlatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means\n* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.zlatrz( l, 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_l = argv[0];
+ rblapack_a = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ l = NUM2INT(rblapack_l);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (m));
+
+ zlatrz_(&m, &n, &l, a, &lda, tau, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_tau, rblapack_a);
+}
+
+void
+init_lapack_zlatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlatrz", rblapack_zlatrz, -1);
+}
diff --git a/ext/zlatzm.c b/ext/zlatzm.c
new file mode 100644
index 0000000..4f1bd48
--- /dev/null
+++ b/ext/zlatzm.c
@@ -0,0 +1,132 @@
+#include "rb_lapack.h"
+
+extern VOID zlatzm_(char* side, integer* m, integer* n, doublecomplex* v, integer* incv, doublecomplex* tau, doublecomplex* c1, doublecomplex* c2, integer* ldc, doublecomplex* work);
+
+
+static VALUE
+rblapack_zlatzm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_incv;
+ integer incv;
+ VALUE rblapack_tau;
+ doublecomplex tau;
+ VALUE rblapack_c1;
+ doublecomplex *c1;
+ VALUE rblapack_c2;
+ doublecomplex *c2;
+ VALUE rblapack_c1_out__;
+ doublecomplex *c1_out__;
+ VALUE rblapack_c2_out__;
+ doublecomplex *c2_out__;
+ doublecomplex *work;
+
+ 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 c1, c2 = NumRu::Lapack.zlatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZUNMRZ.\n*\n* ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX*16 array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of P.\n*\n* C1 (input/output) COMPLEX*16 array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) COMPLEX*16 array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2.\n* LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.zlatzm( side, m, n, v, incv, tau, c1, c2, [: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_side = argv[0];
+ rblapack_m = argv[1];
+ rblapack_n = argv[2];
+ rblapack_v = argv[3];
+ rblapack_incv = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c1 = argv[6];
+ rblapack_c2 = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ n = NUM2INT(rblapack_n);
+ incv = NUM2INT(rblapack_incv);
+ if (!NA_IsNArray(rblapack_c2))
+ rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c2) != 2)
+ rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c2);
+ if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
+ if (NA_TYPE(rblapack_c2) != NA_DCOMPLEX)
+ rblapack_c2 = na_change_type(rblapack_c2, NA_DCOMPLEX);
+ c2 = NA_PTR_TYPE(rblapack_c2, doublecomplex*);
+ m = NUM2INT(rblapack_m);
+ tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
+ tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (4th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 1)
+ rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
+ rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ if (!NA_IsNArray(rblapack_c1))
+ rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
+ if (NA_RANK(rblapack_c1) != 2)
+ rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
+ if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
+ if (NA_TYPE(rblapack_c1) != NA_DCOMPLEX)
+ rblapack_c1 = na_change_type(rblapack_c1, NA_DCOMPLEX);
+ c1 = NA_PTR_TYPE(rblapack_c1, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
+ rblapack_c1_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, doublecomplex*);
+ MEMCPY(c1_out__, c1, doublecomplex, NA_TOTAL(rblapack_c1));
+ rblapack_c1 = rblapack_c1_out__;
+ c1 = c1_out__;
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
+ rblapack_c2_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, doublecomplex*);
+ MEMCPY(c2_out__, c2, doublecomplex, NA_TOTAL(rblapack_c2));
+ rblapack_c2 = rblapack_c2_out__;
+ c2 = c2_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zlatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
+
+ free(work);
+ return rb_ary_new3(2, rblapack_c1, rblapack_c2);
+}
+
+void
+init_lapack_zlatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlatzm", rblapack_zlatzm, -1);
+}
diff --git a/ext/zlauu2.c b/ext/zlauu2.c
new file mode 100644
index 0000000..7718445
--- /dev/null
+++ b/ext/zlauu2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID zlauu2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_zlauu2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.zlauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAUU2 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) COMPLEX*16 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.zlauu2( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+
+ zlauu2_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zlauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlauu2", rblapack_zlauu2, -1);
+}
diff --git a/ext/zlauum.c b/ext/zlauum.c
new file mode 100644
index 0000000..f2b2f8e
--- /dev/null
+++ b/ext/zlauum.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID zlauum_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_zlauum(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.zlauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAUUM 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) COMPLEX*16 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.zlauum( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+
+ zlauum_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zlauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zlauum", rblapack_zlauum, -1);
+}
diff --git a/ext/zpbcon.c b/ext/zpbcon.c
new file mode 100644
index 0000000..491bec7
--- /dev/null
+++ b/ext/zpbcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zpbcon_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zpbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ 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.zpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite band matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* ZPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the Hermitian band matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zpbcon( uplo, kd, ab, anorm, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zpbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbcon", rblapack_zpbcon, -1);
+}
diff --git a/ext/zpbequ.c b/ext/zpbequ.c
new file mode 100644
index 0000000..4aad785
--- /dev/null
+++ b/ext/zpbequ.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID zpbequ_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zpbequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldab;
+ 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 s, scond, amax, info = NumRu::Lapack.zpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPBEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zpbequ( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ zpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zpbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbequ", rblapack_zpbequ, -1);
+}
diff --git a/ext/zpbrfs.c b/ext/zpbrfs.c
new file mode 100644
index 0000000..d9dcb77
--- /dev/null
+++ b/ext/zpbrfs.c
@@ -0,0 +1,145 @@
+#include "rb_lapack.h"
+
+extern VOID zpbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zpbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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.zpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A as computed by\n* ZPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zpbrfs( uplo, kd, ab, afb, 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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_afb = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ if (NA_SHAPE1(rblapack_afb) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zpbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbrfs", rblapack_zpbrfs, -1);
+}
diff --git a/ext/zpbstf.c b/ext/zpbstf.c
new file mode 100644
index 0000000..f58207a
--- /dev/null
+++ b/ext/zpbstf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID zpbstf_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_zpbstf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.zpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBSTF computes a split Cholesky factorization of a complex\n* Hermitian positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with ZHBGST.\n*\n* The factorization has the form A = S**H*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**H*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine; s12' denotes\n* conjg(s12); the diagonal elements of S are real.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.zpbstf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zpbstf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zpbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbstf", rblapack_zpbstf, -1);
+}
diff --git a/ext/zpbsv.c b/ext/zpbsv.c
new file mode 100644
index 0000000..d83783d
--- /dev/null
+++ b/ext/zpbsv.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zpbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zpbsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, ab, b = NumRu::Lapack.zpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPBTRF, ZPBTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.zpbsv( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
+}
+
+void
+init_lapack_zpbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbsv", rblapack_zpbsv, -1);
+}
diff --git a/ext/zpbsvx.c b/ext/zpbsvx.c
new file mode 100644
index 0000000..7468799
--- /dev/null
+++ b/ext/zpbsvx.c
@@ -0,0 +1,201 @@
+#include "rb_lapack.h"
+
+extern VOID zpbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zpbsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_afb;
+ doublecomplex *afb;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+ VALUE rblapack_afb_out__;
+ doublecomplex *afb_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ integer n;
+ integer ldafb;
+ 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 x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.zpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.zpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_kd = argv[2];
+ rblapack_ab = argv[3];
+ rblapack_afb = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ kd = NUM2INT(rblapack_kd);
+ if (!NA_IsNArray(rblapack_afb))
+ rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
+ if (NA_RANK(rblapack_afb) != 2)
+ rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
+ ldafb = NA_SHAPE0(rblapack_afb);
+ n = NA_SHAPE1(rblapack_afb);
+ if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
+ rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
+ afb = NA_PTR_TYPE(rblapack_afb, 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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ if (NA_SHAPE1(rblapack_ab) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+ {
+ int shape[2];
+ shape[0] = ldafb;
+ shape[1] = n;
+ rblapack_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublecomplex*);
+ MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rblapack_afb));
+ rblapack_afb = rblapack_afb_out__;
+ afb = afb_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_zpbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbsvx", rblapack_zpbsvx, -1);
+}
diff --git a/ext/zpbtf2.c b/ext/zpbtf2.c
new file mode 100644
index 0000000..6cdd47a
--- /dev/null
+++ b/ext/zpbtf2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID zpbtf2_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_zpbtf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.zpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the conjugate transpose\n* of U, and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.zpbtf2( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zpbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbtf2", rblapack_zpbtf2, -1);
+}
diff --git a/ext/zpbtrf.c b/ext/zpbtrf.c
new file mode 100644
index 0000000..371a2df
--- /dev/null
+++ b/ext/zpbtrf.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID zpbtrf_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, integer* info);
+
+
+static VALUE
+rblapack_zpbtrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ab_out__;
+ doublecomplex *ab_out__;
+
+ integer ldab;
+ 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, ab = NumRu::Lapack.zpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.zpbtrf( uplo, kd, ab, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldab;
+ shape[1] = n;
+ rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
+ MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
+ rblapack_ab = rblapack_ab_out__;
+ ab = ab_out__;
+
+ zpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ab);
+}
+
+void
+init_lapack_zpbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbtrf", rblapack_zpbtrf, -1);
+}
diff --git a/ext/zpbtrs.c b/ext/zpbtrs.c
new file mode 100644
index 0000000..c46c84e
--- /dev/null
+++ b/ext/zpbtrs.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID zpbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zpbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite band matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by ZPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZTBSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpbtrs( uplo, kd, ab, b, [: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_kd = argv[1];
+ rblapack_ab = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zpbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpbtrs", rblapack_zpbtrs, -1);
+}
diff --git a/ext/zpftrf.c b/ext/zpftrf.c
new file mode 100644
index 0000000..e3f015d
--- /dev/null
+++ b/ext/zpftrf.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zpftrf_(char* transr, char* uplo, integer* n, complex* a, integer* info);
+
+
+static VALUE
+rblapack_zpftrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ complex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ complex *a_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, a = NumRu::Lapack.zpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* ZPFTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**H*U or RFP A = L*L**H.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n* Further Notes on RFP Format:\n* ============================\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\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.zpftrf( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, complex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
+ }
+ a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
+ MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
+ rblapack_a = rblapack_a_out__;
+ a = a_out__;
+
+ zpftrf_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zpftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpftrf", rblapack_zpftrf, -1);
+}
diff --git a/ext/zpftri.c b/ext/zpftri.c
new file mode 100644
index 0000000..abf255c
--- /dev/null
+++ b/ext/zpftri.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zpftri_(char* transr, char* uplo, integer* n, doublecomplex* a, integer* info);
+
+
+static VALUE
+rblapack_zpftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_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, a = NumRu::Lapack.zpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* ZPFTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by ZPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the Hermitian inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zpftri( transr, uplo, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 1, 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__;
+
+ zpftri_(&transr, &uplo, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zpftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpftri", rblapack_zpftri, -1);
+}
diff --git a/ext/zpftrs.c b/ext/zpftrs.c
new file mode 100644
index 0000000..ef3ff55
--- /dev/null
+++ b/ext/zpftrs.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zpftrs_(char* transr, char* uplo, integer* n, integer* nrhs, doublecomplex* a, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zpftrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPFTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by ZPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**H*U or RFP A = L*L**H, as computed by ZPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpftrs( transr, uplo, n, a, b, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (4th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zpftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpftrs", rblapack_zpftrs, -1);
+}
diff --git a/ext/zpocon.c b/ext/zpocon.c
new file mode 100644
index 0000000..6dc0048
--- /dev/null
+++ b/ext/zpocon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID zpocon_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zpocon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 rcond, info = NumRu::Lapack.zpocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPOCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite matrix using the\n* Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zpocon( uplo, a, anorm, [: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_a = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = NUM2DBL(rblapack_anorm);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zpocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpocon", rblapack_zpocon, -1);
+}
diff --git a/ext/zpoequ.c b/ext/zpoequ.c
new file mode 100644
index 0000000..7114f9d
--- /dev/null
+++ b/ext/zpoequ.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID zpoequ_(integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zpoequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.zpoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPOEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N Hermitian positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zpoequ( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ zpoequ_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zpoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpoequ", rblapack_zpoequ, -1);
+}
diff --git a/ext/zpoequb.c b/ext/zpoequb.c
new file mode 100644
index 0000000..c137d94
--- /dev/null
+++ b/ext/zpoequb.c
@@ -0,0 +1,75 @@
+#include "rb_lapack.h"
+
+extern VOID zpoequb_(integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zpoequb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.zpoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPOEQUB computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zpoequb( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ zpoequb_(&n, a, &lda, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zpoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpoequb", rblapack_zpoequb, -1);
+}
diff --git a/ext/zporfs.c b/ext/zporfs.c
new file mode 100644
index 0000000..71467c7
--- /dev/null
+++ b/ext/zporfs.c
@@ -0,0 +1,141 @@
+#include "rb_lapack.h"
+
+extern VOID zporfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zporfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.zporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPOTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zporfs( uplo, a, af, b, x, [: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_af = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ 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_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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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) != nrhs)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zporfs", rblapack_zporfs, -1);
+}
diff --git a/ext/zporfsx.c b/ext/zporfsx.c
new file mode 100644
index 0000000..0db292e
--- /dev/null
+++ b/ext/zporfsx.c
@@ -0,0 +1,206 @@
+#include "rb_lapack.h"
+
+extern VOID zporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zporfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zporfsx( uplo, equed, a, af, s, b, x, params, [: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_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_s = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (5th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ n_err_bnds = 3;
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_zporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zporfsx", rblapack_zporfsx, -1);
+}
diff --git a/ext/zposv.c b/ext/zposv.c
new file mode 100644
index 0000000..12ee1a0
--- /dev/null
+++ b/ext/zposv.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zposv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zposv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPOSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPOTRF, ZPOTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.zposv( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zposv", rblapack_zposv, -1);
+}
diff --git a/ext/zposvx.c b/ext/zposvx.c
new file mode 100644
index 0000000..f869bc7
--- /dev/null
+++ b/ext/zposvx.c
@@ -0,0 +1,197 @@
+#include "rb_lapack.h"
+
+extern VOID zposvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zposvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.zposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS righthand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.zposvx( fact, uplo, a, af, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_zposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zposvx", rblapack_zposvx, -1);
+}
diff --git a/ext/zposvxx.c b/ext/zposvxx.c
new file mode 100644
index 0000000..c33fe44
--- /dev/null
+++ b/ext/zposvxx.c
@@ -0,0 +1,235 @@
+#include "rb_lapack.h"
+
+extern VOID zposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zposvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.zposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a complex*16 system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.zposvxx( fact, uplo, a, af, equed, s, b, params, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_params = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (8th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_zposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zposvxx", rblapack_zposvxx, -1);
+}
diff --git a/ext/zpotf2.c b/ext/zpotf2.c
new file mode 100644
index 0000000..238468f
--- /dev/null
+++ b/ext/zpotf2.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID zpotf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_zpotf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.zpotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\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.zpotf2( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+
+ zpotf2_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zpotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpotf2", rblapack_zpotf2, -1);
+}
diff --git a/ext/zpotrf.c b/ext/zpotrf.c
new file mode 100644
index 0000000..30ccd2a
--- /dev/null
+++ b/ext/zpotrf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID zpotrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_zpotrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.zpotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\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.zpotrf( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+
+ zpotrf_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zpotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpotrf", rblapack_zpotrf, -1);
+}
diff --git a/ext/zpotri.c b/ext/zpotri.c
new file mode 100644
index 0000000..3d13955
--- /dev/null
+++ b/ext/zpotri.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID zpotri_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_zpotri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.zpotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, as computed by\n* ZPOTRF.\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLAUUM, ZTRTRI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zpotri( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+
+ zpotri_(&uplo, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zpotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpotri", rblapack_zpotri, -1);
+}
diff --git a/ext/zpotrs.c b/ext/zpotrs.c
new file mode 100644
index 0000000..9ce57a2
--- /dev/null
+++ b/ext/zpotrs.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID zpotrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zpotrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zpotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.zpotrs( uplo, a, b, [: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_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zpotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpotrs", rblapack_zpotrs, -1);
+}
diff --git a/ext/zppcon.c b/ext/zppcon.c
new file mode 100644
index 0000000..2866cb2
--- /dev/null
+++ b/ext/zppcon.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID zppcon_(char* uplo, integer* n, doublecomplex* ap, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zppcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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.zppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite packed matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* ZPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zppcon( uplo, ap, anorm, [: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_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ anorm = NUM2DBL(rblapack_anorm);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zppcon_(&uplo, &n, ap, &anorm, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zppcon", rblapack_zppcon, -1);
+}
diff --git a/ext/zppequ.c b/ext/zppequ.c
new file mode 100644
index 0000000..2e59c9f
--- /dev/null
+++ b/ext/zppequ.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID zppequ_(char* uplo, integer* n, doublecomplex* ap, doublereal* s, doublereal* scond, doublereal* amax, integer* info);
+
+
+static VALUE
+rblapack_zppequ(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_scond;
+ doublereal scond;
+ VALUE rblapack_amax;
+ doublereal amax;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 s, scond, amax, info = NumRu::Lapack.zppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPPEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zppequ( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+
+ zppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
+
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zppequ", rblapack_zppequ, -1);
+}
diff --git a/ext/zpprfs.c b/ext/zpprfs.c
new file mode 100644
index 0000000..0dec283
--- /dev/null
+++ b/ext/zpprfs.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID zpprfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zpprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_afp;
+ doublecomplex *afp;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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, x = NumRu::Lapack.zpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zpprfs( uplo, ap, afp, b, x, [: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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_b = argv[3];
+ rblapack_x = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = 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*);
+ n = ldb;
+ 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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (5th 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zpprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpprfs", rblapack_zpprfs, -1);
+}
diff --git a/ext/zppsv.c b/ext/zppsv.c
new file mode 100644
index 0000000..e0ef783
--- /dev/null
+++ b/ext/zppsv.c
@@ -0,0 +1,104 @@
+#include "rb_lapack.h"
+
+extern VOID zppsv_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zppsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPPTRF, ZPPTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.zppsv( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = 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*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_zppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zppsv", rblapack_zppsv, -1);
+}
diff --git a/ext/zppsvx.c b/ext/zppsvx.c
new file mode 100644
index 0000000..abe2247
--- /dev/null
+++ b/ext/zppsvx.c
@@ -0,0 +1,191 @@
+#include "rb_lapack.h"
+
+extern VOID zppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zppsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_afp;
+ doublecomplex *afp;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ VALUE rblapack_afp_out__;
+ doublecomplex *afp_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.zppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U'* U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, L is a lower triangular\n* matrix, and ' indicates conjugate transpose.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.zppsvx( fact, uplo, ap, afp, equed, s, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_equed = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th 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*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublecomplex*);
+ MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
+}
+
+void
+init_lapack_zppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zppsvx", rblapack_zppsvx, -1);
+}
diff --git a/ext/zpptrf.c b/ext/zpptrf.c
new file mode 100644
index 0000000..454284e
--- /dev/null
+++ b/ext/zpptrf.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID zpptrf_(char* uplo, integer* n, doublecomplex* ap, integer* info);
+
+
+static VALUE
+rblapack_zpptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *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.zpptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZPPTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zpptrf( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zpptrf_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zpptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpptrf", rblapack_zpptrf, -1);
+}
diff --git a/ext/zpptri.c b/ext/zpptri.c
new file mode 100644
index 0000000..ab26029
--- /dev/null
+++ b/ext/zpptri.c
@@ -0,0 +1,78 @@
+#include "rb_lapack.h"
+
+extern VOID zpptri_(char* uplo, integer* n, doublecomplex* ap, integer* info);
+
+
+static VALUE
+rblapack_zpptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *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.zpptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZPPTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by ZPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zpptri( uplo, n, ap, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zpptri_(&uplo, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zpptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpptri", rblapack_zpptri, -1);
+}
diff --git a/ext/zpptrs.c b/ext/zpptrs.c
new file mode 100644
index 0000000..61da944
--- /dev/null
+++ b/ext/zpptrs.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID zpptrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zpptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPPTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**H*U or A = L*L**H computed by ZPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZTPSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpptrs( uplo, n, ap, b, [: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_n = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = 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*);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zpptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpptrs", rblapack_zpptrs, -1);
+}
diff --git a/ext/zpstf2.c b/ext/zpstf2.c
new file mode 100644
index 0000000..385d668
--- /dev/null
+++ b/ext/zpstf2.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID zpstf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_zpstf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.zpstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPSTF2 computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.zpstf2( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = NUM2DBL(rblapack_tol);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ zpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zpstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpstf2", rblapack_zpstf2, -1);
+}
diff --git a/ext/zpstrf.c b/ext/zpstrf.c
new file mode 100644
index 0000000..32d42b5
--- /dev/null
+++ b/ext/zpstrf.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID zpstrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_zpstrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tol;
+ doublereal tol;
+ VALUE rblapack_piv;
+ integer *piv;
+ VALUE rblapack_rank;
+ integer rank;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublereal *work;
+
+ 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 piv, rank, info, a = NumRu::Lapack.zpstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPSTRF computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.zpstrf( uplo, a, tol, [: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_a = argv[1];
+ rblapack_tol = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ tol = NUM2DBL(rblapack_tol);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ piv = NA_PTR_TYPE(rblapack_piv, integer*);
+ {
+ int 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__;
+ work = ALLOC_N(doublereal, (2*n));
+
+ zpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
+
+ free(work);
+ rblapack_rank = INT2NUM(rank);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zpstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpstrf", rblapack_zpstrf, -1);
+}
diff --git a/ext/zptcon.c b/ext/zptcon.c
new file mode 100644
index 0000000..e019737
--- /dev/null
+++ b/ext/zptcon.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID zptcon_(integer* n, doublereal* d, doublecomplex* e, doublereal* anorm, doublereal* rcond, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zptcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *rwork;
+
+ 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.zptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite tridiagonal matrix\n* using the factorization A = L*D*L**H or A = U**H*D*U computed by\n* ZPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by ZPTTRF.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by ZPTTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal of the condition number of the matrix A,\n* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n* 1-norm of inv(A) computed in this routine.\n*\n* RWORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zptcon( d, e, anorm, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_anorm = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ anorm = NUM2DBL(rblapack_anorm);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ rwork = ALLOC_N(doublereal, (n));
+
+ zptcon_(&n, d, e, &anorm, &rcond, rwork, &info);
+
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zptcon", rblapack_zptcon, -1);
+}
diff --git a/ext/zpteqr.c b/ext/zpteqr.c
new file mode 100644
index 0000000..1104b2b
--- /dev/null
+++ b/ext/zpteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID zpteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublecomplex* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_zpteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.zpteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using DPTTRF and then calling ZBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band positive definite Hermitian matrix\n* can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to\n* tridiagonal form, however, may preclude the possibility of obtaining\n* high relative accuracy in the small eigenvalues of the original\n* matrix, if these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original Hermitian\n* matrix also. Array Z contains the unitary matrix\n* used to reduce the original matrix to tridiagonal\n* form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original Hermitian matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* ====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.zpteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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));
+
+ zpteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_zpteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpteqr", rblapack_zpteqr, -1);
+}
diff --git a/ext/zptrfs.c b/ext/zptrfs.c
new file mode 100644
index 0000000..78abc02
--- /dev/null
+++ b/ext/zptrfs.c
@@ -0,0 +1,161 @@
+#include "rb_lapack.h"
+
+extern VOID zptrfs_(char* uplo, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublereal* df, doublecomplex* ef, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zptrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_df;
+ doublereal *df;
+ VALUE rblapack_ef;
+ doublecomplex *ef;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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.zptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the superdiagonal or the subdiagonal of the\n* tridiagonal matrix A is stored and the form of the\n* factorization:\n* = 'U': E is the superdiagonal of A, and A = U**H*D*U;\n* = 'L': E is the subdiagonal of A, and A = L*D*L**H.\n* (The two forms are equivalent if A is real.)\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n real diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix A\n* (see UPLO).\n*\n* DF (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from\n* the factorization computed by ZPTTRF.\n*\n* EF (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal\n* factor U or L from the factorization computed by ZPTTRF\n* (see UPLO).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPTTRS.\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) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_df = argv[3];
+ rblapack_ef = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (4th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_df);
+ if (NA_TYPE(rblapack_df) != NA_DFLOAT)
+ rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
+ df = NA_PTR_TYPE(rblapack_df, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 df");
+ 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_ef))
+ rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_DCOMPLEX)
+ rblapack_ef = na_change_type(rblapack_ef, NA_DCOMPLEX);
+ ef = NA_PTR_TYPE(rblapack_ef, doublecomplex*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zptrfs_(&uplo, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zptrfs", rblapack_zptrfs, -1);
+}
diff --git a/ext/zptsv.c b/ext/zptsv.c
new file mode 100644
index 0000000..586d35a
--- /dev/null
+++ b/ext/zptsv.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID zptsv_(integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zptsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_nrhs;
+ integer nrhs;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublecomplex *e_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.zptsv( nrhs, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPTSV computes the solution to a complex system of linear equations\n* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**H, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**H.\n*\n* E (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**H factorization of\n* A. E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**H*D*U factorization of A.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPTTRF, ZPTTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.zptsv( nrhs, d, e, b, [: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_nrhs = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ nrhs = NUM2INT(rblapack_nrhs);
+ 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);
+ 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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 of b");
+ 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublecomplex*);
+ MEMCPY(e_out__, e, doublecomplex, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zptsv_(&n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
+}
+
+void
+init_lapack_zptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zptsv", rblapack_zptsv, -1);
+}
diff --git a/ext/zptsvx.c b/ext/zptsvx.c
new file mode 100644
index 0000000..e02b7ba
--- /dev/null
+++ b/ext/zptsvx.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID zptsvx_(char* fact, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublereal* df, doublecomplex* ef, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zptsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_df;
+ doublereal *df;
+ VALUE rblapack_ef;
+ doublecomplex *ef;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_df_out__;
+ doublereal *df_out__;
+ VALUE rblapack_ef_out__;
+ doublecomplex *ef_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.zptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTSVX uses the factorization A = L*D*L**H to compute the solution\n* to a complex system of linear equations A*X = B, where A is an\n* N-by-N Hermitian positive definite tridiagonal matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**H*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix\n* A is supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) DOUBLE PRECISION array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n*\n* EF (input or output) COMPLEX*16 array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The componentwise relative backward error of each solution\n* vector X(j) (i.e., the smallest relative change in any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.zptsvx( fact, d, e, df, ef, b, [: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_fact = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_df = argv[3];
+ rblapack_ef = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_df))
+ rb_raise(rb_eArgError, "df (4th argument) must be NArray");
+ if (NA_RANK(rblapack_df) != 1)
+ rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_df);
+ if (NA_TYPE(rblapack_df) != NA_DFLOAT)
+ rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
+ df = NA_PTR_TYPE(rblapack_df, doublereal*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 df");
+ 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_ef))
+ rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ef) != 1)
+ rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_ef) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
+ if (NA_TYPE(rblapack_ef) != NA_DCOMPLEX)
+ rblapack_ef = na_change_type(rblapack_ef, NA_DCOMPLEX);
+ ef = NA_PTR_TYPE(rblapack_ef, doublecomplex*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ ldx = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublereal*);
+ MEMCPY(df_out__, df, doublereal, NA_TOTAL(rblapack_df));
+ rblapack_df = rblapack_df_out__;
+ df = df_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_ef_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, doublecomplex*);
+ MEMCPY(ef_out__, ef, doublecomplex, NA_TOTAL(rblapack_ef));
+ rblapack_ef = rblapack_ef_out__;
+ ef = ef_out__;
+ work = ALLOC_N(doublecomplex, (n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
+}
+
+void
+init_lapack_zptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zptsvx", rblapack_zptsvx, -1);
+}
diff --git a/ext/zpttrf.c b/ext/zpttrf.c
new file mode 100644
index 0000000..d97b0b3
--- /dev/null
+++ b/ext/zpttrf.c
@@ -0,0 +1,93 @@
+#include "rb_lapack.h"
+
+extern VOID zpttrf_(integer* n, doublereal* d, doublecomplex* e, integer* info);
+
+
+static VALUE
+rblapack_zpttrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublecomplex *e_out__;
+
+ 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, d, e = NumRu::Lapack.zpttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* ZPTTRF computes the L*D*L' factorization of a complex Hermitian\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.zpttrf( d, e, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublecomplex*);
+ MEMCPY(e_out__, e, doublecomplex, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ zpttrf_(&n, d, e, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_zpttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpttrf", rblapack_zpttrf, -1);
+}
diff --git a/ext/zpttrs.c b/ext/zpttrs.c
new file mode 100644
index 0000000..9c8134d
--- /dev/null
+++ b/ext/zpttrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID zpttrs_(char* uplo, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zpttrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zpttrs( uplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 'U': A = U'*D*U, E is the superdiagonal of U\n* = 'L': A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER IUPLO, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPTTS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpttrs( uplo, d, e, b, [: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_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zpttrs_(&uplo, &n, &nrhs, d, e, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zpttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zpttrs", rblapack_zpttrs, -1);
+}
diff --git a/ext/zptts2.c b/ext/zptts2.c
new file mode 100644
index 0000000..e6208ba
--- /dev/null
+++ b/ext/zptts2.c
@@ -0,0 +1,98 @@
+#include "rb_lapack.h"
+
+extern VOID zptts2_(integer* iuplo, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublecomplex* b, integer* ldb);
+
+
+static VALUE
+rblapack_zptts2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_iuplo;
+ integer iuplo;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 b = NumRu::Lapack.zptts2( iuplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* ZPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* IUPLO (input) INTEGER\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 1: A = U'*D*U, E is the superdiagonal of U\n* = 0: A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL ZDSCAL\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.zptts2( iuplo, d, e, b, [: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_iuplo = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ iuplo = NUM2INT(rblapack_iuplo);
+ 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);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zptts2_(&iuplo, &n, &nrhs, d, e, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_zptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zptts2", rblapack_zptts2, -1);
+}
diff --git a/ext/zrot.c b/ext/zrot.c
new file mode 100644
index 0000000..81158a3
--- /dev/null
+++ b/ext/zrot.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zrot_(integer* n, doublecomplex* cx, integer* incx, doublecomplex* cy, integer* incy, doublereal* c, doublecomplex* s);
+
+
+static VALUE
+rblapack_zrot(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_cx;
+ doublecomplex *cx;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_cy;
+ doublecomplex *cy;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_c;
+ doublereal c;
+ VALUE rblapack_s;
+ doublecomplex s;
+ VALUE rblapack_cx_out__;
+ doublecomplex *cx_out__;
+ VALUE rblapack_cy_out__;
+ doublecomplex *cy_out__;
+
+ 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 cx, cy = NumRu::Lapack.zrot( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* ZROT applies a plane rotation, where the cos (C) is real and the\n* sin (S) is complex, and the vectors CX and CY are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector X.\n* On output, CX is overwritten with C*X + S*Y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* CY (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector Y.\n* On output, CY is overwritten with -CONJG(S)*X + C*Y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* C (input) DOUBLE PRECISION\n* S (input) COMPLEX*16\n* C and S define a rotation\n* [ C S ]\n* [ -conjg(S) C ]\n* where C*C + S*CONJG(S) = 1.0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX*16 STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.zrot( cx, incx, cy, incy, c, s, [: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_cx = argv[0];
+ rblapack_incx = argv[1];
+ rblapack_cy = argv[2];
+ rblapack_incy = argv[3];
+ rblapack_c = argv[4];
+ rblapack_s = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_cx))
+ rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
+ if (NA_RANK(rblapack_cx) != 1)
+ rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_cx);
+ if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
+ rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
+ cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
+ if (!NA_IsNArray(rblapack_cy))
+ rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
+ if (NA_RANK(rblapack_cy) != 1)
+ rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_cy) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
+ if (NA_TYPE(rblapack_cy) != NA_DCOMPLEX)
+ rblapack_cy = na_change_type(rblapack_cy, NA_DCOMPLEX);
+ cy = NA_PTR_TYPE(rblapack_cy, doublecomplex*);
+ c = NUM2DBL(rblapack_c);
+ incx = NUM2INT(rblapack_incx);
+ s.r = NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
+ s.i = NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
+ incy = NUM2INT(rblapack_incy);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, doublecomplex*);
+ MEMCPY(cx_out__, cx, doublecomplex, NA_TOTAL(rblapack_cx));
+ rblapack_cx = rblapack_cx_out__;
+ cx = cx_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_cy_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, doublecomplex*);
+ MEMCPY(cy_out__, cy, doublecomplex, NA_TOTAL(rblapack_cy));
+ rblapack_cy = rblapack_cy_out__;
+ cy = cy_out__;
+
+ zrot_(&n, cx, &incx, cy, &incy, &c, &s);
+
+ return rb_ary_new3(2, rblapack_cx, rblapack_cy);
+}
+
+void
+init_lapack_zrot(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zrot", rblapack_zrot, -1);
+}
diff --git a/ext/zspcon.c b/ext/zspcon.c
new file mode 100644
index 0000000..7d8fe7b
--- /dev/null
+++ b/ext/zspcon.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID zspcon_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zspcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *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 rcond, info = NumRu::Lapack.zspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric packed matrix A using the\n* factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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.zspcon( uplo, ap, ipiv, anorm, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zspcon", rblapack_zspcon, -1);
+}
diff --git a/ext/zspmv.c b/ext/zspmv.c
new file mode 100644
index 0000000..f4b461f
--- /dev/null
+++ b/ext/zspmv.c
@@ -0,0 +1,117 @@
+#include "rb_lapack.h"
+
+extern VOID zspmv_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* ap, doublecomplex* x, integer* incx, doublecomplex* beta, doublecomplex* y, integer* incy);
+
+
+static VALUE
+rblapack_zspmv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublecomplex beta;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_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 y = NumRu::Lapack.zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZSPMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* AP (input) COMPLEX*16 array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on.\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX*16\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_n = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_ap = argv[3];
+ rblapack_x = argv[4];
+ rblapack_incx = argv[5];
+ rblapack_beta = argv[6];
+ rblapack_y = argv[7];
+ rblapack_incy = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (5th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( 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_y))
+ rb_raise(rb_eArgError, "y (8th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ 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_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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ beta.r = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
+ beta.i = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ 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__;
+
+ zspmv_(&uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_zspmv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zspmv", rblapack_zspmv, -1);
+}
diff --git a/ext/zspr.c b/ext/zspr.c
new file mode 100644
index 0000000..77552cf
--- /dev/null
+++ b/ext/zspr.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID zspr_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* ap);
+
+
+static VALUE
+rblapack_zspr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ap_out__;
+ doublecomplex *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 ap = NumRu::Lapack.zspr( uplo, n, alpha, x, incx, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n* Purpose\n* =======\n*\n* ZSPR performs the symmetric rank 1 operation\n*\n* A := alpha*x*conjg( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* AP (input/output) COMPLEX*16 array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on. On exit, the array\n* AP is overwritten by the upper triangular part of the\n* updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on. On exit, the array\n* AP is overwritten by the lower triangular part of the\n* updated matrix.\n* Note that the imaginary parts of the diagonal elements need\n* not be set, they are assumed to be zero, and on exit they\n* are set to zero.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ap = NumRu::Lapack.zspr( uplo, n, alpha, x, incx, ap, [: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_n = argv[1];
+ rblapack_alpha = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_ap = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ incx = NUM2INT(rblapack_incx);
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (6th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (6th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ( n*( n + 1 ) )/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zspr_(&uplo, &n, &alpha, x, &incx, ap);
+
+ return rblapack_ap;
+}
+
+void
+init_lapack_zspr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zspr", rblapack_zspr, -1);
+}
diff --git a/ext/zsprfs.c b/ext/zsprfs.c
new file mode 100644
index 0000000..6615299
--- /dev/null
+++ b/ext/zsprfs.c
@@ -0,0 +1,149 @@
+#include "rb_lapack.h"
+
+extern VOID zsprfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zsprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_afp;
+ doublecomplex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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.zsprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by ZSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZSPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zsprfs( uplo, ap, afp, ipiv, 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_ap = argv[1];
+ rblapack_afp = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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 (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);
+ nrhs = NA_SHAPE1(rblapack_x);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ 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);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zsprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zsprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsprfs", rblapack_zsprfs, -1);
+}
diff --git a/ext/zspsv.c b/ext/zspsv.c
new file mode 100644
index 0000000..1e19154
--- /dev/null
+++ b/ext/zspsv.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID zspsv_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zspsv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+ 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 ipiv, info, ap, b = NumRu::Lapack.zspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZSPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZSPTRF, ZSPTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.zspsv( uplo, ap, b, [: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_b = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ n = ldb;
+ 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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
+}
+
+void
+init_lapack_zspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zspsv", rblapack_zspsv, -1);
+}
diff --git a/ext/zspsvx.c b/ext/zspsvx.c
new file mode 100644
index 0000000..c63904f
--- /dev/null
+++ b/ext/zspsvx.c
@@ -0,0 +1,163 @@
+#include "rb_lapack.h"
+
+extern VOID zspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zspsvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_afp;
+ doublecomplex *afp;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_afp_out__;
+ doublecomplex *afp_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form\n* of A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSPTRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zspsvx( fact, uplo, ap, afp, ipiv, b, [: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_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_ap = argv[2];
+ rblapack_afp = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ ldx = MAX(1,n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_afp))
+ rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
+ if (NA_RANK(rblapack_afp) != 1)
+ rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
+ rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
+ afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ap))
+ rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ap) != 1)
+ rb_raise(rb_eArgError, "rank of ap (3th 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublecomplex*);
+ MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rblapack_afp));
+ rblapack_afp = rblapack_afp_out__;
+ afp = afp_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
+}
+
+void
+init_lapack_zspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zspsvx", rblapack_zspsvx, -1);
+}
diff --git a/ext/zsptrf.c b/ext/zsptrf.c
new file mode 100644
index 0000000..bc3f797
--- /dev/null
+++ b/ext/zsptrf.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID zsptrf_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zsptrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+
+ 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 ipiv, info, ap = NumRu::Lapack.zsptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZSPTRF computes the factorization of a complex symmetric matrix A\n* stored in packed format using the Bunch-Kaufman diagonal pivoting\n* method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.zsptrf( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = ldap;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ zsptrf_(&uplo, &n, ap, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zsptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsptrf", rblapack_zsptrf, -1);
+}
diff --git a/ext/zsptri.c b/ext/zsptri.c
new file mode 100644
index 0000000..ce7ab64
--- /dev/null
+++ b/ext/zsptri.c
@@ -0,0 +1,89 @@
+#include "rb_lapack.h"
+
+extern VOID zsptri_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zsptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *ap_out__;
+ doublecomplex *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 info, ap = NumRu::Lapack.zsptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPTRI computes the inverse of a complex symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* WORK (workspace) COMPLEX*16 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zsptri( uplo, ap, ipiv, [: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_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zsptri_(&uplo, &n, ap, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_zsptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsptri", rblapack_zsptri, -1);
+}
diff --git a/ext/zsptrs.c b/ext/zsptrs.c
new file mode 100644
index 0000000..49cf64c
--- /dev/null
+++ b/ext/zsptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID zsptrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zsptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zsptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZSPTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.zsptrs( uplo, ap, ipiv, b, [: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_ap = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zsptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zsptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsptrs", rblapack_zsptrs, -1);
+}
diff --git a/ext/zstedc.c b/ext/zstedc.c
new file mode 100644
index 0000000..6dfc927
--- /dev/null
+++ b/ext/zstedc.c
@@ -0,0 +1,177 @@
+#include "rb_lapack.h"
+
+extern VOID zstedc_(char* compz, integer* n, doublereal* d, doublereal* e, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zstedc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_rwork;
+ doublereal *rwork;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 work, rwork, iwork, info, d, e, z = NumRu::Lapack.zstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See DLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original Hermitian matrix\n* also. On entry, Z contains the unitary matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n* Note that for COMPZ = 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be 1.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 3*N + 2*N*lg N + 3*N**2 ,\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1, LRWORK must be at least\n* 1 + 4*N + 2*N**2 .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LRWORK\n* need only be max(1,2*(N-1)).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If COMPZ = 'V' or N > 1, LIWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* If COMPZ = 'I' or N > 1, LIWORK must be at least\n* 3 + 5*N .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, rwork, iwork, info, d, e, z = NumRu::Lapack.zstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 7) {
+ rblapack_lwork = argv[4];
+ rblapack_lrwork = argv[5];
+ rblapack_liwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_lrwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 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 (rblapack_lwork == Qnil)
+ lwork = (lsame_(&compz,"N")||lsame_(&compz,"I")||n<=1) ? 1 : lsame_(&compz,"V") ? n*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (rblapack_liwork == Qnil)
+ liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (rblapack_lrwork == Qnil)
+ lrwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
+ else {
+ lrwork = NUM2INT(rblapack_lrwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lrwork);
+ rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ zstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(7, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_zstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zstedc", rblapack_zstedc, -1);
+}
diff --git a/ext/zstegr.c b/ext/zstegr.c
new file mode 100644
index 0000000..a015f74
--- /dev/null
+++ b/ext/zstegr.c
@@ -0,0 +1,188 @@
+#include "rb_lapack.h"
+
+extern VOID zstegr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zstegr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_abstol;
+ doublereal abstol;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.zstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* ZSTEGR is a compatability wrapper around the improved ZSTEMR routine.\n* See DSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : ZSTEGR and ZSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in ZLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* ZLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL ZSTEMR\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.zstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 11)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_abstol = argv[8];
+ if (argc == 11) {
+ rblapack_lwork = argv[9];
+ rblapack_liwork = argv[10];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ abstol = NUM2DBL(rblapack_abstol);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ zstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
+}
+
+void
+init_lapack_zstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zstegr", rblapack_zstegr, -1);
+}
diff --git a/ext/zstein.c b/ext/zstein.c
new file mode 100644
index 0000000..490639f
--- /dev/null
+++ b/ext/zstein.c
@@ -0,0 +1,134 @@
+#include "rb_lapack.h"
+
+extern VOID zstein_(integer* n, doublereal* d, doublereal* e, integer* m, doublereal* w, integer* iblock, integer* isplit, doublecomplex* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);
+
+
+static VALUE
+rblapack_zstein(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_iblock;
+ integer *iblock;
+ VALUE rblapack_isplit;
+ integer *isplit;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ifail;
+ integer *ifail;
+ VALUE rblapack_info;
+ integer info;
+ doublereal *work;
+ integer *iwork;
+
+ integer n;
+ integer ldz;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.zstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n* Although the eigenvectors are real, they are stored in a complex\n* array, which may be passed to ZUNMTR or ZUPMTR for back\n* transformation to the eigenvectors of a complex Hermitian matrix\n* which was reduced to tridiagonal form.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, stored in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from DSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from DSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from DSTEBZ is expected here. )\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n* The imaginary parts of the eigenvectors are set to zero.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.zstein( d, e, w, iblock, isplit, [: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_d = argv[0];
+ rblapack_e = argv[1];
+ rblapack_w = argv[2];
+ rblapack_iblock = argv[3];
+ rblapack_isplit = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (1th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ if (!NA_IsNArray(rblapack_w))
+ rb_raise(rb_eArgError, "w (3th argument) must be NArray");
+ if (NA_RANK(rblapack_w) != 1)
+ rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_w) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_w) != NA_DFLOAT)
+ rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ if (!NA_IsNArray(rblapack_isplit))
+ rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
+ if (NA_RANK(rblapack_isplit) != 1)
+ rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_isplit) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_isplit) != NA_LINT)
+ rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
+ isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
+ if (!NA_IsNArray(rblapack_iblock))
+ rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
+ if (NA_RANK(rblapack_iblock) != 1)
+ rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_iblock) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_iblock) != NA_LINT)
+ rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
+ iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
+ m = n;
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (2th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ ldz = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = m;
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
+ work = ALLOC_N(doublereal, (5*n));
+ iwork = ALLOC_N(integer, (n));
+
+ zstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
+
+ free(work);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
+}
+
+void
+init_lapack_zstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zstein", rblapack_zstein, -1);
+}
diff --git a/ext/zstemr.c b/ext/zstemr.c
new file mode 100644
index 0000000..570ea2e
--- /dev/null
+++ b/ext/zstemr.c
@@ -0,0 +1,193 @@
+#include "rb_lapack.h"
+
+extern VOID zstemr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, integer* m, doublereal* w, doublecomplex* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_zstemr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobz;
+ char jobz;
+ VALUE rblapack_range;
+ char range;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_vl;
+ doublereal vl;
+ VALUE rblapack_vu;
+ doublereal vu;
+ VALUE rblapack_il;
+ integer il;
+ VALUE rblapack_iu;
+ integer iu;
+ VALUE rblapack_nzc;
+ integer nzc;
+ VALUE rblapack_tryrac;
+ logical tryrac;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_w;
+ doublereal *w;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_isuppz;
+ integer *isuppz;
+ VALUE rblapack_work;
+ doublereal *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+
+ integer n;
+ integer ldz;
+
+ 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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.zstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.ZSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n* real symmetric tridiagonal form.\n*\n* (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n* and potentially complex numbers on its off-diagonals. By applying a\n* similarity transform with an appropriate diagonal matrix\n* diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n* matrix can be transformed into a real symmetric matrix and complex\n* arithmetic can be entirely avoided.)\n*\n* While the eigenvectors of the real symmetric tridiagonal matrix are real,\n* the eigenvectors of original complex Hermitean matrix have complex entries\n* in general.\n* Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n* ZSTEMR accepts complex workspace to facilitate interoperability\n* with ZUNMTR or ZUPMTR.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in ZLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* ZLARRV, respectively.\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 m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.zstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 12)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
+ rblapack_jobz = argv[0];
+ rblapack_range = argv[1];
+ rblapack_d = argv[2];
+ rblapack_e = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vu = argv[5];
+ rblapack_il = argv[6];
+ rblapack_iu = argv[7];
+ rblapack_nzc = argv[8];
+ rblapack_tryrac = argv[9];
+ if (argc == 12) {
+ rblapack_lwork = argv[10];
+ rblapack_liwork = argv[11];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ jobz = StringValueCStr(rblapack_jobz)[0];
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (3th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_d);
+ if (NA_TYPE(rblapack_d) != NA_DFLOAT)
+ rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
+ d = NA_PTR_TYPE(rblapack_d, doublereal*);
+ vl = NUM2DBL(rblapack_vl);
+ il = NUM2INT(rblapack_il);
+ nzc = NUM2INT(rblapack_nzc);
+ range = StringValueCStr(rblapack_range)[0];
+ vu = NUM2DBL(rblapack_vu);
+ tryrac = (rblapack_tryrac == Qtrue);
+ if (!NA_IsNArray(rblapack_e))
+ rb_raise(rb_eArgError, "e (4th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
+ iu = NUM2INT(rblapack_iu);
+ m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
+ if (rblapack_liwork == Qnil)
+ liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = MAX(1,m);
+ rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 2*MAX(1,m);
+ rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+
+ zstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ rblapack_tryrac = tryrac ? Qtrue : Qfalse;
+ return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
+}
+
+void
+init_lapack_zstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zstemr", rblapack_zstemr, -1);
+}
diff --git a/ext/zsteqr.c b/ext/zsteqr.c
new file mode 100644
index 0000000..20879fe
--- /dev/null
+++ b/ext/zsteqr.c
@@ -0,0 +1,126 @@
+#include "rb_lapack.h"
+
+extern VOID zsteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublecomplex* z, integer* ldz, doublereal* work, integer* info);
+
+
+static VALUE
+rblapack_zsteqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compz;
+ char compz;
+ VALUE rblapack_d;
+ doublereal *d;
+ VALUE rblapack_e;
+ doublereal *e;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_d_out__;
+ doublereal *d_out__;
+ VALUE rblapack_e_out__;
+ doublereal *e_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+ doublereal *work;
+
+ integer n;
+ integer ldz;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.zsteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* Hermitian matrix. On entry, Z must contain the\n* unitary matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is unitarily similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.zsteqr( compz, d, e, z, [: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_compz = argv[0];
+ rblapack_d = argv[1];
+ rblapack_e = argv[2];
+ rblapack_z = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compz = StringValueCStr(rblapack_compz)[0];
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (4th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ n = NA_SHAPE1(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*);
+ if (!NA_IsNArray(rblapack_d))
+ rb_raise(rb_eArgError, "d (2th argument) must be NArray");
+ if (NA_RANK(rblapack_d) != 1)
+ rb_raise(rb_eArgError, "rank of d (2th 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 1 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_e))
+ rb_raise(rb_eArgError, "e (3th argument) must be NArray");
+ if (NA_RANK(rblapack_e) != 1)
+ rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_e) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
+ if (NA_TYPE(rblapack_e) != NA_DFLOAT)
+ rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
+ e = NA_PTR_TYPE(rblapack_e, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
+ MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
+ rblapack_d = rblapack_d_out__;
+ d = d_out__;
+ {
+ int shape[1];
+ shape[0] = n-1;
+ rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
+ MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
+ rblapack_e = rblapack_e_out__;
+ e = e_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
+
+ zsteqr_(&compz, &n, d, e, z, &ldz, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
+}
+
+void
+init_lapack_zsteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsteqr", rblapack_zsteqr, -1);
+}
diff --git a/ext/zsycon.c b/ext/zsycon.c
new file mode 100644
index 0000000..4c6a695
--- /dev/null
+++ b/ext/zsycon.c
@@ -0,0 +1,87 @@
+#include "rb_lapack.h"
+
+extern VOID zsycon_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zsycon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_anorm;
+ doublereal anorm;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+
+ 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 rcond, info = NumRu::Lapack.zsycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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.zsycon( uplo, a, ipiv, anorm, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_anorm = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ anorm = NUM2DBL(rblapack_anorm);
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zsycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
+
+ free(work);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_zsycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsycon", rblapack_zsycon, -1);
+}
diff --git a/ext/zsyconv.c b/ext/zsyconv.c
new file mode 100644
index 0000000..29f068b
--- /dev/null
+++ b/ext/zsyconv.c
@@ -0,0 +1,84 @@
+#include "rb_lapack.h"
+
+extern VOID zsyconv_(char* uplo, char* way, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zsyconv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_way;
+ char way;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+
+ 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 = NumRu::Lapack.zsyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYCONV converts A given by ZHETRF into L and D or vice-versa.\n* Get nondiagonal elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) DOUBLE COMPLEX array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 = NumRu::Lapack.zsyconv( uplo, way, a, ipiv, [: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_way = argv[1];
+ rblapack_a = argv[2];
+ rblapack_ipiv = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ way = StringValueCStr(rblapack_way)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ work = ALLOC_N(doublecomplex, (MAX(1,n)));
+
+ zsyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rblapack_info;
+}
+
+void
+init_lapack_zsyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsyconv", rblapack_zsyconv, -1);
+}
diff --git a/ext/zsyequb.c b/ext/zsyequb.c
new file mode 100644
index 0000000..d628a0a
--- /dev/null
+++ b/ext/zsyequb.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zsyequb_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zsyequb(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_info;
+ integer info;
+ doublecomplex *work;
+
+ 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 s, scond, amax, info = NumRu::Lapack.zsyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zsyequb( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ work = ALLOC_N(doublecomplex, (3*n));
+
+ zsyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
+
+ free(work);
+ rblapack_scond = rb_float_new((double)scond);
+ rblapack_amax = rb_float_new((double)amax);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
+}
+
+void
+init_lapack_zsyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsyequb", rblapack_zsyequb, -1);
+}
diff --git a/ext/zsymv.c b/ext/zsymv.c
new file mode 100644
index 0000000..3b9ba91
--- /dev/null
+++ b/ext/zsymv.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID zsymv_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* a, integer* lda, doublecomplex* x, integer* incx, doublecomplex* beta, doublecomplex* y, integer* incy);
+
+
+static VALUE
+rblapack_zsymv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_beta;
+ doublecomplex beta;
+ VALUE rblapack_y;
+ doublecomplex *y;
+ VALUE rblapack_incy;
+ integer incy;
+ VALUE rblapack_y_out__;
+ doublecomplex *y_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 y = NumRu::Lapack.zsymv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZSYMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX*16 array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX*16\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n y = NumRu::Lapack.zsymv( uplo, alpha, a, x, incx, beta, y, incy, [: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_uplo = argv[0];
+ rblapack_alpha = argv[1];
+ rblapack_a = argv[2];
+ rblapack_x = argv[3];
+ rblapack_incx = argv[4];
+ rblapack_beta = argv[5];
+ rblapack_y = argv[6];
+ rblapack_incy = argv[7];
+ if (argc == 8) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ incx = NUM2INT(rblapack_incx);
+ incy = NUM2INT(rblapack_incy);
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ beta.r = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
+ beta.i = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (4th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( 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_y))
+ rb_raise(rb_eArgError, "y (7th argument) must be NArray");
+ if (NA_RANK(rblapack_y) != 1)
+ rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
+ rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
+ if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
+ rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
+ y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 1 + ( n - 1 )*abs( incy );
+ 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__;
+
+ zsymv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
+
+ return rblapack_y;
+}
+
+void
+init_lapack_zsymv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsymv", rblapack_zsymv, -1);
+}
diff --git a/ext/zsyr.c b/ext/zsyr.c
new file mode 100644
index 0000000..ea8c033
--- /dev/null
+++ b/ext/zsyr.c
@@ -0,0 +1,95 @@
+#include "rb_lapack.h"
+
+extern VOID zsyr_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* a, integer* lda);
+
+
+static VALUE
+rblapack_zsyr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_incx;
+ integer incx;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ 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 a = NumRu::Lapack.zsyr( uplo, alpha, x, incx, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n* Purpose\n* =======\n*\n* ZSYR performs the symmetric rank 1 operation\n*\n* A := alpha*x*( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* A (input/output) COMPLEX*16 array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced. On exit, the\n* upper triangular part of the array A is overwritten by the\n* upper triangular part of the updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced. On exit, the\n* lower triangular part of the array A is overwritten by the\n* lower triangular part of the updated matrix.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.zsyr( uplo, alpha, x, incx, a, [: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_alpha = argv[1];
+ rblapack_x = argv[2];
+ rblapack_incx = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ incx = NUM2INT(rblapack_incx);
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (3th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 1)
+ rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
+ rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int 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__;
+
+ zsyr_(&uplo, &n, &alpha, x, &incx, a, &lda);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_zsyr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsyr", rblapack_zsyr, -1);
+}
diff --git a/ext/zsyrfs.c b/ext/zsyrfs.c
new file mode 100644
index 0000000..3a0149e
--- /dev/null
+++ b/ext/zsyrfs.c
@@ -0,0 +1,153 @@
+#include "rb_lapack.h"
+
+extern VOID zsyrfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zsyrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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.zsyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZSYTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.zsyrfs( uplo, a, af, ipiv, 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_a = argv[1];
+ rblapack_af = argv[2];
+ rblapack_ipiv = argv[3];
+ rblapack_b = argv[4];
+ rblapack_x = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (3th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ n = NA_SHAPE1(rblapack_af);
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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 1 of af");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (4th 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 1 of af");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ zsyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
+}
+
+void
+init_lapack_zsyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsyrfs", rblapack_zsyrfs, -1);
+}
diff --git a/ext/zsyrfsx.c b/ext/zsyrfsx.c
new file mode 100644
index 0000000..3bffd4d
--- /dev/null
+++ b/ext/zsyrfsx.c
@@ -0,0 +1,218 @@
+#include "rb_lapack.h"
+
+extern VOID zsyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zsyrfsx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_x_out__;
+ doublecomplex *x_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer ldx;
+ integer nparams;
+ integer n_err_bnds;
+
+ 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, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_equed = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_s = argv[5];
+ rblapack_b = argv[6];
+ rblapack_x = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (6th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 1)
+ rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ n_err_bnds = 3;
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (8th 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zsyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
+}
+
+void
+init_lapack_zsyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsyrfsx", rblapack_zsyrfsx, -1);
+}
diff --git a/ext/zsysv.c b/ext/zsysv.c
new file mode 100644
index 0000000..9fcbd9a
--- /dev/null
+++ b/ext/zsysv.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID zsysv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zsysv(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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 ipiv, work, info, a, b = NumRu::Lapack.zsysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* ZSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZSYTRF, ZSYTRS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.zsysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_b = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (3th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zsysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
+}
+
+void
+init_lapack_zsysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsysv", rblapack_zsysv, -1);
+}
diff --git a/ext/zsysvx.c b/ext/zsysvx.c
new file mode 100644
index 0000000..14debfa
--- /dev/null
+++ b/ext/zsysvx.c
@@ -0,0 +1,183 @@
+#include "rb_lapack.h"
+
+extern VOID zsysvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zsysvx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ 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 x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSYTRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for ZSYTRF.\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* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_b = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ ldx = MAX(1,n);
+ if (rblapack_lwork == Qnil)
+ lwork = 3*n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ rwork = ALLOC_N(doublereal, (n));
+
+ zsysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
+
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
+}
+
+void
+init_lapack_zsysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsysvx", rblapack_zsysvx, -1);
+}
diff --git a/ext/zsysvxx.c b/ext/zsysvxx.c
new file mode 100644
index 0000000..38c7bf6
--- /dev/null
+++ b/ext/zsysvxx.c
@@ -0,0 +1,258 @@
+#include "rb_lapack.h"
+
+extern VOID zsysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_zsysvxx(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_fact;
+ char fact;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_af;
+ doublecomplex *af;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_equed;
+ char equed;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_params;
+ doublereal *params;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_rpvgrw;
+ doublereal rpvgrw;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_err_bnds_norm;
+ doublereal *err_bnds_norm;
+ VALUE rblapack_err_bnds_comp;
+ doublereal *err_bnds_comp;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_af_out__;
+ doublecomplex *af_out__;
+ VALUE rblapack_ipiv_out__;
+ integer *ipiv_out__;
+ VALUE rblapack_s_out__;
+ doublereal *s_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_params_out__;
+ doublereal *params_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ integer n;
+ integer ldaf;
+ integer ldb;
+ integer nrhs;
+ integer nparams;
+ integer ldx;
+ integer n_err_bnds;
+
+ 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, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex*16 system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_fact = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ rblapack_af = argv[3];
+ rblapack_ipiv = argv[4];
+ rblapack_equed = argv[5];
+ rblapack_s = argv[6];
+ rblapack_b = argv[7];
+ rblapack_params = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ fact = StringValueCStr(rblapack_fact)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (5th 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 1 of a");
+ 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_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) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_s) != NA_DFLOAT)
+ rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ if (!NA_IsNArray(rblapack_params))
+ rb_raise(rb_eArgError, "params (9th argument) must be NArray");
+ if (NA_RANK(rblapack_params) != 1)
+ rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
+ nparams = NA_SHAPE0(rblapack_params);
+ if (NA_TYPE(rblapack_params) != NA_DFLOAT)
+ rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
+ params = NA_PTR_TYPE(rblapack_params, doublereal*);
+ n_err_bnds = 3;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ equed = StringValueCStr(rblapack_equed)[0];
+ if (!NA_IsNArray(rblapack_af))
+ rb_raise(rb_eArgError, "af (4th argument) must be NArray");
+ if (NA_RANK(rblapack_af) != 2)
+ rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
+ ldaf = NA_SHAPE0(rblapack_af);
+ if (NA_SHAPE1(rblapack_af) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
+ rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
+ af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
+ ldx = MAX(1,n);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (8th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldx;
+ shape[1] = nrhs;
+ rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
+ {
+ int shape[2];
+ shape[0] = nrhs;
+ shape[1] = n_err_bnds;
+ rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
+ }
+ err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldaf;
+ shape[1] = n;
+ rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
+ MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
+ rblapack_af = rblapack_af_out__;
+ af = af_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
+ MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
+ rblapack_ipiv = rblapack_ipiv_out__;
+ ipiv = ipiv_out__;
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
+ MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
+ rblapack_s = rblapack_s_out__;
+ s = s_out__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[1];
+ shape[0] = nparams;
+ rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
+ MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
+ rblapack_params = rblapack_params_out__;
+ params = params_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ zsysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_rpvgrw = rb_float_new((double)rpvgrw);
+ rblapack_info = INT2NUM(info);
+ rblapack_equed = rb_str_new(&equed,1);
+ return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
+}
+
+void
+init_lapack_zsysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsysvxx", rblapack_zsysvxx, -1);
+}
diff --git a/ext/zsyswapr.c b/ext/zsyswapr.c
new file mode 100644
index 0000000..e68b319
--- /dev/null
+++ b/ext/zsyswapr.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID zsyswapr_(char* uplo, integer* n, doublecomplex* a, integer* i1, integer* i2);
+
+
+static VALUE
+rblapack_zsyswapr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_i1;
+ integer i1;
+ VALUE rblapack_i2;
+ integer i2;
+ 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 a = NumRu::Lapack.zsyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* ZSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n DOUBLE COMPLEX TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZSWAP\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a = NumRu::Lapack.zsyswapr( uplo, a, i1, i2, [: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_a = argv[1];
+ rblapack_i1 = argv[2];
+ rblapack_i2 = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ i1 = NUM2INT(rblapack_i1);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ i2 = NUM2INT(rblapack_i2);
+ {
+ int 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__;
+
+ zsyswapr_(&uplo, &n, a, &i1, &i2);
+
+ return rblapack_a;
+}
+
+void
+init_lapack_zsyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsyswapr", rblapack_zsyswapr, -1);
+}
diff --git a/ext/zsytf2.c b/ext/zsytf2.c
new file mode 100644
index 0000000..8150a89
--- /dev/null
+++ b/ext/zsytf2.c
@@ -0,0 +1,85 @@
+#include "rb_lapack.h"
+
+extern VOID zsytf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);
+
+
+static VALUE
+rblapack_zsytf2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ 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 ipiv, info, a = NumRu::Lapack.zsytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTF2 computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.209 and l.377\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zsytf2( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int 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__;
+
+ zsytf2_(&uplo, &n, a, &lda, ipiv, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zsytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsytf2", rblapack_zsytf2, -1);
+}
diff --git a/ext/zsytrf.c b/ext/zsytrf.c
new file mode 100644
index 0000000..81850ec
--- /dev/null
+++ b/ext/zsytrf.c
@@ -0,0 +1,97 @@
+#include "rb_lapack.h"
+
+extern VOID zsytrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zsytrf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 ipiv, work, info, a = NumRu::Lapack.zsytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRF computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLASYF, ZSYTF2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.zsytrf( uplo, a, lwork, [: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_a = argv[1];
+ rblapack_lwork = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lwork = NUM2INT(rblapack_lwork);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zsytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zsytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsytrf", rblapack_zsytrf, -1);
+}
diff --git a/ext/zsytri.c b/ext/zsytri.c
new file mode 100644
index 0000000..078b786
--- /dev/null
+++ b/ext/zsytri.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID zsytri_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zsytri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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.zsytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRI computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* ZSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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 block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.zsytri( uplo, a, ipiv, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ zsytri_(&uplo, &n, a, &lda, ipiv, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zsytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsytri", rblapack_zsytri, -1);
+}
diff --git a/ext/zsytri2.c b/ext/zsytri2.c
new file mode 100644
index 0000000..29b405b
--- /dev/null
+++ b/ext/zsytri2.c
@@ -0,0 +1,104 @@
+#include "rb_lapack.h"
+
+extern VOID zsytri2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zsytri2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ integer c__1;
+ integer c__m1;
+ integer nb;
+ doublecomplex *work;
+
+ 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.zsytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* ZSYTRF. ZSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling ZSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) DOUBLE COMPLEX array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL ZSYTRI2X\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zsytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_ipiv = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ if (NA_TYPE(rblapack_ipiv) != NA_LINT)
+ rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
+ ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
+ c__1 = 1;
+ 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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ c__m1 = -1;
+ nb = ilaenv_(&c__1, "ZSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
+ lwork = (n+nb+1)*(nb+3);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (lwork));
+
+ zsytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zsytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsytri2", rblapack_zsytri2, -1);
+}
diff --git a/ext/zsytri2x.c b/ext/zsytri2x.c
new file mode 100644
index 0000000..3c30507
--- /dev/null
+++ b/ext/zsytri2x.c
@@ -0,0 +1,96 @@
+#include "rb_lapack.h"
+
+extern VOID zsytri2x_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* nb, integer* info);
+
+
+static VALUE
+rblapack_zsytri2x(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_nb;
+ integer nb;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ 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.zsytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRI2X computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* ZSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) DOUBLE COMPLEX array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\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.zsytri2x( uplo, a, ipiv, nb, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_nb = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ nb = NUM2INT(rblapack_nb);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n+nb+1)*(nb+3));
+
+ zsytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zsytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsytri2x", rblapack_zsytri2x, -1);
+}
diff --git a/ext/zsytrs.c b/ext/zsytrs.c
new file mode 100644
index 0000000..1a0f9bd
--- /dev/null
+++ b/ext/zsytrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID zsytrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_zsytrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zsytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 info, b = NumRu::Lapack.zsytrs( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ zsytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zsytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsytrs", rblapack_zsytrs, -1);
+}
diff --git a/ext/zsytrs2.c b/ext/zsytrs2.c
new file mode 100644
index 0000000..8a6c228
--- /dev/null
+++ b/ext/zsytrs2.c
@@ -0,0 +1,106 @@
+#include "rb_lapack.h"
+
+extern VOID zsytrs2_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, real* work, integer* info);
+
+
+static VALUE
+rblapack_zsytrs2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ipiv;
+ integer *ipiv;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ real *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.zsytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRS2 solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 info, b = NumRu::Lapack.zsytrs2( uplo, a, ipiv, b, [: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_a = argv[1];
+ rblapack_ipiv = argv[2];
+ rblapack_b = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_ipiv))
+ rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
+ if (NA_RANK(rblapack_ipiv) != 1)
+ rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_ipiv);
+ 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_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 ipiv");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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);
+ nrhs = 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*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ work = ALLOC_N(real, (n));
+
+ zsytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_zsytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zsytrs2", rblapack_zsytrs2, -1);
+}
diff --git a/ext/ztbcon.c b/ext/ztbcon.c
new file mode 100644
index 0000000..c5f39de
--- /dev/null
+++ b/ext/ztbcon.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID ztbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztbcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ 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.ztbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.ztbcon( norm, uplo, diag, kd, ab, [: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_norm = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ norm = StringValueCStr(rblapack_norm)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ kd = NUM2INT(rblapack_kd);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ ztbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_ztbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztbcon", rblapack_ztbcon, -1);
+}
diff --git a/ext/ztbrfs.c b/ext/ztbrfs.c
new file mode 100644
index 0000000..3bdf60b
--- /dev/null
+++ b/ext/ztbrfs.c
@@ -0,0 +1,127 @@
+#include "rb_lapack.h"
+
+extern VOID ztbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztbrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer ldab;
+ 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 = NumRu::Lapack.ztbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by ZTBTRS or some other\n* means before entering this routine. ZTBRFS 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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.ztbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 7 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = argv[5];
+ rblapack_x = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ if (!NA_IsNArray(rblapack_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x))
+ rb_raise(rb_eArgError, "x (7th argument) must be NArray");
+ if (NA_RANK(rblapack_x) != 2)
+ rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
+ ldx = NA_SHAPE0(rblapack_x);
+ nrhs = NA_SHAPE1(rblapack_x);
+ if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ ztbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
+}
+
+void
+init_lapack_ztbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztbrfs", rblapack_ztbrfs, -1);
+}
diff --git a/ext/ztbtrs.c b/ext/ztbtrs.c
new file mode 100644
index 0000000..a39bb14
--- /dev/null
+++ b/ext/ztbtrs.c
@@ -0,0 +1,103 @@
+#include "rb_lapack.h"
+
+extern VOID ztbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ztbtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_kd;
+ integer kd;
+ VALUE rblapack_ab;
+ doublecomplex *ab;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldab;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ztbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZTBTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by-NRHS matrix. A check is made to verify that A is nonsingular.\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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ztbtrs( uplo, trans, diag, kd, ab, b, [: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_kd = argv[3];
+ rblapack_ab = argv[4];
+ rblapack_b = 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_ab))
+ rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
+ if (NA_RANK(rblapack_ab) != 2)
+ rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
+ ldab = NA_SHAPE0(rblapack_ab);
+ n = NA_SHAPE1(rblapack_ab);
+ if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
+ rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
+ ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ kd = NUM2INT(rblapack_kd);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ztbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ztbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztbtrs", rblapack_ztbtrs, -1);
+}
diff --git a/ext/ztfsm.c b/ext/ztfsm.c
new file mode 100644
index 0000000..4ba1945
--- /dev/null
+++ b/ext/ztfsm.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID ztfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, doublecomplex* alpha, doublecomplex* a, doublecomplex* b, integer* ldb);
+
+
+static VALUE
+rblapack_ztfsm(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_alpha;
+ doublecomplex alpha;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldb;
+ 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 b = NumRu::Lapack.ztfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* ZTFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = conjg( A' ).\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'C' or 'c' op( A ) = conjg( A' ).\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n b = NumRu::Lapack.ztfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_transr = argv[0];
+ rblapack_side = argv[1];
+ rblapack_uplo = argv[2];
+ rblapack_trans = argv[3];
+ rblapack_diag = argv[4];
+ rblapack_m = argv[5];
+ rblapack_alpha = argv[6];
+ rblapack_a = argv[7];
+ rblapack_b = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
+ alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (9th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (9th 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*);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (8th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ztfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
+
+ return rblapack_b;
+}
+
+void
+init_lapack_ztfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztfsm", rblapack_ztfsm, -1);
+}
diff --git a/ext/ztftri.c b/ext/ztftri.c
new file mode 100644
index 0000000..8005643
--- /dev/null
+++ b/ext/ztftri.c
@@ -0,0 +1,86 @@
+#include "rb_lapack.h"
+
+extern VOID ztftri_(char* transr, char* uplo, char* diag, integer* n, doublecomplex* a, integer* info);
+
+
+static VALUE
+rblapack_ztftri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_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, a = NumRu::Lapack.ztftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* ZTFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\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* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the triangular matrix A in RFP format. RFP format\n* is described by TRANSR, UPLO, and N as follows: If TRANSR =\n* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ztftri( transr, uplo, diag, n, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_n = argv[3];
+ rblapack_a = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ diag = StringValueCStr(rblapack_diag)[0];
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ n = NUM2INT(rblapack_n);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 1)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
+ rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 1, 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__;
+
+ ztftri_(&transr, &uplo, &diag, &n, a, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ztftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztftri", rblapack_ztftri, -1);
+}
diff --git a/ext/ztfttp.c b/ext/ztfttp.c
new file mode 100644
index 0000000..ceca866
--- /dev/null
+++ b/ext/ztfttp.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID ztfttp_(char* transr, char* uplo, integer* n, doublecomplex* arf, doublecomplex* ap, integer* info);
+
+
+static VALUE
+rblapack_ztfttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_arf;
+ doublecomplex *arf;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 ap, info = NumRu::Lapack.ztfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZTFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.ztfttp( transr, uplo, n, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_arf = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
+ rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
+ if (NA_TYPE(rblapack_arf) != NA_DCOMPLEX)
+ rblapack_arf = na_change_type(rblapack_arf, NA_DCOMPLEX);
+ arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_ap = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+
+ ztfttp_(&transr, &uplo, &n, arf, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_ztfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztfttp", rblapack_ztfttp, -1);
+}
diff --git a/ext/ztfttr.c b/ext/ztfttr.c
new file mode 100644
index 0000000..ab9da7c
--- /dev/null
+++ b/ext/ztfttr.c
@@ -0,0 +1,80 @@
+#include "rb_lapack.h"
+
+extern VOID ztfttr_(char* transr, char* uplo, integer* n, doublecomplex* arf, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ztfttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_arf;
+ doublecomplex *arf;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldarf;
+ 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 a, info = NumRu::Lapack.ztfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* A (output) COMPLEX*16 array, dimension ( LDA, N ) \n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.ztfttr( transr, uplo, arf, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_arf = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ if (!NA_IsNArray(rblapack_arf))
+ rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
+ if (NA_RANK(rblapack_arf) != 1)
+ rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
+ ldarf = NA_SHAPE0(rblapack_arf);
+ if (NA_TYPE(rblapack_arf) != NA_DCOMPLEX)
+ rblapack_arf = na_change_type(rblapack_arf, NA_DCOMPLEX);
+ arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);
+ n = ((int)sqrtf(8*ldarf+1.0f)-1)/2;
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+
+ ztfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_ztfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztfttr", rblapack_ztfttr, -1);
+}
diff --git a/ext/ztgevc.c b/ext/ztgevc.c
new file mode 100644
index 0000000..e760b6b
--- /dev/null
+++ b/ext/ztgevc.c
@@ -0,0 +1,156 @@
+#include "rb_lapack.h"
+
+extern VOID ztgevc_(char* side, char* howmny, logical* select, integer* n, doublecomplex* s, integer* lds, doublecomplex* p, integer* ldp, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* mm, integer* m, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztgevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_s;
+ doublecomplex *s;
+ VALUE rblapack_p;
+ doublecomplex *p;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_vl_out__;
+ doublecomplex *vl_out__;
+ VALUE rblapack_vr_out__;
+ doublecomplex *vr_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer n;
+ integer lds;
+ integer ldp;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, vl, vr = NumRu::Lapack.ztgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of complex matrices (S,P), where S and P are upper triangular.\n* Matrix pairs of this type are produced by the generalized Schur\n* factorization of a complex matrix pair (A,B):\n* \n* A = Q*S*Z**H, B = Q*P*Z**H\n* \n* as computed by ZGGHRD + ZHGEQZ.\n* \n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal elements of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the unitary factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. The eigenvector corresponding to the j-th\n* eigenvalue is computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) COMPLEX*16 array, dimension (LDS,N)\n* The upper triangular matrix S from a generalized Schur\n* factorization, as computed by ZHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) COMPLEX*16 array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by ZHGEQZ. P must have real\n* diagonal elements.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q\n* of left Schur vectors returned by ZHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n*\n* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Z\n* of right Schur vectors returned by ZHGEQZ).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Z*X;\n* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VR, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one column.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 m, info, vl, vr = NumRu::Lapack.ztgevc( side, howmny, select, s, p, vl, vr, [: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_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_s = argv[3];
+ rblapack_p = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = argv[6];
+ if (argc == 7) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_p))
+ rb_raise(rb_eArgError, "p (5th argument) must be NArray");
+ if (NA_RANK(rblapack_p) != 2)
+ rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
+ ldp = NA_SHAPE0(rblapack_p);
+ if (NA_SHAPE1(rblapack_p) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_p) != NA_DCOMPLEX)
+ rblapack_p = na_change_type(rblapack_p, NA_DCOMPLEX);
+ p = NA_PTR_TYPE(rblapack_p, doublecomplex*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ mm = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ if (!NA_IsNArray(rblapack_s))
+ rb_raise(rb_eArgError, "s (4th argument) must be NArray");
+ if (NA_RANK(rblapack_s) != 2)
+ rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
+ lds = NA_SHAPE0(rblapack_s);
+ if (NA_SHAPE1(rblapack_s) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_s) != NA_DCOMPLEX)
+ rblapack_s = na_change_type(rblapack_s, NA_DCOMPLEX);
+ s = NA_PTR_TYPE(rblapack_s, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublecomplex*);
+ MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublecomplex*);
+ MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (2*n));
+
+ ztgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_ztgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgevc", rblapack_ztgevc, -1);
+}
diff --git a/ext/ztgex2.c b/ext/ztgex2.c
new file mode 100644
index 0000000..3fc1805
--- /dev/null
+++ b/ext/ztgex2.c
@@ -0,0 +1,171 @@
+#include "rb_lapack.h"
+
+extern VOID ztgex2_(logical* wantq, logical* wantz, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* j1, integer* info);
+
+
+static VALUE
+rblapack_ztgex2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ldz;
+ integer ldz;
+ VALUE rblapack_j1;
+ integer j1;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+
+ 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, b, q, z = NumRu::Lapack.ztgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n* Purpose\n* =======\n*\n* ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n* in an upper triangular matrix pair (A, B) by an unitary equivalence\n* transformation.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 arrays, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 arrays, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n* the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n* the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11).\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. \n*\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n* Department of Computing Science, Umea University, S-901 87 Umea,\n* Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n* Numerical Algorithms, 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.ztgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_ldq = argv[5];
+ rblapack_z = argv[6];
+ rblapack_ldz = argv[7];
+ rblapack_j1 = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ldq = NUM2INT(rblapack_ldq);
+ ldz = NUM2INT(rblapack_ldz);
+ wantz = (rblapack_wantz == Qtrue);
+ j1 = NUM2INT(rblapack_j1);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != (wantq ? ldz : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantq ? ldz : 0);
+ if (NA_SHAPE1(rblapack_z) != (wantq ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantq ? n : 0);
+ 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_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_q) != (wantq ? ldq : 0))
+ rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", wantq ? ldq : 0);
+ if (NA_SHAPE1(rblapack_q) != (wantq ? n : 0))
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", wantq ? n : 0);
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = wantq ? ldq : 0;
+ shape[1] = wantq ? n : 0;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = wantq ? ldz : 0;
+ shape[1] = wantq ? n : 0;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ ztgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_ztgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgex2", rblapack_ztgex2, -1);
+}
diff --git a/ext/ztgexc.c b/ext/ztgexc.c
new file mode 100644
index 0000000..33c0436
--- /dev/null
+++ b/ext/ztgexc.c
@@ -0,0 +1,172 @@
+#include "rb_lapack.h"
+
+extern VOID ztgexc_(logical* wantq, logical* wantz, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* ifst, integer* ilst, integer* info);
+
+
+static VALUE
+rblapack_ztgexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_ldq;
+ integer ldq;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldz;
+
+ 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, b, q, z, ilst = NumRu::Lapack.ztgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* ZTGEXC reorders the generalized Schur decomposition of a complex\n* matrix pair (A,B), using an unitary equivalence transformation\n* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n* row index IFST is moved to row ILST.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the upper triangular matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the upper triangular matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the unitary matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the unitary matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* <0: if INFO = -i, the i-th argument had an illegal value.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\n*\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER HERE\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZTGEX2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a, b, q, z, ilst = NumRu::Lapack.ztgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 9 && argc != 9)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
+ rblapack_wantq = argv[0];
+ rblapack_wantz = argv[1];
+ rblapack_a = argv[2];
+ rblapack_b = argv[3];
+ rblapack_q = argv[4];
+ rblapack_ldq = argv[5];
+ rblapack_z = argv[6];
+ rblapack_ifst = argv[7];
+ rblapack_ilst = argv[8];
+ if (argc == 9) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ wantq = (rblapack_wantq == Qtrue);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (7th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_z) != ldz)
+ rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ ilst = NUM2INT(rblapack_ilst);
+ wantz = (rblapack_wantz == Qtrue);
+ ldq = NUM2INT(rblapack_ldq);
+ 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ ifst = NUM2INT(rblapack_ifst);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ ztgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, &info);
+
+ rblapack_info = INT2NUM(info);
+ rblapack_ilst = INT2NUM(ilst);
+ return rb_ary_new3(6, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ilst);
+}
+
+void
+init_lapack_ztgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgexc", rblapack_ztgexc, -1);
+}
diff --git a/ext/ztgsen.c b/ext/ztgsen.c
new file mode 100644
index 0000000..40fbe3f
--- /dev/null
+++ b/ext/ztgsen.c
@@ -0,0 +1,244 @@
+#include "rb_lapack.h"
+
+extern VOID ztgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* m, doublereal* pl, doublereal* pr, doublereal* dif, doublecomplex* work, integer* lwork, integer* iwork, integer* liwork, integer* info);
+
+
+static VALUE
+rblapack_ztgsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_wantq;
+ logical wantq;
+ VALUE rblapack_wantz;
+ logical wantz;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_z;
+ doublecomplex *z;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_liwork;
+ integer liwork;
+ VALUE rblapack_alpha;
+ doublecomplex *alpha;
+ VALUE rblapack_beta;
+ doublecomplex *beta;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_pl;
+ doublereal pl;
+ VALUE rblapack_pr;
+ doublereal pr;
+ VALUE rblapack_dif;
+ doublereal *dif;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_iwork;
+ integer *iwork;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ VALUE rblapack_z_out__;
+ doublecomplex *z_out__;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldq;
+ integer ldz;
+
+ 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 alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ztgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSEN reorders the generalized Schur decomposition of a complex\n* matrix pair (A, B) (in terms of an unitary equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the pair (A,B). The leading\n* columns of Q and Z form unitary bases of the corresponding left and\n* right eigenspaces (deflating subspaces). (A, B) must be in\n* generalized Schur canonical form, that is, A and B are both upper\n* triangular.\n*\n* ZTGSEN also computes the generalized eigenvalues\n*\n* w(j)= ALPHA(j) / BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, the routine computes estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) integer\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select an eigenvalue w(j), SELECT(j) must be set to\n* .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension(LDA,N)\n* On entry, the upper triangular matrix A, in generalized\n* Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, in generalized\n* Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The diagonal elements of A and B, respectively,\n* when the pair (A,B) has been reduced to generalized Schur\n* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized\n* eigenvalues.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right\n* eigenspaces, (deflating subspaces) 0 <= M <= N.\n*\n* PL (output) DOUBLE PRECISION\n* PR (output) DOUBLE PRECISION\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspace with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3 PL, PR are not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl, computed using reversed\n* communication with ZLACN2.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\n*\n* WORK (workspace/output) COMPLEX*16 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, 2 or 4, LWORK >= 2*M*(N-M)\n* If IJOB = 3 or 5, LWORK >= 4*M*(N-M)\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+2;\n* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n*\n\n* Further Details\n* ===============\n*\n* ZTGSEN first collects the selected eigenvalues by computing unitary\n* U and W that move them to the top left corner of (A, B). In other\n* words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the conjugate transpose of U. The first\n* n1 columns of U and W span the specified pair of left and right\n* eigenspaces (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see ZLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF\n* (IJOB = 2 will be used)). See ZTGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ztgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 8 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
+ rblapack_ijob = argv[0];
+ rblapack_wantq = argv[1];
+ rblapack_wantz = argv[2];
+ rblapack_select = argv[3];
+ rblapack_a = argv[4];
+ rblapack_b = argv[5];
+ rblapack_q = argv[6];
+ rblapack_z = argv[7];
+ if (argc == 10) {
+ rblapack_lwork = argv[8];
+ rblapack_liwork = argv[9];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ rblapack_liwork = Qnil;
+ }
+
+ ijob = NUM2INT(rblapack_ijob);
+ wantz = (rblapack_wantz == Qtrue);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (7th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ wantq = (rblapack_wantq == Qtrue);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th 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 a");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (4th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_select) != n)
+ rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_z))
+ rb_raise(rb_eArgError, "z (8th argument) must be NArray");
+ if (NA_RANK(rblapack_z) != 2)
+ rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
+ ldz = NA_SHAPE0(rblapack_z);
+ if (NA_SHAPE1(rblapack_z) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
+ if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
+ rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
+ z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
+ if (rblapack_liwork == Qnil)
+ liwork = (ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0;
+ else {
+ liwork = NUM2INT(rblapack_liwork);
+ }
+ if (rblapack_lwork == Qnil)
+ lwork = (ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = 2;
+ rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,liwork);
+ rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
+ }
+ iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ {
+ int shape[2];
+ shape[0] = ldz;
+ shape[1] = n;
+ rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, 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__;
+
+ ztgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alpha, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_pl = rb_float_new((double)pl);
+ rblapack_pr = rb_float_new((double)pr);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(13, rblapack_alpha, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
+}
+
+void
+init_lapack_ztgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgsen", rblapack_ztgsen, -1);
+}
diff --git a/ext/ztgsja.c b/ext/ztgsja.c
new file mode 100644
index 0000000..a341004
--- /dev/null
+++ b/ext/ztgsja.c
@@ -0,0 +1,227 @@
+#include "rb_lapack.h"
+
+extern VOID ztgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* tola, doublereal* tolb, doublereal* alpha, doublereal* beta, doublecomplex* u, integer* ldu, doublecomplex* v, integer* ldv, doublecomplex* q, integer* ldq, doublecomplex* work, integer* ncycle, integer* info);
+
+
+static VALUE
+rblapack_ztgsja(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu;
+ char jobu;
+ VALUE rblapack_jobv;
+ char jobv;
+ VALUE rblapack_jobq;
+ char jobq;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_tola;
+ doublereal tola;
+ VALUE rblapack_tolb;
+ doublereal tolb;
+ VALUE rblapack_u;
+ doublecomplex *u;
+ VALUE rblapack_v;
+ doublecomplex *v;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_alpha;
+ doublereal *alpha;
+ VALUE rblapack_beta;
+ doublereal *beta;
+ VALUE rblapack_ncycle;
+ integer ncycle;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+ VALUE rblapack_u_out__;
+ doublecomplex *u_out__;
+ VALUE rblapack_v_out__;
+ doublecomplex *v_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer ldu;
+ integer m;
+ integer ldv;
+ integer p;
+ integer ldq;
+
+ 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 alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ztgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSJA computes the generalized singular value decomposition (GSVD)\n* of two complex upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine ZGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are unitary matrices, Z' denotes the conjugate\n* transpose of Z, R is a nonsingular upper triangular matrix, and D1\n* and D2 are ``diagonal'' matrices, which are of the following\n* structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the unitary transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain a unitary matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* unitary matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain a unitary matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* unitary matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain a unitary matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by ZTGSJA.\n* See Further Details.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) COMPLEX*16 array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the unitary matrix returned by ZGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the unitary matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) COMPLEX*16 array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the unitary matrix returned by ZGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the unitary matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the unitary matrix returned by ZGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the unitary matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n* transpose of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ztgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [: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_jobu = argv[0];
+ rblapack_jobv = argv[1];
+ rblapack_jobq = argv[2];
+ rblapack_k = argv[3];
+ rblapack_l = argv[4];
+ rblapack_a = argv[5];
+ rblapack_b = argv[6];
+ rblapack_tola = argv[7];
+ rblapack_tolb = argv[8];
+ rblapack_u = argv[9];
+ rblapack_v = argv[10];
+ rblapack_q = argv[11];
+ if (argc == 12) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu = StringValueCStr(rblapack_jobu)[0];
+ jobq = StringValueCStr(rblapack_jobq)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_b))
+ rb_raise(rb_eArgError, "b (7th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (7th 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*);
+ tolb = NUM2DBL(rblapack_tolb);
+ if (!NA_IsNArray(rblapack_v))
+ rb_raise(rb_eArgError, "v (11th argument) must be NArray");
+ if (NA_RANK(rblapack_v) != 2)
+ rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
+ ldv = NA_SHAPE0(rblapack_v);
+ p = NA_SHAPE1(rblapack_v);
+ if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
+ rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
+ v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
+ jobv = StringValueCStr(rblapack_jobv)[0];
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th 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 1 of b");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_u))
+ rb_raise(rb_eArgError, "u (10th argument) must be NArray");
+ if (NA_RANK(rblapack_u) != 2)
+ rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
+ ldu = NA_SHAPE0(rblapack_u);
+ m = NA_SHAPE1(rblapack_u);
+ if (NA_TYPE(rblapack_u) != NA_DCOMPLEX)
+ rblapack_u = na_change_type(rblapack_u, NA_DCOMPLEX);
+ u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (12th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ tola = NUM2DBL(rblapack_tola);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
+ {
+ int 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__;
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = n;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+ {
+ int shape[2];
+ shape[0] = ldu;
+ shape[1] = m;
+ rblapack_u_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublecomplex*);
+ MEMCPY(u_out__, u, doublecomplex, NA_TOTAL(rblapack_u));
+ rblapack_u = rblapack_u_out__;
+ u = u_out__;
+ {
+ int shape[2];
+ shape[0] = ldv;
+ shape[1] = p;
+ rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
+ MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
+ rblapack_v = rblapack_v_out__;
+ v = v_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+
+ ztgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
+
+ free(work);
+ rblapack_ncycle = INT2NUM(ncycle);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
+}
+
+void
+init_lapack_ztgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgsja", rblapack_ztgsja, -1);
+}
diff --git a/ext/ztgsna.c b/ext/ztgsna.c
new file mode 100644
index 0000000..c884706
--- /dev/null
+++ b/ext/ztgsna.c
@@ -0,0 +1,164 @@
+#include "rb_lapack.h"
+
+extern VOID ztgsna_(char* job, char* howmny, logical* select, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublereal* s, doublereal* dif, integer* mm, integer* m, doublecomplex* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ztgsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_dif;
+ doublereal *dif;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ integer *iwork;
+
+ integer n;
+ integer lda;
+ integer ldb;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+
+ 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 s, dif, m, work, info = NumRu::Lapack.ztgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B).\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the corresponding j-th eigenvalue and/or eigenvector,\n* SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The upper triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A, B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) COMPLEX*16 array, dimension (LDVL,M)\n* IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by ZTGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; and\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX*16 array, dimension (LDVR,M)\n* IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VR, as returned by ZTGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1;\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array.\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If the eigenvalues cannot be reordered to compute DIF(j),\n* DIF(j) is set to 0; this can only occur when the true value\n* would be very small anyway.\n* For each eigenvalue/vector specified by SELECT, DIF stores\n* a Frobenius norm-based estimate of Difl.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected eigenvalue\n* one element is used. If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n* eigenvalue w = (a, b) is defined as\n*\n* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u. The pair\n* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n* matrix pair (A, B). If both a and b equal zero, then (A,B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows. Suppose\n*\n* (A, B) = ( a * ) ( b * ) 1\n* ( 0 A22 ),( 0 B22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(I) is\n*\n* Difl[(a, b), (A22, B22)] = sigma-min( Zl )\n*\n* where sigma-min(Zl) denotes the smallest singular value of\n*\n* Zl = [ kron(a, In-1) -kron(1, A22) ]\n* [ kron(b, In-1) -kron(1, B22) ].\n*\n* Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n* transpose of X. kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* We approximate the smallest singular value of Zl with an upper\n* bound. This is done by ZLATDF.\n*\n* An approximate error bound for a computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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.\n* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.ztgsna( job, howmny, select, a, b, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_vl = argv[5];
+ rblapack_vr = 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;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ 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);
+ if (NA_SHAPE1(rblapack_b) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ m = NA_SHAPE1(rblapack_vr);
+ if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ if (NA_SHAPE1(rblapack_vl) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
+ if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ mm = 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 select");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n+2));
+
+ ztgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
+
+ free(iwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
+}
+
+void
+init_lapack_ztgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgsna", rblapack_ztgsna, -1);
+}
diff --git a/ext/ztgsy2.c b/ext/ztgsy2.c
new file mode 100644
index 0000000..6cf9cb7
--- /dev/null
+++ b/ext/ztgsy2.c
@@ -0,0 +1,176 @@
+#include "rb_lapack.h"
+
+extern VOID ztgsy2_(char* trans, integer* ijob, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublecomplex* d, integer* ldd, doublecomplex* e, integer* lde, doublecomplex* f, integer* ldf, doublereal* scale, doublereal* rdsum, doublereal* rdscal, integer* info);
+
+
+static VALUE
+rblapack_ztgsy2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_f;
+ doublecomplex *f;
+ VALUE rblapack_rdsum;
+ doublereal rdsum;
+ VALUE rblapack_rdscal;
+ doublereal rdscal;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ VALUE rblapack_f_out__;
+ doublecomplex *f_out__;
+
+ 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, info, c, f, rdsum, rdscal = NumRu::Lapack.ztgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSY2 solves the generalized Sylvester equation\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F\n*\n* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n* (i.e., (A,D) and (B,E) in generalized Schur form).\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 solving equation (1) corresponds to solve\n* Zx = scale * b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n* is solved for, 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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* = sigma_min(Z) using reverse communicaton with ZLACON.\n*\n* ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n* ZTGSYL.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* =2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (DGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) COMPLEX*16 array, dimension (LDA, M)\n* On entry, A contains an upper triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) COMPLEX*16 array, dimension (LDB, N)\n* On entry, B contains an upper triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1, N).\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC, N)\n* On entry, C contains the right-hand-side of the first matrix\n* equation in (1).\n* On exit, if IJOB = 0, C has been overwritten by the solution\n* R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) COMPLEX*16 array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) COMPLEX*16 array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix E. LDE >= max(1, N).\n*\n* F (input/output) COMPLEX*16 array, dimension (LDF, N)\n* On entry, F contains the right-hand-side of the second matrix\n* equation in (1).\n* On exit, if IJOB = 0, F has been overwritten by the solution\n* L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0.\n* Normally, SCALE = 1.\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by ZTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when ZTGSY2 is called by\n* ZTGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n* ZTGSYL.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, input argument number i is illegal.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ztgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 10 && argc != 10)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", 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];
+ rblapack_rdsum = argv[8];
+ rblapack_rdscal = argv[9];
+ if (argc == 10) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ rdsum = NUM2DBL(rblapack_rdsum);
+ 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ rdscal = NUM2DBL(rblapack_rdscal);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_f = na_change_type(rblapack_f, NA_DCOMPLEX);
+ f = NA_PTR_TYPE(rblapack_f, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = n;
+ rblapack_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublecomplex*);
+ MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+
+ ztgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ rblapack_rdsum = rb_float_new((double)rdsum);
+ rblapack_rdscal = rb_float_new((double)rdscal);
+ return rb_ary_new3(6, rblapack_scale, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
+}
+
+void
+init_lapack_ztgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgsy2", rblapack_ztgsy2, -1);
+}
diff --git a/ext/ztgsyl.c b/ext/ztgsyl.c
new file mode 100644
index 0000000..3704e9e
--- /dev/null
+++ b/ext/ztgsyl.c
@@ -0,0 +1,190 @@
+#include "rb_lapack.h"
+
+extern VOID ztgsyl_(char* trans, integer* ijob, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublecomplex* d, integer* ldd, doublecomplex* e, integer* lde, doublecomplex* f, integer* ldf, doublereal* scale, doublereal* dif, doublecomplex* work, integer* lwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_ztgsyl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ijob;
+ integer ijob;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_d;
+ doublecomplex *d;
+ VALUE rblapack_e;
+ doublecomplex *e;
+ VALUE rblapack_f;
+ doublecomplex *f;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_dif;
+ doublereal dif;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ VALUE rblapack_f_out__;
+ doublecomplex *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.ztgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSYL( 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* ZTGSYL 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 complex entries. A, B, D and E are upper\n* triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n* is an output scaling factor chosen to avoid overflow.\n*\n* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n* is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Here Ix is the identity matrix of size x and X' is the conjugate\n* transpose of X. Kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n* is solved for, 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 = 'C') 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 ZLACON.\n*\n* If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of\n* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n* reciprocal of the smallest singular value of Z.\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* = 'C': solve the \"conjugate 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 is used).\n* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n* (ZGECON on sub-systems is used).\n* Not referenced if TRANS = 'C'.\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) COMPLEX*16 array, dimension (LDA, M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, M).\n*\n* B (input) COMPLEX*16 array, dimension (LDB, N)\n* The upper 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION\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 = 'C', DIF is not referenced.\n*\n* SCALE (output) DOUBLE PRECISION\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,\n* D and E have not been changed. If SCALE = 0, R and L will\n* hold the solutions to the homogenious system with C = F = 0.\n*\n* WORK (workspace/output) COMPLEX*16 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+2)\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 very close\n* 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 CCOPY by calls to CLASET.\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.ztgsyl( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
+ e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
+ d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_f = na_change_type(rblapack_f, NA_DCOMPLEX);
+ f = NA_PTR_TYPE(rblapack_f, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ {
+ int shape[2];
+ shape[0] = ldf;
+ shape[1] = n;
+ rblapack_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublecomplex*);
+ MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rblapack_f));
+ rblapack_f = rblapack_f_out__;
+ f = f_out__;
+ iwork = ALLOC_N(integer, (m+n+2));
+
+ ztgsyl_(&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_ztgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztgsyl", rblapack_ztgsyl, -1);
+}
diff --git a/ext/ztpcon.c b/ext/ztpcon.c
new file mode 100644
index 0000000..20f3373
--- /dev/null
+++ b/ext/ztpcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ztpcon_(char* norm, char* uplo, char* diag, integer* n, doublecomplex* ap, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztpcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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.ztpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTPCON 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) COMPLEX*16 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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.ztpcon( 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ ztpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_ztpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztpcon", rblapack_ztpcon, -1);
+}
diff --git a/ext/ztprfs.c b/ext/ztprfs.c
new file mode 100644
index 0000000..d165de1
--- /dev/null
+++ b/ext/ztprfs.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID ztprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztprfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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.ztprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTPRFS 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 ZTPTRS or some other\n* means before entering this routine. ZTPRFS 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)\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) COMPLEX*16 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* B (input) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.ztprfs( 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ ztprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
+}
+
+void
+init_lapack_ztprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztprfs", rblapack_ztprfs, -1);
+}
diff --git a/ext/ztptri.c b/ext/ztptri.c
new file mode 100644
index 0000000..8c1985c
--- /dev/null
+++ b/ext/ztptri.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ztptri_(char* uplo, char* diag, integer* n, doublecomplex* ap, integer* info);
+
+
+static VALUE
+rblapack_ztptri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_ap_out__;
+ doublecomplex *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.ztptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTRI computes the inverse of a complex 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) COMPLEX*16 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.ztptri( 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = n*(n+1)/2;
+ rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
+ MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
+ rblapack_ap = rblapack_ap_out__;
+ ap = ap_out__;
+
+ ztptri_(&uplo, &diag, &n, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_ap);
+}
+
+void
+init_lapack_ztptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztptri", rblapack_ztptri, -1);
+}
diff --git a/ext/ztptrs.c b/ext/ztptrs.c
new file mode 100644
index 0000000..5970bcf
--- /dev/null
+++ b/ext/ztptrs.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID ztptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ztptrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ztptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* AP (input) COMPLEX*16 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*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ztptrs( uplo, trans, diag, n, ap, b, [: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_n = argv[3];
+ rblapack_ap = argv[4];
+ rblapack_b = 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 (6th argument) must be NArray");
+ if (NA_RANK(rblapack_b) != 2)
+ rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
+ ldb = NA_SHAPE0(rblapack_b);
+ nrhs = 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*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ n = NUM2INT(rblapack_n);
+ 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) != (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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ztptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ztptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztptrs", rblapack_ztptrs, -1);
+}
diff --git a/ext/ztpttf.c b/ext/ztpttf.c
new file mode 100644
index 0000000..836ef17
--- /dev/null
+++ b/ext/ztpttf.c
@@ -0,0 +1,79 @@
+#include "rb_lapack.h"
+
+extern VOID ztpttf_(char* transr, char* uplo, integer* n, doublecomplex* ap, doublecomplex* arf, integer* info);
+
+
+static VALUE
+rblapack_ztpttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_n;
+ integer n;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_arf;
+ doublecomplex *arf;
+ VALUE rblapack_info;
+ integer info;
+
+
+ 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 arf, info = NumRu::Lapack.ztpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'C': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ztpttf( transr, uplo, 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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_n = argv[2];
+ rblapack_ap = argv[3];
+ if (argc == 4) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[0];
+ n = NUM2INT(rblapack_n);
+ 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);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);
+
+ ztpttf_(&transr, &uplo, &n, ap, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_ztpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztpttf", rblapack_ztpttf, -1);
+}
diff --git a/ext/ztpttr.c b/ext/ztpttr.c
new file mode 100644
index 0000000..85ec0df
--- /dev/null
+++ b/ext/ztpttr.c
@@ -0,0 +1,76 @@
+#include "rb_lapack.h"
+
+extern VOID ztpttr_(char* uplo, integer* n, doublecomplex* ap, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ztpttr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+
+ integer ldap;
+ 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 a, info = NumRu::Lapack.ztpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) COMPLEX*16 array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -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 a, info = NumRu::Lapack.ztpttr( uplo, ap, [: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_ap = argv[1];
+ if (argc == 2) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ n = ((int)sqrtf(ldap*8-1.0f)-1)/2;
+ lda = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = lda;
+ shape[1] = n;
+ rblapack_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+
+ ztpttr_(&uplo, &n, ap, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_a, rblapack_info);
+}
+
+void
+init_lapack_ztpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztpttr", rblapack_ztpttr, -1);
+}
diff --git a/ext/ztrcon.c b/ext/ztrcon.c
new file mode 100644
index 0000000..6e82c4c
--- /dev/null
+++ b/ext/ztrcon.c
@@ -0,0 +1,82 @@
+#include "rb_lapack.h"
+
+extern VOID ztrcon_(char* norm, char* uplo, char* diag, integer* n, doublecomplex* a, integer* lda, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztrcon(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_norm;
+ char norm;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_rcond;
+ doublereal rcond;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ 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 rcond, info = NumRu::Lapack.ztrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRCON estimates the reciprocal of the condition number of a\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.ztrcon( norm, uplo, diag, a, [: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_a = 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_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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ ztrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_rcond = rb_float_new((double)rcond);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_rcond, rblapack_info);
+}
+
+void
+init_lapack_ztrcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrcon", rblapack_ztrcon, -1);
+}
diff --git a/ext/ztrevc.c b/ext/ztrevc.c
new file mode 100644
index 0000000..c6758bf
--- /dev/null
+++ b/ext/ztrevc.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID ztrevc_(char* side, char* howmny, logical* select, integer* n, doublecomplex* t, integer* ldt, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* mm, integer* m, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztrevc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ doublecomplex *t_out__;
+ VALUE rblapack_vl_out__;
+ doublecomplex *vl_out__;
+ VALUE rblapack_vr_out__;
+ doublecomplex *vr_out__;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer mm;
+ integer ldvr;
+
+ 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 m, info, t, vl, vr = NumRu::Lapack.ztrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTREVC computes some or all of the right and/or left eigenvectors of\n* a complex upper triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of the vector y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the unitary factor that reduces a matrix A to\n* Schur form T, then Q*X and Q*Y are the matrices of right and left\n* eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed using the matrices supplied in\n* VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* The eigenvector corresponding to the j-th eigenvalue is\n* computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT,N)\n* The upper triangular matrix T. T is modified, but restored\n* on exit.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by ZHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by ZHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B'; LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one\n* column.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n m, info, t, vl, vr = NumRu::Lapack.ztrevc( side, howmny, select, t, vl, vr, [: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_side = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ mm = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != mm)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
+ MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldvl;
+ shape[1] = mm;
+ rblapack_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublecomplex*);
+ MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rblapack_vl));
+ rblapack_vl = rblapack_vl_out__;
+ vl = vl_out__;
+ {
+ int shape[2];
+ shape[0] = ldvr;
+ shape[1] = mm;
+ rblapack_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublecomplex*);
+ MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rblapack_vr));
+ rblapack_vr = rblapack_vr_out__;
+ vr = vr_out__;
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ ztrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_t, rblapack_vl, rblapack_vr);
+}
+
+void
+init_lapack_ztrevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrevc", rblapack_ztrevc, -1);
+}
diff --git a/ext/ztrexc.c b/ext/ztrexc.c
new file mode 100644
index 0000000..1677676
--- /dev/null
+++ b/ext/ztrexc.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID ztrexc_(char* compq, integer* n, doublecomplex* t, integer* ldt, doublecomplex* q, integer* ldq, integer* ifst, integer* ilst, integer* info);
+
+
+static VALUE
+rblapack_ztrexc(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_ifst;
+ integer ifst;
+ VALUE rblapack_ilst;
+ integer ilst;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ doublecomplex *t_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+
+ integer ldt;
+ integer n;
+ integer ldq;
+
+ 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, t, q = NumRu::Lapack.ztrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* ZTREXC reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n* is moved to row ILST.\n*\n* The Schur form T is reordered by a unitary similarity transformation\n* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n* postmultplying it with Z.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, the reordered upper triangular matrix.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input) INTEGER\n* ILST (input) INTEGER\n* Specify the reordering of the diagonal elements of T:\n* The element with row index IFST is moved to row ILST by a\n* sequence of transpositions between adjacent elements.\n* 1 <= IFST <= N; 1 <= ILST <= 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* .. Local Scalars ..\n LOGICAL WANTQ\n INTEGER K, M1, M2, M3\n DOUBLE PRECISION CS\n COMPLEX*16 SN, T11, T22, TEMP\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLARTG, ZROT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.ztrexc( compq, t, q, ifst, ilst, [: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_compq = argv[0];
+ rblapack_t = argv[1];
+ rblapack_q = argv[2];
+ rblapack_ifst = argv[3];
+ rblapack_ilst = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (3th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ n = NA_SHAPE1(rblapack_q);
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ ilst = NUM2INT(rblapack_ilst);
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (2th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
+ if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ ifst = NUM2INT(rblapack_ifst);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
+ MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+
+ ztrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_ztrexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrexc", rblapack_ztrexc, -1);
+}
diff --git a/ext/ztrrfs.c b/ext/ztrrfs.c
new file mode 100644
index 0000000..2db1052
--- /dev/null
+++ b/ext/ztrrfs.c
@@ -0,0 +1,123 @@
+#include "rb_lapack.h"
+
+extern VOID ztrrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztrrfs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_x;
+ doublecomplex *x;
+ VALUE rblapack_ferr;
+ doublereal *ferr;
+ VALUE rblapack_berr;
+ doublereal *berr;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer lda;
+ 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 = NumRu::Lapack.ztrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by ZTRTRS or some other\n* means before entering this routine. ZTRRFS 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)\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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.ztrrfs( uplo, trans, diag, a, 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_a = 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
+ x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
+ {
+ int shape[1];
+ shape[0] = nrhs;
+ rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
+ work = ALLOC_N(doublecomplex, (2*n));
+ rwork = ALLOC_N(doublereal, (n));
+
+ ztrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
+}
+
+void
+init_lapack_ztrrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrrfs", rblapack_ztrrfs, -1);
+}
diff --git a/ext/ztrsen.c b/ext/ztrsen.c
new file mode 100644
index 0000000..ee82998
--- /dev/null
+++ b/ext/ztrsen.c
@@ -0,0 +1,154 @@
+#include "rb_lapack.h"
+
+extern VOID ztrsen_(char* job, char* compq, logical* select, integer* n, doublecomplex* t, integer* ldt, doublecomplex* q, integer* ldq, doublecomplex* w, integer* m, doublereal* s, doublereal* sep, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ztrsen(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_compq;
+ char compq;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_w;
+ doublecomplex *w;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_s;
+ doublereal s;
+ VALUE rblapack_sep;
+ doublereal sep;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_t_out__;
+ doublecomplex *t_out__;
+ VALUE rblapack_q_out__;
+ doublecomplex *q_out__;
+
+ integer n;
+ integer ldt;
+ integer ldq;
+
+ 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 w, m, s, sep, work, info, t, q = NumRu::Lapack.ztrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRSEN reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n* the leading positions on the diagonal of the upper triangular matrix\n* T, and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, T is overwritten by the reordered matrix T, with the\n* selected eigenvalues as the leading diagonal elements.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix which reorders T; the leading M\n* columns of Q form an orthonormal basis for the specified\n* invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The reordered eigenvalues of T, in the same order as they\n* appear on the diagonal of T.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 <= M <= N.\n*\n* S (output) DOUBLE PRECISION\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If JOB = 'N', LWORK >= 1;\n* if JOB = 'E', LWORK = max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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* ZTRSEN first collects the selected eigenvalues by computing a unitary\n* transformation Z to move them to the top left corner of T. In other\n* words, the selected eigenvalues are the eigenvalues of T11 in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n* n1 columns of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the Schur factorization of a matrix\n* A = Q*T*Q', then the reordered Schur factorization of A is given by\n* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n* corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n w, m, s, sep, work, info, t, q = NumRu::Lapack.ztrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_job = argv[0];
+ rblapack_compq = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_q = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_q))
+ rb_raise(rb_eArgError, "q (5th argument) must be NArray");
+ if (NA_RANK(rblapack_q) != 2)
+ rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
+ ldq = NA_SHAPE0(rblapack_q);
+ if (NA_SHAPE1(rblapack_q) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
+ rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ compq = StringValueCStr(rblapack_compq)[0];
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = n;
+ rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldt;
+ shape[1] = n;
+ rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
+ MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
+ rblapack_t = rblapack_t_out__;
+ t = t_out__;
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
+ MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
+ rblapack_q = rblapack_q_out__;
+ q = q_out__;
+
+ ztrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, w, &m, &s, &sep, work, &lwork, &info);
+
+ rblapack_m = INT2NUM(m);
+ rblapack_s = rb_float_new((double)s);
+ rblapack_sep = rb_float_new((double)sep);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(8, rblapack_w, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
+}
+
+void
+init_lapack_ztrsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrsen", rblapack_ztrsen, -1);
+}
diff --git a/ext/ztrsna.c b/ext/ztrsna.c
new file mode 100644
index 0000000..a024df2
--- /dev/null
+++ b/ext/ztrsna.c
@@ -0,0 +1,137 @@
+#include "rb_lapack.h"
+
+extern VOID ztrsna_(char* job, char* howmny, logical* select, integer* n, doublecomplex* t, integer* ldt, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublereal* s, doublereal* sep, integer* mm, integer* m, doublecomplex* work, integer* ldwork, doublereal* rwork, integer* info);
+
+
+static VALUE
+rblapack_ztrsna(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_job;
+ char job;
+ VALUE rblapack_howmny;
+ char howmny;
+ VALUE rblapack_select;
+ logical *select;
+ VALUE rblapack_t;
+ doublecomplex *t;
+ VALUE rblapack_vl;
+ doublecomplex *vl;
+ VALUE rblapack_vr;
+ doublecomplex *vr;
+ VALUE rblapack_s;
+ doublereal *s;
+ VALUE rblapack_sep;
+ doublereal *sep;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+
+ integer n;
+ integer ldt;
+ integer ldvl;
+ integer ldvr;
+ integer mm;
+ integer ldwork;
+
+ 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 s, sep, m, info = NumRu::Lapack.ztrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a complex upper triangular\n* matrix T (or of any matrix Q*T*Q**H with Q unitary).\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) COMPLEX*16 array, dimension (LDT,N)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) COMPLEX*16 array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* ZHSEIN or ZTREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX*16 array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* ZHSEIN or ZTREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n* all correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n* If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.ztrsna( job, howmny, select, t, vl, vr, [: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_job = argv[0];
+ rblapack_howmny = argv[1];
+ rblapack_select = argv[2];
+ rblapack_t = argv[3];
+ rblapack_vl = argv[4];
+ rblapack_vr = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ job = StringValueCStr(rblapack_job)[0];
+ if (!NA_IsNArray(rblapack_select))
+ rb_raise(rb_eArgError, "select (3th argument) must be NArray");
+ if (NA_RANK(rblapack_select) != 1)
+ rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
+ n = NA_SHAPE0(rblapack_select);
+ if (NA_TYPE(rblapack_select) != NA_LINT)
+ rblapack_select = na_change_type(rblapack_select, NA_LINT);
+ select = NA_PTR_TYPE(rblapack_select, logical*);
+ if (!NA_IsNArray(rblapack_vl))
+ rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
+ if (NA_RANK(rblapack_vl) != 2)
+ rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
+ ldvl = NA_SHAPE0(rblapack_vl);
+ m = NA_SHAPE1(rblapack_vl);
+ if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
+ rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
+ vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
+ howmny = StringValueCStr(rblapack_howmny)[0];
+ if (!NA_IsNArray(rblapack_vr))
+ rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
+ if (NA_RANK(rblapack_vr) != 2)
+ rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
+ ldvr = NA_SHAPE0(rblapack_vr);
+ if (NA_SHAPE1(rblapack_vr) != m)
+ rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
+ if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
+ rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
+ vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
+ mm = m;
+ if (!NA_IsNArray(rblapack_t))
+ rb_raise(rb_eArgError, "t (4th argument) must be NArray");
+ if (NA_RANK(rblapack_t) != 2)
+ rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
+ ldt = NA_SHAPE0(rblapack_t);
+ if (NA_SHAPE1(rblapack_t) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
+ if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
+ rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
+ t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
+ ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ s = NA_PTR_TYPE(rblapack_s, doublereal*);
+ {
+ int shape[1];
+ shape[0] = mm;
+ rblapack_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ sep = NA_PTR_TYPE(rblapack_sep, doublereal*);
+ work = ALLOC_N(doublecomplex, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
+ rwork = ALLOC_N(doublereal, (lsame_(&job,"E") ? 0 : n));
+
+ ztrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, rwork, &info);
+
+ free(work);
+ free(rwork);
+ rblapack_m = INT2NUM(m);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
+}
+
+void
+init_lapack_ztrsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrsna", rblapack_ztrsna, -1);
+}
diff --git a/ext/ztrsyl.c b/ext/ztrsyl.c
new file mode 100644
index 0000000..22c2282
--- /dev/null
+++ b/ext/ztrsyl.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID ztrsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublereal* scale, integer* info);
+
+
+static VALUE
+rblapack_ztrsyl(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trana;
+ char trana;
+ VALUE rblapack_tranb;
+ char tranb;
+ VALUE rblapack_isgn;
+ integer isgn;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_scale;
+ doublereal scale;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ 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 scale, info, c = NumRu::Lapack.ztrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* ZTRSYL solves the complex Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**H, and A and B are both upper triangular. A is\n* M-by-M and B is N-by-N; the right hand side C and the solution X are\n* M-by-N; and scale is an output scale factor, set <= 1 to avoid\n* overflow in X.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'C': op(A) = A**H (Conjugate transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'C': op(B) = B**H (Conjugate transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The upper 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) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) DOUBLE PRECISION\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.ztrsyl( trana, tranb, isgn, a, b, c, [: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_trana = argv[0];
+ rblapack_tranb = argv[1];
+ rblapack_isgn = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ trana = StringValueCStr(rblapack_trana)[0];
+ isgn = NUM2INT(rblapack_isgn);
+ 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);
+ 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*);
+ tranb = StringValueCStr(rblapack_tranb)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ if (NA_SHAPE1(rblapack_c) != n)
+ rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ ztrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
+
+ rblapack_scale = rb_float_new((double)scale);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_ztrsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrsyl", rblapack_ztrsyl, -1);
+}
diff --git a/ext/ztrti2.c b/ext/ztrti2.c
new file mode 100644
index 0000000..a8eee22
--- /dev/null
+++ b/ext/ztrti2.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID ztrti2_(char* uplo, char* diag, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ztrti2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.ztrti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTI2 computes the inverse of a complex upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit 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 triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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.ztrti2( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ int 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__;
+
+ ztrti2_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ztrti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrti2", rblapack_ztrti2, -1);
+}
diff --git a/ext/ztrtri.c b/ext/ztrtri.c
new file mode 100644
index 0000000..e166f6f
--- /dev/null
+++ b/ext/ztrtri.c
@@ -0,0 +1,81 @@
+#include "rb_lapack.h"
+
+extern VOID ztrtri_(char* uplo, char* diag, integer* n, doublecomplex* a, integer* lda, integer* info);
+
+
+static VALUE
+rblapack_ztrtri(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_info;
+ integer info;
+ 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 info, a = NumRu::Lapack.ztrtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTRI computes the inverse of a complex upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ztrtri( uplo, diag, a, [: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_diag = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ uplo = StringValueCStr(rblapack_uplo)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ diag = StringValueCStr(rblapack_diag)[0];
+ {
+ int 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__;
+
+ ztrtri_(&uplo, &diag, &n, a, &lda, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ztrtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrtri", rblapack_ztrtri, -1);
+}
diff --git a/ext/ztrtrs.c b/ext/ztrtrs.c
new file mode 100644
index 0000000..43814dc
--- /dev/null
+++ b/ext/ztrtrs.c
@@ -0,0 +1,99 @@
+#include "rb_lapack.h"
+
+extern VOID ztrtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);
+
+
+static VALUE
+rblapack_ztrtrs(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_diag;
+ char diag;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_b;
+ doublecomplex *b;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_b_out__;
+ doublecomplex *b_out__;
+
+ integer lda;
+ integer n;
+ integer ldb;
+ integer nrhs;
+
+ 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, b = NumRu::Lapack.ztrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ztrtrs( uplo, trans, diag, a, b, [: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_trans = argv[1];
+ rblapack_diag = argv[2];
+ rblapack_a = argv[3];
+ rblapack_b = argv[4];
+ if (argc == 5) {
+ } 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_DCOMPLEX)
+ rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
+ b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldb;
+ shape[1] = nrhs;
+ rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
+ MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
+ rblapack_b = rblapack_b_out__;
+ b = b_out__;
+
+ ztrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_b);
+}
+
+void
+init_lapack_ztrtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrtrs", rblapack_ztrtrs, -1);
+}
diff --git a/ext/ztrttf.c b/ext/ztrttf.c
new file mode 100644
index 0000000..abca98d
--- /dev/null
+++ b/ext/ztrttf.c
@@ -0,0 +1,77 @@
+#include "rb_lapack.h"
+
+extern VOID ztrttf_(char* transr, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* arf, integer* info);
+
+
+static VALUE
+rblapack_ztrttf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_transr;
+ char transr;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_arf;
+ doublecomplex *arf;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 arf, info = NumRu::Lapack.ztrttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal mode is wanted;\n* = 'C': ARF in Conjugate Transpose mode is wanted;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension ( LDA, N ) \n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ztrttf( transr, uplo, a, [: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_transr = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_a = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ transr = StringValueCStr(rblapack_transr)[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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);
+
+ ztrttf_(&transr, &uplo, &n, a, &lda, arf, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_arf, rblapack_info);
+}
+
+void
+init_lapack_ztrttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrttf", rblapack_ztrttf, -1);
+}
diff --git a/ext/ztrttp.c b/ext/ztrttp.c
new file mode 100644
index 0000000..cdad41b
--- /dev/null
+++ b/ext/ztrttp.c
@@ -0,0 +1,73 @@
+#include "rb_lapack.h"
+
+extern VOID ztrttp_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* ap, integer* info);
+
+
+static VALUE
+rblapack_ztrttp(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_info;
+ integer info;
+
+ 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 ap, info = NumRu::Lapack.ztrttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 ap, info = NumRu::Lapack.ztrttp( 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = ( n*(n+1)/2 );
+ rblapack_ap = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+
+ ztrttp_(&uplo, &n, a, &lda, ap, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_ap, rblapack_info);
+}
+
+void
+init_lapack_ztrttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztrttp", rblapack_ztrttp, -1);
+}
diff --git a/ext/ztzrqf.c b/ext/ztzrqf.c
new file mode 100644
index 0000000..ff55e50
--- /dev/null
+++ b/ext/ztzrqf.c
@@ -0,0 +1,83 @@
+#include "rb_lapack.h"
+
+extern VOID ztzrqf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, integer* info);
+
+
+static VALUE
+rblapack_ztzrqf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.ztzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZTZRZF.\n*\n* ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), whose conjugate transpose is used to\n* introduce zeros into the (m - k + 1)th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.ztzrqf( a, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 1)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 1) {
+ } 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+
+ ztzrqf_(&m, &n, a, &lda, tau, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ztzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztzrqf", rblapack_ztzrqf, -1);
+}
diff --git a/ext/ztzrzf.c b/ext/ztzrzf.c
new file mode 100644
index 0000000..3b226d3
--- /dev/null
+++ b/ext/ztzrzf.c
@@ -0,0 +1,101 @@
+#include "rb_lapack.h"
+
+extern VOID ztzrzf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_ztzrzf(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.ztzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.ztzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 1 && argc != 2)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
+ rblapack_a = argv[0];
+ if (argc == 2) {
+ rblapack_lwork = argv[1];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = m;
+ rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ ztzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(4, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_ztzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "ztzrzf", rblapack_ztzrzf, -1);
+}
diff --git a/ext/zunbdb.c b/ext/zunbdb.c
new file mode 100644
index 0000000..53075db
--- /dev/null
+++ b/ext/zunbdb.c
@@ -0,0 +1,232 @@
+#include "rb_lapack.h"
+
+extern VOID zunbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, doublecomplex* x11, integer* ldx11, doublecomplex* x12, integer* ldx12, doublecomplex* x21, integer* ldx21, doublecomplex* x22, integer* ldx22, doublereal* theta, doublereal* phi, doublecomplex* taup1, doublecomplex* taup2, doublecomplex* tauq1, doublecomplex* tauq2, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunbdb(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_signs;
+ char signs;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x11;
+ doublecomplex *x11;
+ VALUE rblapack_x12;
+ doublecomplex *x12;
+ VALUE rblapack_x21;
+ doublecomplex *x21;
+ VALUE rblapack_x22;
+ doublecomplex *x22;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_theta;
+ doublereal *theta;
+ VALUE rblapack_phi;
+ doublereal *phi;
+ VALUE rblapack_taup1;
+ doublecomplex *taup1;
+ VALUE rblapack_taup2;
+ doublecomplex *taup2;
+ VALUE rblapack_tauq1;
+ doublecomplex *tauq1;
+ VALUE rblapack_tauq2;
+ doublecomplex *tauq2;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_x11_out__;
+ doublecomplex *x11_out__;
+ VALUE rblapack_x12_out__;
+ doublecomplex *x12_out__;
+ VALUE rblapack_x21_out__;
+ doublecomplex *x21_out__;
+ VALUE rblapack_x22_out__;
+ doublecomplex *x22_out__;
+ doublecomplex *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.zunbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNBDB( 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* ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n* partitioned unitary matrix X:\n*\n* [ B11 | B12 0 0 ]\n* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H\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 ZUNCSD\n* for details.)\n*\n* The unitary 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) COMPLEX*16 array, dimension (LDX11,Q)\n* On entry, the top-left block of the unitary 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) COMPLEX*16 array, dimension (LDX12,M-Q)\n* On entry, the top-right block of the unitary 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) COMPLEX*16 array, dimension (LDX21,Q)\n* On entry, the bottom-left block of the unitary 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) COMPLEX*16 array, dimension (LDX22,M-Q)\n* On entry, the bottom-right block of the unitary 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) COMPLEX*16 array, dimension (P)\n* The scalar factors of the elementary reflectors that define\n* P1.\n*\n* TAUP2 (output) COMPLEX*16 array, dimension (M-P)\n* The scalar factors of the elementary reflectors that define\n* P2.\n*\n* TAUQ1 (output) COMPLEX*16 array, dimension (Q)\n* The scalar factors of the elementary reflectors that define\n* Q1.\n*\n* TAUQ2 (output) COMPLEX*16 array, dimension (M-Q)\n* The scalar factors of the elementary reflectors that define\n* Q2.\n*\n* WORK (workspace) COMPLEX*16 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 ZUNCSD for details.\n*\n* P1, P2, Q1, and Q2 are represented as products of elementary\n* reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2\n* using ZUNGQR and ZUNGLQ.\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.zunbdb( 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_DCOMPLEX)
+ rblapack_x11 = na_change_type(rblapack_x11, NA_DCOMPLEX);
+ x11 = NA_PTR_TYPE(rblapack_x11, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x21 = na_change_type(rblapack_x21, NA_DCOMPLEX);
+ x21 = NA_PTR_TYPE(rblapack_x21, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x22 = na_change_type(rblapack_x22, NA_DCOMPLEX);
+ x22 = NA_PTR_TYPE(rblapack_x22, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_x12 = na_change_type(rblapack_x12, NA_DCOMPLEX);
+ x12 = NA_PTR_TYPE(rblapack_x12, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
+ {
+ int shape[1];
+ shape[0] = q-1;
+ rblapack_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_taup1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taup1 = NA_PTR_TYPE(rblapack_taup1, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_taup2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ taup2 = NA_PTR_TYPE(rblapack_taup2, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_tauq1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tauq1 = NA_PTR_TYPE(rblapack_tauq1, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_tauq2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ tauq2 = NA_PTR_TYPE(rblapack_tauq2, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldx11;
+ shape[1] = q;
+ rblapack_x11_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, doublecomplex*);
+ MEMCPY(x11_out__, x11, doublecomplex, NA_TOTAL(rblapack_x11));
+ rblapack_x11 = rblapack_x11_out__;
+ x11 = x11_out__;
+ {
+ int shape[2];
+ shape[0] = ldx12;
+ shape[1] = m-q;
+ rblapack_x12_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, doublecomplex*);
+ MEMCPY(x12_out__, x12, doublecomplex, NA_TOTAL(rblapack_x12));
+ rblapack_x12 = rblapack_x12_out__;
+ x12 = x12_out__;
+ {
+ int shape[2];
+ shape[0] = ldx21;
+ shape[1] = q;
+ rblapack_x21_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, doublecomplex*);
+ MEMCPY(x21_out__, x21, doublecomplex, NA_TOTAL(rblapack_x21));
+ rblapack_x21 = rblapack_x21_out__;
+ x21 = x21_out__;
+ {
+ int shape[2];
+ shape[0] = ldx22;
+ shape[1] = m-q;
+ rblapack_x22_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, doublecomplex*);
+ MEMCPY(x22_out__, x22, doublecomplex, NA_TOTAL(rblapack_x22));
+ rblapack_x22 = rblapack_x22_out__;
+ x22 = x22_out__;
+ work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
+
+ zunbdb_(&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_zunbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunbdb", rblapack_zunbdb, -1);
+}
diff --git a/ext/zuncsd.c b/ext/zuncsd.c
new file mode 100644
index 0000000..9f24b97
--- /dev/null
+++ b/ext/zuncsd.c
@@ -0,0 +1,204 @@
+#include "rb_lapack.h"
+
+extern VOID zuncsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, char* signs, integer* m, integer* p, integer* q, doublecomplex* x11, integer* ldx11, doublecomplex* x12, integer* ldx12, doublecomplex* x21, integer* ldx21, doublecomplex* x22, integer* ldx22, doublereal* theta, doublecomplex* u1, integer* ldu1, doublecomplex* u2, integer* ldu2, doublecomplex* v1t, integer* ldv1t, doublecomplex* v2t, integer* ldv2t, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* info);
+
+
+static VALUE
+rblapack_zuncsd(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_jobu1;
+ char jobu1;
+ VALUE rblapack_jobu2;
+ char jobu2;
+ VALUE rblapack_jobv1t;
+ char jobv1t;
+ VALUE rblapack_jobv2t;
+ char jobv2t;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_signs;
+ char signs;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_x11;
+ doublecomplex *x11;
+ VALUE rblapack_x12;
+ doublecomplex *x12;
+ VALUE rblapack_x21;
+ doublecomplex *x21;
+ VALUE rblapack_x22;
+ doublecomplex *x22;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_lrwork;
+ integer lrwork;
+ VALUE rblapack_theta;
+ doublereal *theta;
+ VALUE rblapack_u1;
+ doublecomplex *u1;
+ VALUE rblapack_u2;
+ doublecomplex *u2;
+ VALUE rblapack_v1t;
+ doublecomplex *v1t;
+ VALUE rblapack_v2t;
+ doublecomplex *v2t;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *work;
+ doublereal *rwork;
+ integer *iwork;
+
+ integer p;
+ integer q;
+ integer ldv2t;
+ integer ldv1t;
+ integer ldu1;
+ integer ldu2;
+ integer ldx11;
+ integer ldx12;
+ integer ldx21;
+ integer ldx22;
+
+ 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, u1, u2, v1t, v2t, info = NumRu::Lapack.zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNCSD computes the CS decomposition of an M-by-M partitioned\n* unitary matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) COMPLEX*16 array, dimension (LDX,M)\n* On entry, the unitary matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) DOUBLE PRECISION array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) COMPLEX*16 array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) COMPLEX*16 array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) COMPLEX*16 array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n* matrix V1**H.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) COMPLEX*16 array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n* matrix V2**H.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) COMPLEX*16 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.\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* RWORK (workspace) DOUBLE PRECISION array, dimension MAX(1,LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n* If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n*\n* If LRWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the RWORK array, returns\n* this value as the first entry of the work array, and no error\n* message related to LRWORK is issued by XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (M-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: ZBBCSD did not converge. See the description of RWORK\n* above for details.\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\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 13 && argc != 13)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
+ rblapack_jobu1 = argv[0];
+ rblapack_jobu2 = argv[1];
+ rblapack_jobv1t = argv[2];
+ rblapack_jobv2t = argv[3];
+ rblapack_trans = argv[4];
+ rblapack_signs = argv[5];
+ rblapack_m = argv[6];
+ rblapack_x11 = argv[7];
+ rblapack_x12 = argv[8];
+ rblapack_x21 = argv[9];
+ rblapack_x22 = argv[10];
+ rblapack_lwork = argv[11];
+ rblapack_lrwork = argv[12];
+ if (argc == 13) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ jobu1 = StringValueCStr(rblapack_jobu1)[0];
+ jobv1t = StringValueCStr(rblapack_jobv1t)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_x21))
+ rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
+ if (NA_RANK(rblapack_x21) != 2)
+ rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
+ p = NA_SHAPE0(rblapack_x21);
+ q = NA_SHAPE1(rblapack_x21);
+ if (NA_TYPE(rblapack_x21) != NA_DCOMPLEX)
+ rblapack_x21 = na_change_type(rblapack_x21, NA_DCOMPLEX);
+ x21 = NA_PTR_TYPE(rblapack_x21, doublecomplex*);
+ lwork = NUM2INT(rblapack_lwork);
+ jobu2 = StringValueCStr(rblapack_jobu2)[0];
+ signs = StringValueCStr(rblapack_signs)[0];
+ lrwork = NUM2INT(rblapack_lrwork);
+ jobv2t = StringValueCStr(rblapack_jobv2t)[0];
+ if (!NA_IsNArray(rblapack_x11))
+ rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
+ if (NA_RANK(rblapack_x11) != 2)
+ rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_x11) != p)
+ rb_raise(rb_eRuntimeError, "shape 0 of x11 must be the same as shape 0 of x21");
+ if (NA_SHAPE1(rblapack_x11) != q)
+ rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
+ if (NA_TYPE(rblapack_x11) != NA_DCOMPLEX)
+ rblapack_x11 = na_change_type(rblapack_x11, NA_DCOMPLEX);
+ x11 = NA_PTR_TYPE(rblapack_x11, doublecomplex*);
+ if (!NA_IsNArray(rblapack_x22))
+ rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
+ if (NA_RANK(rblapack_x22) != 2)
+ rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_x22) != p)
+ rb_raise(rb_eRuntimeError, "shape 0 of x22 must be the same as shape 0 of x21");
+ 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_DCOMPLEX)
+ rblapack_x22 = na_change_type(rblapack_x22, NA_DCOMPLEX);
+ x22 = NA_PTR_TYPE(rblapack_x22, doublecomplex*);
+ ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
+ if (!NA_IsNArray(rblapack_x12))
+ rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
+ if (NA_RANK(rblapack_x12) != 2)
+ rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
+ if (NA_SHAPE0(rblapack_x12) != p)
+ rb_raise(rb_eRuntimeError, "shape 0 of x12 must be the same as shape 0 of x21");
+ 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_DCOMPLEX)
+ rblapack_x12 = na_change_type(rblapack_x12, NA_DCOMPLEX);
+ x12 = NA_PTR_TYPE(rblapack_x12, doublecomplex*);
+ ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
+ ldx11 = p;
+ ldx21 = p;
+ ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
+ ldx12 = p;
+ ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
+ ldx22 = p;
+ {
+ int shape[1];
+ shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
+ rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
+ }
+ theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
+ {
+ int shape[1];
+ shape[0] = p;
+ rblapack_u1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ u1 = NA_PTR_TYPE(rblapack_u1, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = m-p;
+ rblapack_u2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ u2 = NA_PTR_TYPE(rblapack_u2, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = q;
+ rblapack_v1t = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ v1t = NA_PTR_TYPE(rblapack_v1t, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = m-q;
+ rblapack_v2t = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ v2t = NA_PTR_TYPE(rblapack_v2t, doublecomplex*);
+ work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
+ rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
+ iwork = ALLOC_N(integer, (m-q));
+
+ zuncsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, rwork, &lrwork, iwork, &info);
+
+ free(work);
+ free(rwork);
+ free(iwork);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
+}
+
+void
+init_lapack_zuncsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zuncsd", rblapack_zuncsd, -1);
+}
diff --git a/ext/zung2l.c b/ext/zung2l.c
new file mode 100644
index 0000000..89dd8bc
--- /dev/null
+++ b/ext/zung2l.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID zung2l_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zung2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.zung2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNG2L generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.zung2l( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zung2l_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zung2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zung2l", rblapack_zung2l, -1);
+}
diff --git a/ext/zung2r.c b/ext/zung2r.c
new file mode 100644
index 0000000..c543cc5
--- /dev/null
+++ b/ext/zung2r.c
@@ -0,0 +1,92 @@
+#include "rb_lapack.h"
+
+extern VOID zung2r_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zung2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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.zung2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNG2R generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.zung2r( m, a, 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_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 3) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (n));
+
+ zung2r_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zung2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zung2r", rblapack_zung2r, -1);
+}
diff --git a/ext/zungbr.c b/ext/zungbr.c
new file mode 100644
index 0000000..1f493b3
--- /dev/null
+++ b/ext/zungbr.c
@@ -0,0 +1,115 @@
+#include "rb_lapack.h"
+
+extern VOID zungbr_(char* vect, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zungbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 work, info, a = NumRu::Lapack.zungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGBR generates one of the complex unitary matrices Q or P**H\n* determined by ZGEBRD when reducing a complex matrix A to bidiagonal\n* form: A = Q * B * P**H. Q and P**H are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n* is of order N:\n* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m\n* rows of P**H, where n >= m >= k;\n* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**H is\n* required, as defined in the transformation applied by ZGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**H to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**H to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by ZGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by ZGEBRD.\n* K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by ZGEBRD.\n* On exit, the M-by-N matrix Q or P**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= M.\n*\n* TAU (input) COMPLEX*16 array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**H, as\n* returned by ZGEBRD in its array argument TAUQ or TAUP.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_vect = argv[0];
+ rblapack_m = argv[1];
+ rblapack_k = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ k = NUM2INT(rblapack_k);
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = MIN(m,n);
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zungbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zungbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zungbr", rblapack_zungbr, -1);
+}
diff --git a/ext/zunghr.c b/ext/zunghr.c
new file mode 100644
index 0000000..dbc7dc8
--- /dev/null
+++ b/ext/zunghr.c
@@ -0,0 +1,111 @@
+#include "rb_lapack.h"
+
+extern VOID zunghr_(integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunghr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 work, info, a = NumRu::Lapack.zunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGHR generates a complex unitary matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* ZGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of ZGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by ZGEHRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEHRD.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 4 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
+ rblapack_ilo = argv[0];
+ rblapack_ihi = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ if (argc == 5) {
+ rblapack_lwork = argv[4];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ ilo = NUM2INT(rblapack_ilo);
+ 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = ihi-ilo;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zunghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zunghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunghr", rblapack_zunghr, -1);
+}
diff --git a/ext/zungl2.c b/ext/zungl2.c
new file mode 100644
index 0000000..3330c68
--- /dev/null
+++ b/ext/zungl2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID zungl2_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zungl2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zungl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by ZGELQF in the first k rows of its array argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.zungl2( a, tau, [: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_tau = 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (m));
+
+ zungl2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zungl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zungl2", rblapack_zungl2, -1);
+}
diff --git a/ext/zunglq.c b/ext/zunglq.c
new file mode 100644
index 0000000..54d83c8
--- /dev/null
+++ b/ext/zunglq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zunglq_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunglq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.zunglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by ZGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zunglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zunglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zunglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunglq", rblapack_zunglq, -1);
+}
diff --git a/ext/zungql.c b/ext/zungql.c
new file mode 100644
index 0000000..2975a6f
--- /dev/null
+++ b/ext/zungql.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zungql_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zungql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.zungql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zungql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zungql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zungql", rblapack_zungql, -1);
+}
diff --git a/ext/zungqr.c b/ext/zungqr.c
new file mode 100644
index 0000000..e24f363
--- /dev/null
+++ b/ext/zungqr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zungqr_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zungqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.zungqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zungqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zungqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zungqr", rblapack_zungqr, -1);
+}
diff --git a/ext/zungr2.c b/ext/zungr2.c
new file mode 100644
index 0000000..29af8ab
--- /dev/null
+++ b/ext/zungr2.c
@@ -0,0 +1,90 @@
+#include "rb_lapack.h"
+
+extern VOID zungr2_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zungr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer n;
+ integer k;
+ integer m;
+
+ VALUE rblapack_options;
+ if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
+ argc--;
+ rblapack_options = argv[argc];
+ if (rb_hash_aref(rblapack_options, sHelp) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zungr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGERQF in the last k rows of its array argument\n* A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has 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.zungr2( a, tau, [: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_tau = 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);
+ n = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ m = lda;
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int 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__;
+ work = ALLOC_N(doublecomplex, (m));
+
+ zungr2_(&m, &n, &k, a, &lda, tau, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zungr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zungr2", rblapack_zungr2, -1);
+}
diff --git a/ext/zungrq.c b/ext/zungrq.c
new file mode 100644
index 0000000..945faf5
--- /dev/null
+++ b/ext/zungrq.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zungrq_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zungrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_a_out__;
+ doublecomplex *a_out__;
+
+ integer lda;
+ integer n;
+ integer k;
+
+ 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 work, info, a = NumRu::Lapack.zungrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_m = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ m = NUM2INT(rblapack_m);
+ 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);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = m;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zungrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zungrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zungrq", rblapack_zungrq, -1);
+}
diff --git a/ext/zungtr.c b/ext/zungtr.c
new file mode 100644
index 0000000..565b364
--- /dev/null
+++ b/ext/zungtr.c
@@ -0,0 +1,107 @@
+#include "rb_lapack.h"
+
+extern VOID zungtr_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zungtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ 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 work, info, a = NumRu::Lapack.zungtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* ZHETRD:\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 triangle of A contains elementary reflectors\n* from ZHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from ZHETRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by ZHETRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= N.\n*\n* TAU (input) COMPLEX*16 array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZHETRD.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= N-1.\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 3 && argc != 4)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
+ rblapack_uplo = argv[0];
+ rblapack_a = argv[1];
+ rblapack_tau = argv[2];
+ if (argc == 4) {
+ rblapack_lwork = argv[3];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ 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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = n-1;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ 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);
+ if (NA_SHAPE0(rblapack_tau) != (n-1))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int 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__;
+
+ zungtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
+}
+
+void
+init_lapack_zungtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zungtr", rblapack_zungtr, -1);
+}
diff --git a/ext/zunm2l.c b/ext/zunm2l.c
new file mode 100644
index 0000000..09892b3
--- /dev/null
+++ b/ext/zunm2l.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID zunm2l_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zunm2l(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer k;
+ 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.zunm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNM2L overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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.zunm2l( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zunm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunm2l", rblapack_zunm2l, -1);
+}
diff --git a/ext/zunm2r.c b/ext/zunm2r.c
new file mode 100644
index 0000000..4566c81
--- /dev/null
+++ b/ext/zunm2r.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID zunm2r_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zunm2r(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer k;
+ 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.zunm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNM2R overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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.zunm2r( side, trans, m, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zunm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunm2r", rblapack_zunm2r, -1);
+}
diff --git a/ext/zunmbr.c b/ext/zunmbr.c
new file mode 100644
index 0000000..377466c
--- /dev/null
+++ b/ext/zunmbr.c
@@ -0,0 +1,139 @@
+#include "rb_lapack.h"
+
+extern VOID zunmbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmbr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_vect;
+ char vect;
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_k;
+ integer k;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer ldc;
+ integer n;
+ integer nq;
+
+ 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 work, info, c = NumRu::Lapack.zunmbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'C': P**H * C C * P**H\n*\n* Here Q and P**H are the unitary matrices determined by ZGEBRD when\n* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n* and P**H are defined as products of elementary reflectors H(i) and\n* G(i) respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the unitary matrix Q or P**H that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**H;\n* = 'P': apply P or P**H.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**H, P or P**H from the Left;\n* = 'R': apply Q, Q**H, P or P**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'C': Conjugate transpose, apply Q**H or P**H.\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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by ZGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by ZGEBRD.\n* K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by ZGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) COMPLEX*16 array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by ZGEBRD in the array argument TAUQ or TAUP.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n* or P*C or P**H*C or C*P or C*P**H.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M);\n* if N = 0 or M = 0, LWORK >= 1.\n* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n* optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMLQ, ZUNMQR\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmbr( vect, side, trans, m, k, a, tau, c, [: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_vect = argv[0];
+ rblapack_side = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_m = argv[3];
+ rblapack_k = argv[4];
+ rblapack_a = argv[5];
+ rblapack_tau = argv[6];
+ rblapack_c = 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;
+ }
+
+ vect = StringValueCStr(rblapack_vect)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ k = NUM2INT(rblapack_k);
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (8th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (6th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
+ if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
+ rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmbr", rblapack_zunmbr, -1);
+}
diff --git a/ext/zunmhr.c b/ext/zunmhr.c
new file mode 100644
index 0000000..72e4588
--- /dev/null
+++ b/ext/zunmhr.c
@@ -0,0 +1,133 @@
+#include "rb_lapack.h"
+
+extern VOID zunmhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmhr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_ilo;
+ integer ilo;
+ VALUE rblapack_ihi;
+ integer ihi;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.zunmhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMHR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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* IHI-ILO elementary reflectors, as returned by ZGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q**H (Conjugate transpose)\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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of ZGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by ZGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX*16 array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEHRD.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMQR\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmhr( side, trans, ilo, ihi, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_ilo = argv[2];
+ rblapack_ihi = argv[3];
+ rblapack_a = argv[4];
+ rblapack_tau = argv[5];
+ rblapack_c = 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;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ ilo = NUM2INT(rblapack_ilo);
+ if (!NA_IsNArray(rblapack_a))
+ rb_raise(rb_eArgError, "a (5th argument) must be NArray");
+ if (NA_RANK(rblapack_a) != 2)
+ rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
+ lda = NA_SHAPE0(rblapack_a);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ 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_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ ihi = NUM2INT(rblapack_ihi);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmhr", rblapack_zunmhr, -1);
+}
diff --git a/ext/zunml2.c b/ext/zunml2.c
new file mode 100644
index 0000000..2f913bb
--- /dev/null
+++ b/ext/zunml2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID zunml2_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zunml2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.zunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNML2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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.zunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zunml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunml2", rblapack_zunml2, -1);
+}
diff --git a/ext/zunmlq.c b/ext/zunmlq.c
new file mode 100644
index 0000000..6e826fc
--- /dev/null
+++ b/ext/zunmlq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID zunmlq_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmlq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.zunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMLQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmlq", rblapack_zunmlq, -1);
+}
diff --git a/ext/zunmql.c b/ext/zunmql.c
new file mode 100644
index 0000000..fa774d4
--- /dev/null
+++ b/ext/zunmql.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID zunmql_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmql(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.zunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMQL overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmql", rblapack_zunmql, -1);
+}
diff --git a/ext/zunmqr.c b/ext/zunmqr.c
new file mode 100644
index 0000000..f915207
--- /dev/null
+++ b/ext/zunmqr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID zunmqr_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmqr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_m;
+ integer m;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.zunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMQR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_m = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ m = NUM2INT(rblapack_m);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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) != k)
+ rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmqr", rblapack_zunmqr, -1);
+}
diff --git a/ext/zunmr2.c b/ext/zunmr2.c
new file mode 100644
index 0000000..2ae71c2
--- /dev/null
+++ b/ext/zunmr2.c
@@ -0,0 +1,110 @@
+#include "rb_lapack.h"
+
+extern VOID zunmr2_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zunmr2(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.zunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMR2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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.zunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 5)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 5) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zunmr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmr2", rblapack_zunmr2, -1);
+}
diff --git a/ext/zunmr3.c b/ext/zunmr3.c
new file mode 100644
index 0000000..2f60a92
--- /dev/null
+++ b/ext/zunmr3.c
@@ -0,0 +1,114 @@
+#include "rb_lapack.h"
+
+extern VOID zunmr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zunmr3(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *work;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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.zunmr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMR3 overwrites the general complex m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZTZRZF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n COMPLEX*16 TAUI\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLARZ\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG, MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.zunmr3( side, trans, l, a, tau, c, [: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_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 6) {
+ } else if (rblapack_options != Qnil) {
+ } else {
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zunmr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
+
+ free(work);
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(2, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmr3", rblapack_zunmr3, -1);
+}
diff --git a/ext/zunmrq.c b/ext/zunmrq.c
new file mode 100644
index 0000000..cc7102a
--- /dev/null
+++ b/ext/zunmrq.c
@@ -0,0 +1,125 @@
+#include "rb_lapack.h"
+
+extern VOID zunmrq_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmrq(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.zunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMRQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 5 && argc != 6)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_a = argv[2];
+ rblapack_tau = argv[3];
+ rblapack_c = argv[4];
+ if (argc == 6) {
+ rblapack_lwork = argv[5];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[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_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmrq", rblapack_zunmrq, -1);
+}
diff --git a/ext/zunmrz.c b/ext/zunmrz.c
new file mode 100644
index 0000000..b318638
--- /dev/null
+++ b/ext/zunmrz.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID zunmrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmrz(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_l;
+ integer l;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer m;
+ integer k;
+ 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 work, info, c = NumRu::Lapack.zunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMRZ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZTZRZF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_trans = argv[1];
+ rblapack_l = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ l = NUM2INT(rblapack_l);
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
+ k = NA_SHAPE0(rblapack_tau);
+ if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmrz", rblapack_zunmrz, -1);
+}
diff --git a/ext/zunmtr.c b/ext/zunmtr.c
new file mode 100644
index 0000000..915d381
--- /dev/null
+++ b/ext/zunmtr.c
@@ -0,0 +1,129 @@
+#include "rb_lapack.h"
+
+extern VOID zunmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);
+
+
+static VALUE
+rblapack_zunmtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_side;
+ char side;
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_trans;
+ char trans;
+ VALUE rblapack_a;
+ doublecomplex *a;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_lwork;
+ integer lwork;
+ VALUE rblapack_work;
+ doublecomplex *work;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+
+ integer lda;
+ integer m;
+ 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 work, info, c = NumRu::Lapack.zunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 ZHETRD:\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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A contains elementary reflectors\n* from ZHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from ZHETRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by ZHETRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX*16 array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZHETRD.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMQL, ZUNMQR\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
+ return Qnil;
+ }
+ if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
+ printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
+ return Qnil;
+ }
+ } else
+ rblapack_options = Qnil;
+ if (argc != 6 && argc != 7)
+ rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
+ rblapack_side = argv[0];
+ rblapack_uplo = argv[1];
+ rblapack_trans = argv[2];
+ rblapack_a = argv[3];
+ rblapack_tau = argv[4];
+ rblapack_c = argv[5];
+ if (argc == 7) {
+ rblapack_lwork = argv[6];
+ } else if (rblapack_options != Qnil) {
+ rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
+ } else {
+ rblapack_lwork = Qnil;
+ }
+
+ side = StringValueCStr(rblapack_side)[0];
+ trans = StringValueCStr(rblapack_trans)[0];
+ if (!NA_IsNArray(rblapack_c))
+ rb_raise(rb_eArgError, "c (6th argument) must be NArray");
+ if (NA_RANK(rblapack_c) != 2)
+ rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
+ ldc = NA_SHAPE0(rblapack_c);
+ n = NA_SHAPE1(rblapack_c);
+ if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ uplo = StringValueCStr(rblapack_uplo)[0];
+ 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);
+ m = NA_SHAPE1(rblapack_a);
+ if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
+ rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
+ a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
+ if (rblapack_lwork == Qnil)
+ lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
+ else {
+ lwork = NUM2INT(rblapack_lwork);
+ }
+ if (!NA_IsNArray(rblapack_tau))
+ rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
+ if (NA_RANK(rblapack_tau) != 1)
+ rb_raise(rb_eArgError, "rank of tau (5th 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_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ {
+ int shape[1];
+ shape[0] = MAX(1,lwork);
+ rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
+ }
+ work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+
+ zunmtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
+
+ rblapack_info = INT2NUM(info);
+ return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
+}
+
+void
+init_lapack_zunmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zunmtr", rblapack_zunmtr, -1);
+}
diff --git a/ext/zupgtr.c b/ext/zupgtr.c
new file mode 100644
index 0000000..7bf6d07
--- /dev/null
+++ b/ext/zupgtr.c
@@ -0,0 +1,91 @@
+#include "rb_lapack.h"
+
+extern VOID zupgtr_(char* uplo, integer* n, doublecomplex* ap, doublecomplex* tau, doublecomplex* q, integer* ldq, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zupgtr(int argc, VALUE *argv, VALUE self){
+ VALUE rblapack_uplo;
+ char uplo;
+ VALUE rblapack_ap;
+ doublecomplex *ap;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_q;
+ doublecomplex *q;
+ VALUE rblapack_info;
+ integer info;
+ doublecomplex *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.zupgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUPGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors H(i) of order n, as returned by\n* ZHPTRD 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 ZHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to ZHPTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The vectors which define the elementary reflectors, as\n* returned by ZHPTRD.\n*\n* TAU (input) COMPLEX*16 array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZHPTRD.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,N)\n* The N-by-N unitary matrix Q.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 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.zupgtr( 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_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ ldq = MAX(1,n);
+ {
+ int shape[2];
+ shape[0] = ldq;
+ shape[1] = n;
+ rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
+ work = ALLOC_N(doublecomplex, (n-1));
+
+ zupgtr_(&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_zupgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zupgtr", rblapack_zupgtr, -1);
+}
diff --git a/ext/zupmtr.c b/ext/zupmtr.c
new file mode 100644
index 0000000..3c1c88c
--- /dev/null
+++ b/ext/zupmtr.c
@@ -0,0 +1,116 @@
+#include "rb_lapack.h"
+
+extern VOID zupmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublecomplex* ap, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);
+
+
+static VALUE
+rblapack_zupmtr(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;
+ doublecomplex *ap;
+ VALUE rblapack_tau;
+ doublecomplex *tau;
+ VALUE rblapack_c;
+ doublecomplex *c;
+ VALUE rblapack_info;
+ integer info;
+ VALUE rblapack_c_out__;
+ doublecomplex *c_out__;
+ doublecomplex *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.zupmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUPMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 ZHPTRD 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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular packed storage used in previous\n* call to ZHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to ZHPTRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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) COMPLEX*16 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 ZHPTRD. AP is modified by the routine but\n* restored on exit.\n*\n* TAU (input) COMPLEX*16 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 ZHPTRD.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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.zupmtr( 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_DCOMPLEX)
+ rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
+ c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
+ tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
+ 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_DCOMPLEX)
+ rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
+ ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
+ {
+ int shape[2];
+ shape[0] = ldc;
+ shape[1] = n;
+ rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
+ }
+ c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
+ MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
+ rblapack_c = rblapack_c_out__;
+ c = c_out__;
+ work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
+
+ zupmtr_(&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_zupmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
+ sHelp = sH;
+ sUsage = sU;
+ rblapack_ZERO = zero;
+
+ rb_define_module_function(mLapack, "zupmtr", rblapack_zupmtr, -1);
+}
diff --git a/extconf.rb b/extconf.rb
deleted file mode 100644
index 12548eb..0000000
--- a/extconf.rb
+++ /dev/null
@@ -1,129 +0,0 @@
-require "mkmf"
-
-
-def header_not_found(name)
- warn <<EOF
- #{name}.h was not found.
- If you have #{name}.h, try the following:
- % ruby extconf.rb --with-#{name}-include=path
-EOF
- exit 1
-end
-
-def library_not_found(lname, fname=nil)
- if fname
- warn <<EOF
- #{fname} was not found.
- If you have #{lname} library, try the following:
- % ruby extconf.rb --with-#{lname}-lib=path --with-#{lname}-name=name
- e.g.
- If you have /usr/local/#{lname}/#{fname},
- % ruby extconf.rb --with-#{lname}-lib=/usr/local/#{lname} --with-#{lname}-name=#{fname}
-EOF
- exit 1
- else
- warn <<EOF
- lib#{lname}.{a|so} was not found.
- If you have lib#{lname}.{a|so}, try the following:
- % ruby extconf.rb --with-#{lname}-lib=path
-EOF
- exit 1
- end
-end
-
-def try_func(func, libs, headers = nil, &b)
- headers = cpp_include(headers)
- try_link(<<"SRC", libs, &b) or try_link(<<"SRC", libs, &b)
-#{COMMON_HEADERS}
-#{headers}
-/*top*/
-int main() { return 0; }
-int MAIN__() { return main(); }
-int t() { void ((*volatile p)()); p = (void ((*)()))#{func}; return 0; }
-SRC
-#{headers}
-/*top*/
-int main() { return 0; }
-int MAIN__() { return main(); }
-int t() { #{func}(); return 0; }
-SRC
-end
-
-
-def find_library(lib, func=nil, name=nil)
- func = "main" if !func or func.empty?
- ldir = with_config(lib+'-lib')
- ldirs = ldir ? Array === ldir ? ldir : ldir.split(File::PATH_SEPARATOR) : []
- $LIBPATH = ldirs | $LIBPATH
- if /\.(a|so)$/ =~ name
- libs = $libs
- $LIBPATH.each{|path|
- f = File.join(path,name)
- if File.exist?(f)
- libs = f + " " + $libs
- break
- end
- }
- else
- name = LIBARG%lib
- libs = append_library($libs, lib)
- end
- paths = {}
- checking_for "#{func}() in #{name}" do
- libpath = $LIBPATH
- begin
- until r = try_func(func, libs) or paths.empty?
- $LIBPATH = libpath | [paths.shift]
- end
- if r
- $libs = libs
- libpath = nil
- end
- ensure
- $LIBPATH = libpath if libpath
- end
- r
- end
-end
-
-
-
-
-dir_config("lapack")
-unless find_library("lapack")
- library_not_found("lapack",nil)
-
- warn "LAPACK will be tried to find"
-
- name = with_config("blas-name","blas_LINUX.a")
- unless have_library(name)
- lib_path = with_config("blas-lib","/usr/local/lib")
- _libarg = LIBARG
- LIBARG.replace "#{lib_path}/%s"
- unless have_library(name)
- library_not_found("blas",name)
- end
- LIBARG.replace _libarg
- end
- name = with_config("lapack-name","lapack_LINUX.a")
- unless have_library(name)
- lib_path = with_config("lapack-lib","/usr/local/lib")
- _libarg = LIBARG
- LIBARG.replace "#{lib_path}/%s"
- unless have_library(name)
- library_not_found("lapack",name)
- end
- LIBARG.replace _libarg
- end
-end
-
-sitearchdir = Config::CONFIG["sitearchdir"]
-dir_config("narray", sitearchdir, sitearchdir)
-unless find_header("narray.h") && have_header("narray_config.h")
- header_not_found("narray")
-end
-unless find_library("narray", nil, "narray.so")
- library_not_found("narray","narray.so")
-end
-
-create_makefile("numru/lapack")
diff --git a/icmax1.c b/icmax1.c
deleted file mode 100644
index bdd4057..0000000
--- a/icmax1.c
+++ /dev/null
@@ -1,44 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer icmax1_(integer *n, complex *cx, integer *incx);
-
-static VALUE
-rb_icmax1(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- complex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb___out__;
- integer __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.icmax1( cx, incx)\n or\n NumRu::Lapack.icmax1 # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ICMAX1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* ICMAX1 finds the index of the element whose real part has maximum\n* absolute value.\n*\n* Based on ICAMAX from Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with CLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX >= 1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX\n REAL SMAX\n COMPLEX ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n* .. Statement Functions ..\n REAL CABS1\n* ..\n* .. Statement Function definitions ..\n*\n* NEXT LINE IS THE ONLY MODIFICATION.\n CABS1( ZDUM ) = ABS( ZDUM )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
-
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cx);
- if (NA_TYPE(rb_cx) != NA_SCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_SCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, complex*);
-
- __out__ = icmax1_(&n, cx, &incx);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_icmax1(VALUE mLapack){
- rb_define_module_function(mLapack, "icmax1", rb_icmax1, -1);
-}
diff --git a/ieeeck.c b/ieeeck.c
deleted file mode 100644
index c6b6381..0000000
--- a/ieeeck.c
+++ /dev/null
@@ -1,40 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ieeeck_(integer *ispec, real *zero, real *one);
-
-static VALUE
-rb_ieeeck(int argc, VALUE *argv, VALUE self){
- VALUE rb_ispec;
- integer ispec;
- VALUE rb_zero;
- real zero;
- VALUE rb_one;
- real one;
- VALUE rb___out__;
- integer __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ieeeck( ispec, zero, one)\n or\n NumRu::Lapack.ieeeck # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )\n\n* Purpose\n* =======\n*\n* IEEECK is called from the ILAENV to verify that Infinity and\n* possibly NaN arithmetic is safe (i.e. will not trap).\n*\n\n* Arguments\n* =========\n*\n* ISPEC (input) INTEGER\n* Specifies whether to test just for inifinity arithmetic\n* or whether to test for infinity and NaN arithmetic.\n* = 0: Verify infinity arithmetic only.\n* = 1: Verify infinity and NaN arithmetic.\n*\n* ZERO (input) REAL\n* Must contain the value 0.0\n* This is passed to prevent the compiler from optimizing\n* away this code.\n*\n* ONE (input) REAL\n* Must contain the value 1.0\n* This is passed to prevent the compiler from optimizing\n* away this code.\n*\n* RETURN VALUE: INTEGER\n* = 0: Arithmetic failed to produce the correct answers\n* = 1: Arithmetic produced the correct answers\n*\n* .. Local Scalars ..\n REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,\n $ NEGZRO, NEWZRO, POSINF\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ispec = argv[0];
- rb_zero = argv[1];
- rb_one = argv[2];
-
- one = (real)NUM2DBL(rb_one);
- ispec = NUM2INT(rb_ispec);
- zero = (real)NUM2DBL(rb_zero);
-
- __out__ = ieeeck_(&ispec, &zero, &one);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ieeeck(VALUE mLapack){
- rb_define_module_function(mLapack, "ieeeck", rb_ieeeck, -1);
-}
diff --git a/ilaclc.c b/ilaclc.c
deleted file mode 100644
index 4281e12..0000000
--- a/ilaclc.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilaclc_(integer *m, integer *n, complex *a, integer *lda);
-
-static VALUE
-rb_ilaclc(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaclc( m, a)\n or\n NumRu::Lapack.ilaclc # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILACLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILACLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
-
- __out__ = ilaclc_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilaclc(VALUE mLapack){
- rb_define_module_function(mLapack, "ilaclc", rb_ilaclc, -1);
-}
diff --git a/ilaclr.c b/ilaclr.c
deleted file mode 100644
index 30413b0..0000000
--- a/ilaclr.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilaclr_(integer *m, integer *n, complex *a, integer *lda);
-
-static VALUE
-rb_ilaclr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- complex *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaclr( m, a)\n or\n NumRu::Lapack.ilaclr # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILACLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILACLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- m = NUM2INT(rb_m);
-
- __out__ = ilaclr_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilaclr(VALUE mLapack){
- rb_define_module_function(mLapack, "ilaclr", rb_ilaclr, -1);
-}
diff --git a/iladiag.c b/iladiag.c
deleted file mode 100644
index 924e64c..0000000
--- a/iladiag.c
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer iladiag_(char *diag);
-
-static VALUE
-rb_iladiag(int argc, VALUE *argv, VALUE self){
- VALUE rb_diag;
- char diag;
- VALUE rb___out__;
- integer __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iladiag( diag)\n or\n NumRu::Lapack.iladiag # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILADIAG( DIAG )\n\n* Purpose\n* =======\n*\n* This subroutine translated from a character string specifying if a\n* matrix has unit diagonal or not to the relevant BLAST-specified\n* integer constant.\n*\n* ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a\n* character indicating a unit or non-unit diagonal. Otherwise ILADIAG\n* returns the constant value corresponding to DIAG.\n*\n\n* Arguments\n* =========\n* DIAG (input) CHARACTER*1\n* = 'N': A is non-unit triangular;\n* = 'U': A is unit triangular.\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_diag = argv[0];
-
- diag = StringValueCStr(rb_diag)[0];
-
- __out__ = iladiag_(&diag);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_iladiag(VALUE mLapack){
- rb_define_module_function(mLapack, "iladiag", rb_iladiag, -1);
-}
diff --git a/iladlc.c b/iladlc.c
deleted file mode 100644
index 2427e9f..0000000
--- a/iladlc.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda);
-
-static VALUE
-rb_iladlc(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iladlc( m, a)\n or\n NumRu::Lapack.iladlc # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILADLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILADLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
-
- __out__ = iladlc_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_iladlc(VALUE mLapack){
- rb_define_module_function(mLapack, "iladlc", rb_iladlc, -1);
-}
diff --git a/iladlr.c b/iladlr.c
deleted file mode 100644
index 2c4530f..0000000
--- a/iladlr.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda);
-
-static VALUE
-rb_iladlr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iladlr( m, a)\n or\n NumRu::Lapack.iladlr # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILADLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILADLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
-
- __out__ = iladlr_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_iladlr(VALUE mLapack){
- rb_define_module_function(mLapack, "iladlr", rb_iladlr, -1);
-}
diff --git a/ilaenv.c b/ilaenv.c
deleted file mode 100644
index 089a1bd..0000000
--- a/ilaenv.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilaenv_(integer *ispec, char *name, char *opts, integer *n1, integer *n2, integer *n3, integer *n4);
-
-static VALUE
-rb_ilaenv(int argc, VALUE *argv, VALUE self){
- VALUE rb_ispec;
- integer ispec;
- VALUE rb_name;
- char *name;
- VALUE rb_opts;
- char *opts;
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_n3;
- integer n3;
- VALUE rb_n4;
- integer n4;
- VALUE rb___out__;
- integer __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaenv( ispec, name, opts, n1, n2, n3, n4)\n or\n NumRu::Lapack.ilaenv # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )\n\n* Purpose\n* =======\n*\n* ILAENV is called from the LAPACK routines to choose problem-dependent\n* parameters for the local environment. See ISPEC for a description of\n* the parameters.\n*\n* ILAENV returns an INTEGER\n* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC\n* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.\n*\n* This version provides a set of parameters which should give good,\n* but not optimal, performance on many of the currently available\n* computers. Users are encouraged to modify this subroutine to set\n* the tuning parameters for their particular machine using the option\n* and problem size information in the arguments.\n*\n* This routine will not function correctly if it is converted to all\n* lower case. Converting it to all upper case is allowed.\n*\n\n* Arguments\n* =========\n*\n* ISPEC (input) INTEGER\n* Specifies the parameter to be returned as the value of\n* ILAENV.\n* = 1: the optimal blocksize; if this value is 1, an unblocked\n* algorithm will give the best performance.\n* = 2: the minimum block size for which the block routine\n* should be used; if the usable block size is less than\n* this value, an unblocked routine should be used.\n* = 3: the crossover point (in a block routine, for N less\n* than this value, an unblocked routine should be used)\n* = 4: the number of shifts, used in the nonsymmetric\n* eigenvalue routines (DEPRECATED)\n* = 5: the minimum column dimension for blocking to be used;\n* rectangular blocks must have dimension at least k by m,\n* where k is given by ILAENV(2,...) and m by ILAENV(5,...)\n* = 6: the crossover point for the SVD (when reducing an m by n\n* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds\n* this value, a QR factorization is used first to reduce\n* the matrix to a triangular form.)\n* = 7: the number of processors\n* = 8: the crossover point for the multishift QR method\n* for nonsymmetric eigenvalue problems (DEPRECATED)\n* = 9: maximum size of the subproblems at the bottom of the\n* computation tree in the divide-and-conquer algorithm\n* (used by xGELSD and xGESDD)\n* =10: ieee NaN arithmetic can be trusted not to trap\n* =11: infinity arithmetic can be trusted not to trap\n* 12 <= ISPEC <= 16:\n* xHSEQR or one of its subroutines,\n* see IPARMQ for detailed explanation\n*\n* NAME (input) CHARACTER*(*)\n* The name of the calling subroutine, in either upper case or\n* lower case.\n*\n* OPTS (input) CHARACTER*(*)\n* The character options to the subroutine NAME, concatenated\n* into a single character string. For example, UPLO = 'U',\n* TRANS = 'T', and DIAG = 'N' for a triangular routine would\n* be specified as OPTS = 'UTN'.\n*\n* N1 (input) INTEGER\n* N2 (input) INTEGER\n* N3 (input) INTEGER\n* N4 (input) INTEGER\n* Problem dimensions for the subroutine NAME; these may not all\n* be required.\n*\n\n* Further Details\n* ===============\n*\n* The following conventions have been used when calling ILAENV from the\n* LAPACK routines:\n* 1) OPTS is a concatenation of all of the character options to\n* subroutine NAME, in the same order that they appear in the\n* argument list for NAME, even if they are not used in determining\n* the value of the parameter specified by ISPEC.\n* 2) The problem dimensions N1, N2, N3, N4 are specified in the order\n* that they appear in the argument list for NAME. N1 is used\n* first, N2 second, and so on, and unused problem dimensions are\n* passed a value of -1.\n* 3) The parameter value returned by ILAENV is checked for validity in\n* the calling subroutine. For example, ILAENV is used to retrieve\n* the optimal blocksize for STRTRI as follows:\n*\n* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )\n* IF( NB.LE.1 ) NB = MAX( 1, N )\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IC, IZ, NB, NBMIN, NX\n LOGICAL CNAME, SNAME\n CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC CHAR, ICHAR, INT, MIN, REAL\n* ..\n* .. External Functions ..\n INTEGER IEEECK, IPARMQ\n EXTERNAL IEEECK, IPARMQ\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_ispec = argv[0];
- rb_name = argv[1];
- rb_opts = argv[2];
- rb_n1 = argv[3];
- rb_n2 = argv[4];
- rb_n3 = argv[5];
- rb_n4 = argv[6];
-
- name = StringValueCStr(rb_name);
- opts = StringValueCStr(rb_opts);
- n1 = NUM2INT(rb_n1);
- n2 = NUM2INT(rb_n2);
- n3 = NUM2INT(rb_n3);
- n4 = NUM2INT(rb_n4);
- ispec = NUM2INT(rb_ispec);
-
- __out__ = ilaenv_(&ispec, name, opts, &n1, &n2, &n3, &n4);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilaenv(VALUE mLapack){
- rb_define_module_function(mLapack, "ilaenv", rb_ilaenv, -1);
-}
diff --git a/ilaprec.c b/ilaprec.c
deleted file mode 100644
index 98f0122..0000000
--- a/ilaprec.c
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilaprec_(char *prec);
-
-static VALUE
-rb_ilaprec(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec;
- char prec;
- VALUE rb___out__;
- integer __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaprec( prec)\n or\n NumRu::Lapack.ilaprec # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAPREC( PREC )\n\n* Purpose\n* =======\n*\n* This subroutine translated from a character string specifying an\n* intermediate precision to the relevant BLAST-specified integer\n* constant.\n*\n* ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a\n* character indicating a supported intermediate precision. Otherwise\n* ILAPREC returns the constant value corresponding to PREC.\n*\n\n* Arguments\n* =========\n* PREC (input) CHARACTER\n* Specifies the form of the system of equations:\n* = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_prec = argv[0];
-
- prec = StringValueCStr(rb_prec)[0];
-
- __out__ = ilaprec_(&prec);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilaprec(VALUE mLapack){
- rb_define_module_function(mLapack, "ilaprec", rb_ilaprec, -1);
-}
diff --git a/ilaslc.c b/ilaslc.c
deleted file mode 100644
index 21f4cce..0000000
--- a/ilaslc.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilaslc_(integer *m, integer *n, real *a, integer *lda);
-
-static VALUE
-rb_ilaslc(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaslc( m, a)\n or\n NumRu::Lapack.ilaslc # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILASLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILASLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
-
- __out__ = ilaslc_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilaslc(VALUE mLapack){
- rb_define_module_function(mLapack, "ilaslc", rb_ilaslc, -1);
-}
diff --git a/ilaslr.c b/ilaslr.c
deleted file mode 100644
index c4e8fb8..0000000
--- a/ilaslr.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilaslr_(integer *m, integer *n, real *a, integer *lda);
-
-static VALUE
-rb_ilaslr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilaslr( m, a)\n or\n NumRu::Lapack.ilaslr # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILASLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILASLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
-
- __out__ = ilaslr_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilaslr(VALUE mLapack){
- rb_define_module_function(mLapack, "ilaslr", rb_ilaslr, -1);
-}
diff --git a/ilatrans.c b/ilatrans.c
deleted file mode 100644
index dde1399..0000000
--- a/ilatrans.c
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilatrans_(char *trans);
-
-static VALUE
-rb_ilatrans(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb___out__;
- integer __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilatrans( trans)\n or\n NumRu::Lapack.ilatrans # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILATRANS( TRANS )\n\n* Purpose\n* =======\n*\n* This subroutine translates from a character string specifying a\n* transposition operation to the relevant BLAST-specified integer\n* constant.\n*\n* ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not\n* a character indicating a transposition operator. Otherwise ILATRANS\n* returns the constant value corresponding to TRANS.\n*\n\n* Arguments\n* =========\n* TRANS (input) CHARACTER*1\n* Specifies the form of the system of equations:\n* = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_trans = argv[0];
-
- trans = StringValueCStr(rb_trans)[0];
-
- __out__ = ilatrans_(&trans);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilatrans(VALUE mLapack){
- rb_define_module_function(mLapack, "ilatrans", rb_ilatrans, -1);
-}
diff --git a/ilauplo.c b/ilauplo.c
deleted file mode 100644
index 535b67f..0000000
--- a/ilauplo.c
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilauplo_(char *uplo);
-
-static VALUE
-rb_ilauplo(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb___out__;
- integer __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilauplo( uplo)\n or\n NumRu::Lapack.ilauplo # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAUPLO( UPLO )\n\n* Purpose\n* =======\n*\n* This subroutine translated from a character string specifying a\n* upper- or lower-triangular matrix to the relevant BLAST-specified\n* integer constant.\n*\n* ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not\n* a character indicating an upper- or lower-triangular matrix.\n* Otherwise ILAUPLO returns the constant value corresponding to UPLO.\n*\n\n* Arguments\n* =========\n* UPLO (input) CHARACTER\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_uplo = argv[0];
-
- uplo = StringValueCStr(rb_uplo)[0];
-
- __out__ = ilauplo_(&uplo);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilauplo(VALUE mLapack){
- rb_define_module_function(mLapack, "ilauplo", rb_ilauplo, -1);
-}
diff --git a/ilaver.c b/ilaver.c
deleted file mode 100644
index 8a0e30d..0000000
--- a/ilaver.c
+++ /dev/null
@@ -1,34 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ilaver_(integer *vers_major, integer *vers_minor, integer *vers_patch);
-
-static VALUE
-rb_ilaver(int argc, VALUE *argv, VALUE self){
- VALUE rb_vers_major;
- integer vers_major;
- VALUE rb_vers_minor;
- integer vers_minor;
- VALUE rb_vers_patch;
- integer vers_patch;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n vers_major, vers_minor, vers_patch = NumRu::Lapack.ilaver( )\n or\n NumRu::Lapack.ilaver # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )\n\n* Purpose\n* =======\n*\n* This subroutine return the Lapack version.\n*\n\n* Arguments\n* =========\n* VERS_MAJOR (output) INTEGER\n* return the lapack major version\n* VERS_MINOR (output) INTEGER\n* return the lapack minor version from the major version\n* VERS_PATCH (output) INTEGER\n* return the lapack patch version from the minor version\n\n* =====================================================================\n*\n INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH\n* =====================================================================\n VERS_MAJOR = 3\n VERS_MINOR = 3\n VERS_PATCH = 0\n* =====================================================================\n*\n RETURN\n END\n\n");
- return Qnil;
- }
- if (argc != 0)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 0)", argc);
-
-
- ilaver_(&vers_major, &vers_minor, &vers_patch);
-
- rb_vers_major = INT2NUM(vers_major);
- rb_vers_minor = INT2NUM(vers_minor);
- rb_vers_patch = INT2NUM(vers_patch);
- return rb_ary_new3(3, rb_vers_major, rb_vers_minor, rb_vers_patch);
-}
-
-void
-init_lapack_ilaver(VALUE mLapack){
- rb_define_module_function(mLapack, "ilaver", rb_ilaver, -1);
-}
diff --git a/ilazlc.c b/ilazlc.c
deleted file mode 100644
index 633ed07..0000000
--- a/ilazlc.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda);
-
-static VALUE
-rb_ilazlc(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilazlc( m, a)\n or\n NumRu::Lapack.ilazlc # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAZLC( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILAZLC scans A for its last non-zero column.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
-
- __out__ = ilazlc_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilazlc(VALUE mLapack){
- rb_define_module_function(mLapack, "ilazlc", rb_ilazlc, -1);
-}
diff --git a/ilazlr.c b/ilazlr.c
deleted file mode 100644
index 20842de..0000000
--- a/ilazlr.c
+++ /dev/null
@@ -1,46 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda);
-
-static VALUE
-rb_ilazlr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- integer __out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.ilazlr( m, a)\n or\n NumRu::Lapack.ilazlr # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION ILAZLR( M, N, A, LDA )\n\n* Purpose\n* =======\n*\n* ILAZLR scans A for its last non-zero row.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
-
- __out__ = ilazlr_(&m, &n, a, &lda);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_ilazlr(VALUE mLapack){
- rb_define_module_function(mLapack, "ilazlr", rb_ilazlr, -1);
-}
diff --git a/iparmq.c b/iparmq.c
deleted file mode 100644
index 85d7e02..0000000
--- a/iparmq.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer iparmq_(integer *ispec, char *name, char *opts, integer *n, integer *ilo, integer *ihi, integer *lwork);
-
-static VALUE
-rb_iparmq(int argc, VALUE *argv, VALUE self){
- VALUE rb_ispec;
- integer ispec;
- VALUE rb_name;
- char name;
- VALUE rb_opts;
- char opts;
- VALUE rb_n;
- integer n;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb___out__;
- integer __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.iparmq( ispec, name, opts, n, ilo, ihi, lwork)\n or\n NumRu::Lapack.iparmq # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )\n\n* Purpose\n* =======\n*\n* This program sets problem and machine dependent parameters\n* useful for xHSEQR and its subroutines. It is called whenever \n* ILAENV is called with 12 <= ISPEC <= 16\n*\n\n* Arguments\n* =========\n*\n* ISPEC (input) integer scalar\n* ISPEC specifies which tunable parameter IPARMQ should\n* return.\n*\n* ISPEC=12: (INMIN) Matrices of order nmin or less\n* are sent directly to xLAHQR, the implicit\n* double shift QR algorithm. NMIN must be\n* at least 11.\n*\n* ISPEC=13: (INWIN) Size of the deflation window.\n* This is best set greater than or equal to\n* the number of simultaneous shifts NS.\n* Larger matrices benefit from larger deflation\n* windows.\n*\n* ISPEC=14: (INIBL) Determines when to stop nibbling and\n* invest in an (expensive) multi-shift QR sweep.\n* If the aggressive early deflation subroutine\n* finds LD converged eigenvalues from an order\n* NW deflation window and LD.GT.(NW*NIBBLE)/100,\n* then the next QR sweep is skipped and early\n* deflation is applied immediately to the\n* remaining active diagonal block. Setting\n* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a\n* multi-shift QR sweep whenever early deflation\n* finds a converged eigenvalue. Setting\n* IPARMQ(ISPEC=14) greater than or equal to 100\n* prevents TTQRE from skipping a multi-shift\n* QR sweep.\n*\n* ISPEC=15: (NSHFTS) The number of simultaneous shifts in\n* a multi-shift QR iteration.\n*\n* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the\n* following meanings.\n* 0: During the multi-shift QR sweep,\n* xLAQR5 does not accumulate reflections and\n* does not use matrix-matrix multiply to\n* update the far-from-diagonal matrix\n* entries.\n* 1: During the multi-shift QR sweep,\n* xLAQR5 and/or xLAQRaccumulates reflections and uses\n* matrix-matrix multiply to update the\n* far-from-diagonal matrix entries.\n* 2: During the multi-shift QR sweep.\n* xLAQR5 accumulates reflections and takes\n* advantage of 2-by-2 block structure during\n* matrix-matrix multiplies.\n* (If xTRMM is slower than xGEMM, then\n* IPARMQ(ISPEC=16)=1 may be more efficient than\n* IPARMQ(ISPEC=16)=2 despite the greater level of\n* arithmetic work implied by the latter choice.)\n*\n* NAME (input) character string\n* Name of the calling subroutine\n*\n* OPTS (input) character string\n* This is a concatenation of the string arguments to\n* TTQRE.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N.\n*\n* LWORK (input) integer scalar\n* The amount of workspace available.\n*\n\n* Further Details\n* ===============\n*\n* Little is known about how best to choose these parameters.\n* It is possible to use different values of the parameters\n* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.\n*\n* It is probably best to choose different parameters for\n* different matrices and different parameters at different\n* times during the iteration, but this has not been\n* implemented --- yet.\n*\n*\n* The best choices of most of the parameters depend\n* in an ill-understood way on the relative execution\n* rate of xLAQR3 and xLAQR5 and on the nature of each\n* particular eigenvalue problem. Experiment may be the\n* only practical way to determine which choices are most\n* effective.\n*\n* Following is a list of default values supplied by IPARMQ.\n* These defaults may be adjusted in order to attain better\n* performance in any particular computational environment.\n*\n* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* IPARMQ(ISPEC=13) Recommended deflation window size.\n* This depends on ILO, IHI and NS, the\n* number of simultaneous shifts returned\n* by IPARMQ(ISPEC=15). The default for\n* (IHI-ILO+1).LE.500 is NS. The default\n* for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.\n*\n* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.\n* a multi-shift QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 0 30 NS = 2+\n* 30 60 NS = 4+\n* 60 150 NS = 10\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default matrices of this order are\n* passed to the implicit double shift routine\n* xLAHQR. See IPARMQ(ISPEC=12) above. These\n* values of NS are used only in case of a rare\n* xLAHQR failure.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function increasing from 10 to 64.\n*\n* IPARMQ(ISPEC=16) Select structured matrix multiply.\n* (See ISPEC=16 above for details.)\n* Default: 3.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_ispec = argv[0];
- rb_name = argv[1];
- rb_opts = argv[2];
- rb_n = argv[3];
- rb_ilo = argv[4];
- rb_ihi = argv[5];
- rb_lwork = argv[6];
-
- name = StringValueCStr(rb_name)[0];
- ilo = NUM2INT(rb_ilo);
- opts = StringValueCStr(rb_opts)[0];
- n = NUM2INT(rb_n);
- lwork = NUM2INT(rb_lwork);
- ispec = NUM2INT(rb_ispec);
- ihi = NUM2INT(rb_ihi);
-
- __out__ = iparmq_(&ispec, &name, &opts, &n, &ilo, &ihi, &lwork);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_iparmq(VALUE mLapack){
- rb_define_module_function(mLapack, "iparmq", rb_iparmq, -1);
-}
diff --git a/izmax1.c b/izmax1.c
deleted file mode 100644
index 4710bf9..0000000
--- a/izmax1.c
+++ /dev/null
@@ -1,44 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer izmax1_(integer *n, doublecomplex *cx, integer *incx);
-
-static VALUE
-rb_izmax1(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- doublecomplex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb___out__;
- integer __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.izmax1( cx, incx)\n or\n NumRu::Lapack.izmax1 # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION IZMAX1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* IZMAX1 finds the index of the element whose real part has maximum\n* absolute value.\n*\n* Based on IZAMAX from Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with ZLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX*16 array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX >= 1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX\n DOUBLE PRECISION SMAX\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function definitions ..\n*\n* NEXT LINE IS THE ONLY MODIFICATION.\n CABS1( ZDUM ) = ABS( ZDUM )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
-
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cx);
- if (NA_TYPE(rb_cx) != NA_DCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_DCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, doublecomplex*);
-
- __out__ = izmax1_(&n, cx, &incx);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_izmax1(VALUE mLapack){
- rb_define_module_function(mLapack, "izmax1", rb_izmax1, -1);
-}
diff --git a/lib/lapack.rb b/lib/lapack.rb
deleted file mode 100644
index 33c7232..0000000
--- a/lib/lapack.rb
+++ /dev/null
@@ -1,2 +0,0 @@
-require "narray"
-require "numru/lapack.so"
diff --git a/lib/numru/lapack.rb b/lib/numru/lapack.rb
new file mode 100644
index 0000000..ea4cfd6
--- /dev/null
+++ b/lib/numru/lapack.rb
@@ -0,0 +1,51 @@
+require "narray"
+require "numru/lapack.so"
+
+
+
+class NMatrix
+
+ # to lapack matrix
+ def to_lm
+ NArray.ref(self.transpose)
+ end
+
+ # to lapack band matrix
+ def to_lb(kl, ku, shift=0)
+ n = shape[0]
+ na = NArray.ref(self)
+ lb = NArray.new(typecode, kl+ku+1+shift, n)
+ n.times do |j|
+ i0 = [n-1,j+kl].min
+ i1 = [0,j-ku].max
+ l = i0 - i1 + 1
+ lb[-i1-1..-i0-1,j] = na[j,i0..i1]
+ end
+ lb
+ end
+
+ # to lapack symmetrix band matrix
+ def to_lsb(uplo, kd)
+ n = shape[0]
+ lsb = NArray.new(typecode, kd+1, n)
+ na = NArray.ref(self)
+ case uplo
+ when /U/i
+ n.times do |j|
+ i0 = [0,j-kd].max
+ i1 = j
+ lsb[i0+kd-j..i1+kd-j, j] = na[j,i0..i1]
+ end
+ when /L/i
+ n.times do |j|
+ i0 = j
+ i1 = [n-1,j+kd].min
+ lsb[i0-j..i1-j, j] = na[j,i0..i1]
+ end
+ else
+ raise "uplo is invalid"
+ end
+ lsb
+ end
+
+end
diff --git a/lsamen.c b/lsamen.c
deleted file mode 100644
index c41ab8d..0000000
--- a/lsamen.c
+++ /dev/null
@@ -1,40 +0,0 @@
-#include "rb_lapack.h"
-
-extern logical lsamen_(integer *n, char *ca, char *cb);
-
-static VALUE
-rb_lsamen(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_ca;
- char *ca;
- VALUE rb_cb;
- char *cb;
- VALUE rb___out__;
- logical __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.lsamen( n, ca, cb)\n or\n NumRu::Lapack.lsamen # print help\n\n\nFORTRAN MANUAL\n LOGICAL FUNCTION LSAMEN( N, CA, CB )\n\n* Purpose\n* =======\n*\n* LSAMEN tests if the first N letters of CA are the same as the\n* first N letters of CB, regardless of case.\n* LSAMEN returns .TRUE. if CA and CB are equivalent except for case\n* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )\n* or LEN( CB ) is less than N.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of characters in CA and CB to be compared.\n*\n* CA (input) CHARACTER*(*)\n* CB (input) CHARACTER*(*)\n* CA and CB specify two character strings of length at least N.\n* Only the first N characters of each string will be accessed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC LEN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_n = argv[0];
- rb_ca = argv[1];
- rb_cb = argv[2];
-
- n = NUM2INT(rb_n);
- ca = StringValueCStr(rb_ca);
- cb = StringValueCStr(rb_cb);
-
- __out__ = lsamen_(&n, ca, cb);
-
- rb___out__ = __out__ ? Qtrue : Qfalse;
- return rb___out__;
-}
-
-void
-init_lapack_lsamen(VALUE mLapack){
- rb_define_module_function(mLapack, "lsamen", rb_lsamen, -1);
-}
diff --git a/rb_lapack.c b/rb_lapack.c
deleted file mode 100644
index d99d5ff..0000000
--- a/rb_lapack.c
+++ /dev/null
@@ -1,3273 +0,0 @@
-#include "ruby.h"
-
-extern void init_lapack_sgetri(VALUE mLapack);
-extern void init_lapack_scsum1(VALUE mLapack);
-extern void init_lapack_zgelsy(VALUE mLapack);
-extern void init_lapack_chbgv(VALUE mLapack);
-extern void init_lapack_slahrd(VALUE mLapack);
-extern void init_lapack_zptts2(VALUE mLapack);
-extern void init_lapack_dorgqr(VALUE mLapack);
-extern void init_lapack_cspmv(VALUE mLapack);
-extern void init_lapack_zggev(VALUE mLapack);
-extern void init_lapack_cgerqf(VALUE mLapack);
-extern void init_lapack_dpttrf(VALUE mLapack);
-extern void init_lapack_zgerfs(VALUE mLapack);
-extern void init_lapack_ctrrfs(VALUE mLapack);
-extern void init_lapack_slartv(VALUE mLapack);
-extern void init_lapack_dlarra(VALUE mLapack);
-extern void init_lapack_dgesvd(VALUE mLapack);
-extern void init_lapack_dspev(VALUE mLapack);
-extern void init_lapack_zlaqps(VALUE mLapack);
-extern void init_lapack_ztrevc(VALUE mLapack);
-extern void init_lapack_cgeqrfp(VALUE mLapack);
-extern void init_lapack_cunbdb(VALUE mLapack);
-extern void init_lapack_ztrti2(VALUE mLapack);
-extern void init_lapack_stzrzf(VALUE mLapack);
-extern void init_lapack_dlaic1(VALUE mLapack);
-extern void init_lapack_dlalsa(VALUE mLapack);
-extern void init_lapack_zgetri(VALUE mLapack);
-extern void init_lapack_zsytrf(VALUE mLapack);
-extern void init_lapack_zsptrs(VALUE mLapack);
-extern void init_lapack_zlaein(VALUE mLapack);
-extern void init_lapack_dtrti2(VALUE mLapack);
-extern void init_lapack_zstegr(VALUE mLapack);
-extern void init_lapack_cgbtf2(VALUE mLapack);
-extern void init_lapack_dtrtrs(VALUE mLapack);
-extern void init_lapack_csytri2(VALUE mLapack);
-extern void init_lapack_zla_syrcond_c(VALUE mLapack);
-extern void init_lapack_dlaqr2(VALUE mLapack);
-extern void init_lapack_sgebd2(VALUE mLapack);
-extern void init_lapack_chpgst(VALUE mLapack);
-extern void init_lapack_zla_lin_berr(VALUE mLapack);
-extern void init_lapack_sgbtrf(VALUE mLapack);
-extern void init_lapack_clasr(VALUE mLapack);
-extern void init_lapack_dlarfg(VALUE mLapack);
-extern void init_lapack_zggbak(VALUE mLapack);
-extern void init_lapack_csytri(VALUE mLapack);
-extern void init_lapack_ctgsy2(VALUE mLapack);
-extern void init_lapack_clarzt(VALUE mLapack);
-extern void init_lapack_ztfsm(VALUE mLapack);
-extern void init_lapack_dlasq3(VALUE mLapack);
-extern void init_lapack_dgbrfs(VALUE mLapack);
-extern void init_lapack_cla_porpvgrw(VALUE mLapack);
-extern void init_lapack_slaqsp(VALUE mLapack);
-extern void init_lapack_dlatrd(VALUE mLapack);
-extern void init_lapack_zlahr2(VALUE mLapack);
-extern void init_lapack_dgelsx(VALUE mLapack);
-extern void init_lapack_zporfsx(VALUE mLapack);
-extern void init_lapack_slaed7(VALUE mLapack);
-extern void init_lapack_zggglm(VALUE mLapack);
-extern void init_lapack_ctzrqf(VALUE mLapack);
-extern void init_lapack_sstevr(VALUE mLapack);
-extern void init_lapack_dpftrf(VALUE mLapack);
-extern void init_lapack_zlaqr1(VALUE mLapack);
-extern void init_lapack_cgels(VALUE mLapack);
-extern void init_lapack_dtrexc(VALUE mLapack);
-extern void init_lapack_cgglse(VALUE mLapack);
-extern void init_lapack_zgerqf(VALUE mLapack);
-extern void init_lapack_claset(VALUE mLapack);
-extern void init_lapack_spptrs(VALUE mLapack);
-extern void init_lapack_zunmlq(VALUE mLapack);
-extern void init_lapack_zhptrf(VALUE mLapack);
-extern void init_lapack_zpbtrs(VALUE mLapack);
-extern void init_lapack_zlaqr5(VALUE mLapack);
-extern void init_lapack_cstein(VALUE mLapack);
-extern void init_lapack_dsfrk(VALUE mLapack);
-extern void init_lapack_slarrj(VALUE mLapack);
-extern void init_lapack_spotrs(VALUE mLapack);
-extern void init_lapack_dlagtf(VALUE mLapack);
-extern void init_lapack_zpbrfs(VALUE mLapack);
-extern void init_lapack_sdisna(VALUE mLapack);
-extern void init_lapack_slaruv(VALUE mLapack);
-extern void init_lapack_cpbequ(VALUE mLapack);
-extern void init_lapack_dormtr(VALUE mLapack);
-extern void init_lapack_sgtsv(VALUE mLapack);
-extern void init_lapack_clarzb(VALUE mLapack);
-extern void init_lapack_dla_syrpvgrw(VALUE mLapack);
-extern void init_lapack_slasq3(VALUE mLapack);
-extern void init_lapack_dposvx(VALUE mLapack);
-extern void init_lapack_zlapmr(VALUE mLapack);
-extern void init_lapack_clatrd(VALUE mLapack);
-extern void init_lapack_cla_syrpvgrw(VALUE mLapack);
-extern void init_lapack_dlaln2(VALUE mLapack);
-extern void init_lapack_zgttrs(VALUE mLapack);
-extern void init_lapack_dlasd7(VALUE mLapack);
-extern void init_lapack_zgetf2(VALUE mLapack);
-extern void init_lapack_zgebal(VALUE mLapack);
-extern void init_lapack_dspgvd(VALUE mLapack);
-extern void init_lapack_cgtsv(VALUE mLapack);
-extern void init_lapack_ctrexc(VALUE mLapack);
-extern void init_lapack_slasd1(VALUE mLapack);
-extern void init_lapack_zpbsv(VALUE mLapack);
-extern void init_lapack_dormql(VALUE mLapack);
-extern void init_lapack_sgbcon(VALUE mLapack);
-extern void init_lapack_clansp(VALUE mLapack);
-extern void init_lapack_cla_gercond_x(VALUE mLapack);
-extern void init_lapack_dtrttf(VALUE mLapack);
-extern void init_lapack_stgsen(VALUE mLapack);
-extern void init_lapack_shsein(VALUE mLapack);
-extern void init_lapack_zhfrk(VALUE mLapack);
-extern void init_lapack_sgbequ(VALUE mLapack);
-extern void init_lapack_slapll(VALUE mLapack);
-extern void init_lapack_spbstf(VALUE mLapack);
-extern void init_lapack_dptts2(VALUE mLapack);
-extern void init_lapack_ctpcon(VALUE mLapack);
-extern void init_lapack_dgeqp3(VALUE mLapack);
-extern void init_lapack_dstevx(VALUE mLapack);
-extern void init_lapack_sormrq(VALUE mLapack);
-extern void init_lapack_spteqr(VALUE mLapack);
-extern void init_lapack_sspgst(VALUE mLapack);
-extern void init_lapack_clagtm(VALUE mLapack);
-extern void init_lapack_clanht(VALUE mLapack);
-extern void init_lapack_sstemr(VALUE mLapack);
-extern void init_lapack_ssbgv(VALUE mLapack);
-extern void init_lapack_slascl(VALUE mLapack);
-extern void init_lapack_ssbgvx(VALUE mLapack);
-extern void init_lapack_disnan(VALUE mLapack);
-extern void init_lapack_zlaset(VALUE mLapack);
-extern void init_lapack_zggqrf(VALUE mLapack);
-extern void init_lapack_zlarscl2(VALUE mLapack);
-extern void init_lapack_dgtsv(VALUE mLapack);
-extern void init_lapack_zptrfs(VALUE mLapack);
-extern void init_lapack_cungqr(VALUE mLapack);
-extern void init_lapack_dstemr(VALUE mLapack);
-extern void init_lapack_clapll(VALUE mLapack);
-extern void init_lapack_slasd8(VALUE mLapack);
-extern void init_lapack_dlahrd(VALUE mLapack);
-extern void init_lapack_sgbrfsx(VALUE mLapack);
-extern void init_lapack_cla_syrcond_c(VALUE mLapack);
-extern void init_lapack_slaswp(VALUE mLapack);
-extern void init_lapack_zlatps(VALUE mLapack);
-extern void init_lapack_dpptrf(VALUE mLapack);
-extern void init_lapack_cgegv(VALUE mLapack);
-extern void init_lapack_slacn2(VALUE mLapack);
-extern void init_lapack_ctbrfs(VALUE mLapack);
-extern void init_lapack_cporfsx(VALUE mLapack);
-extern void init_lapack_dlasq2(VALUE mLapack);
-extern void init_lapack_dtfttr(VALUE mLapack);
-extern void init_lapack_clarcm(VALUE mLapack);
-extern void init_lapack_zgglse(VALUE mLapack);
-extern void init_lapack_ssptri(VALUE mLapack);
-extern void init_lapack_cgbcon(VALUE mLapack);
-extern void init_lapack_chptrs(VALUE mLapack);
-extern void init_lapack_sspsv(VALUE mLapack);
-extern void init_lapack_cpoequb(VALUE mLapack);
-extern void init_lapack_zlaev2(VALUE mLapack);
-extern void init_lapack_spbtf2(VALUE mLapack);
-extern void init_lapack_cgesc2(VALUE mLapack);
-extern void init_lapack_chegv(VALUE mLapack);
-extern void init_lapack_slatrs(VALUE mLapack);
-extern void init_lapack_dgeevx(VALUE mLapack);
-extern void init_lapack_sgbequb(VALUE mLapack);
-extern void init_lapack_clangb(VALUE mLapack);
-extern void init_lapack_dla_porfsx_extended(VALUE mLapack);
-extern void init_lapack_spoequb(VALUE mLapack);
-extern void init_lapack_dlaqsb(VALUE mLapack);
-extern void init_lapack_zlascl2(VALUE mLapack);
-extern void init_lapack_zpttrs(VALUE mLapack);
-extern void init_lapack_dspsv(VALUE mLapack);
-extern void init_lapack_slaed9(VALUE mLapack);
-extern void init_lapack_ztgsyl(VALUE mLapack);
-extern void init_lapack_zlauum(VALUE mLapack);
-extern void init_lapack_zbdsqr(VALUE mLapack);
-extern void init_lapack_stptri(VALUE mLapack);
-extern void init_lapack_dlasd6(VALUE mLapack);
-extern void init_lapack_slar2v(VALUE mLapack);
-extern void init_lapack_claqp2(VALUE mLapack);
-extern void init_lapack_slaed6(VALUE mLapack);
-extern void init_lapack_spttrf(VALUE mLapack);
-extern void init_lapack_dtgex2(VALUE mLapack);
-extern void init_lapack_dla_gbrfsx_extended(VALUE mLapack);
-extern void init_lapack_claqr5(VALUE mLapack);
-extern void init_lapack_zptsvx(VALUE mLapack);
-extern void init_lapack_zgerq2(VALUE mLapack);
-extern void init_lapack_dsysvx(VALUE mLapack);
-extern void init_lapack_strcon(VALUE mLapack);
-extern void init_lapack_stbcon(VALUE mLapack);
-extern void init_lapack_dlantr(VALUE mLapack);
-extern void init_lapack_slapy3(VALUE mLapack);
-extern void init_lapack_slauu2(VALUE mLapack);
-extern void init_lapack_sgetrf(VALUE mLapack);
-extern void init_lapack_sggqrf(VALUE mLapack);
-extern void init_lapack_dsyevr(VALUE mLapack);
-extern void init_lapack_chbevx(VALUE mLapack);
-extern void init_lapack_zgtrfs(VALUE mLapack);
-extern void init_lapack_zgtcon(VALUE mLapack);
-extern void init_lapack_claqr1(VALUE mLapack);
-extern void init_lapack_zhbev(VALUE mLapack);
-extern void init_lapack_srscl(VALUE mLapack);
-extern void init_lapack_csytrs2(VALUE mLapack);
-extern void init_lapack_clarrv(VALUE mLapack);
-extern void init_lapack_iparmq(VALUE mLapack);
-extern void init_lapack_zlantp(VALUE mLapack);
-extern void init_lapack_zla_geamv(VALUE mLapack);
-extern void init_lapack_cgesvxx(VALUE mLapack);
-extern void init_lapack_cla_lin_berr(VALUE mLapack);
-extern void init_lapack_ctgsyl(VALUE mLapack);
-extern void init_lapack_dlas2(VALUE mLapack);
-extern void init_lapack_dlaebz(VALUE mLapack);
-extern void init_lapack_zlarzb(VALUE mLapack);
-extern void init_lapack_sgbtf2(VALUE mLapack);
-extern void init_lapack_zlanhb(VALUE mLapack);
-extern void init_lapack_spstrf(VALUE mLapack);
-extern void init_lapack_cheev(VALUE mLapack);
-extern void init_lapack_claed7(VALUE mLapack);
-extern void init_lapack_cpbtf2(VALUE mLapack);
-extern void init_lapack_dsysv(VALUE mLapack);
-extern void init_lapack_zsytrs2(VALUE mLapack);
-extern void init_lapack_csytrf(VALUE mLapack);
-extern void init_lapack_sgsvj0(VALUE mLapack);
-extern void init_lapack_zlaqr0(VALUE mLapack);
-extern void init_lapack_cptrfs(VALUE mLapack);
-extern void init_lapack_claqhe(VALUE mLapack);
-extern void init_lapack_ssterf(VALUE mLapack);
-extern void init_lapack_zhbgvx(VALUE mLapack);
-extern void init_lapack_dgerfsx(VALUE mLapack);
-extern void init_lapack_zla_syrpvgrw(VALUE mLapack);
-extern void init_lapack_sorcsd(VALUE mLapack);
-extern void init_lapack_dorml2(VALUE mLapack);
-extern void init_lapack_slaqp2(VALUE mLapack);
-extern void init_lapack_ctrttp(VALUE mLapack);
-extern void init_lapack_ztgsna(VALUE mLapack);
-extern void init_lapack_dgebrd(VALUE mLapack);
-extern void init_lapack_slartgs(VALUE mLapack);
-extern void init_lapack_dgeequb(VALUE mLapack);
-extern void init_lapack_stzrqf(VALUE mLapack);
-extern void init_lapack_zgbrfs(VALUE mLapack);
-extern void init_lapack_dgesc2(VALUE mLapack);
-extern void init_lapack_zgees(VALUE mLapack);
-extern void init_lapack_dtgexc(VALUE mLapack);
-extern void init_lapack_ssptrd(VALUE mLapack);
-extern void init_lapack_slanhs(VALUE mLapack);
-extern void init_lapack_dgttrf(VALUE mLapack);
-extern void init_lapack_zptcon(VALUE mLapack);
-extern void init_lapack_slaln2(VALUE mLapack);
-extern void init_lapack_cgesvd(VALUE mLapack);
-extern void init_lapack_xerbla_array(VALUE mLapack);
-extern void init_lapack_sposvxx(VALUE mLapack);
-extern void init_lapack_zhprfs(VALUE mLapack);
-extern void init_lapack_zlacrm(VALUE mLapack);
-extern void init_lapack_dsteqr(VALUE mLapack);
-extern void init_lapack_csyconv(VALUE mLapack);
-extern void init_lapack_sgttrs(VALUE mLapack);
-extern void init_lapack_csptri(VALUE mLapack);
-extern void init_lapack_dlasq4(VALUE mLapack);
-extern void init_lapack_zla_syrfsx_extended(VALUE mLapack);
-extern void init_lapack_dgeqpf(VALUE mLapack);
-extern void init_lapack_clansb(VALUE mLapack);
-extern void init_lapack_dsptri(VALUE mLapack);
-extern void init_lapack_dpbtrf(VALUE mLapack);
-extern void init_lapack_ctbcon(VALUE mLapack);
-extern void init_lapack_sgeqp3(VALUE mLapack);
-extern void init_lapack_cspsv(VALUE mLapack);
-extern void init_lapack_stgevc(VALUE mLapack);
-extern void init_lapack_zsptrf(VALUE mLapack);
-extern void init_lapack_ssbgst(VALUE mLapack);
-extern void init_lapack_ctgexc(VALUE mLapack);
-extern void init_lapack_slaqps(VALUE mLapack);
-extern void init_lapack_dsbtrd(VALUE mLapack);
-extern void init_lapack_zunmqr(VALUE mLapack);
-extern void init_lapack_dlarrj(VALUE mLapack);
-extern void init_lapack_clantb(VALUE mLapack);
-extern void init_lapack_cgeesx(VALUE mLapack);
-extern void init_lapack_zggrqf(VALUE mLapack);
-extern void init_lapack_cunmtr(VALUE mLapack);
-extern void init_lapack_dggev(VALUE mLapack);
-extern void init_lapack_clarscl2(VALUE mLapack);
-extern void init_lapack_dlasd8(VALUE mLapack);
-extern void init_lapack_dsygv(VALUE mLapack);
-extern void init_lapack_dlasda(VALUE mLapack);
-extern void init_lapack_dorgql(VALUE mLapack);
-extern void init_lapack_slagv2(VALUE mLapack);
-extern void init_lapack_iladlr(VALUE mLapack);
-extern void init_lapack_cuncsd(VALUE mLapack);
-extern void init_lapack_icmax1(VALUE mLapack);
-extern void init_lapack_dorcsd(VALUE mLapack);
-extern void init_lapack_cgelsy(VALUE mLapack);
-extern void init_lapack_dptrfs(VALUE mLapack);
-extern void init_lapack_spoequ(VALUE mLapack);
-extern void init_lapack_sgbsvxx(VALUE mLapack);
-extern void init_lapack_zgeequ(VALUE mLapack);
-extern void init_lapack_sgelsd(VALUE mLapack);
-extern void init_lapack_sgbsv(VALUE mLapack);
-extern void init_lapack_cstedc(VALUE mLapack);
-extern void init_lapack_slasd2(VALUE mLapack);
-extern void init_lapack_dggsvd(VALUE mLapack);
-extern void init_lapack_clags2(VALUE mLapack);
-extern void init_lapack_zlalsa(VALUE mLapack);
-extern void init_lapack_dpotf2(VALUE mLapack);
-extern void init_lapack_dlantb(VALUE mLapack);
-extern void init_lapack_ctfttp(VALUE mLapack);
-extern void init_lapack_zhbevd(VALUE mLapack);
-extern void init_lapack_cggev(VALUE mLapack);
-extern void init_lapack_sorg2r(VALUE mLapack);
-extern void init_lapack_dppsv(VALUE mLapack);
-extern void init_lapack_cgebd2(VALUE mLapack);
-extern void init_lapack_zgebrd(VALUE mLapack);
-extern void init_lapack_clanhf(VALUE mLapack);
-extern void init_lapack_sla_lin_berr(VALUE mLapack);
-extern void init_lapack_cgeqlf(VALUE mLapack);
-extern void init_lapack_cunmql(VALUE mLapack);
-extern void init_lapack_zgetrf(VALUE mLapack);
-extern void init_lapack_clauu2(VALUE mLapack);
-extern void init_lapack_slasq4(VALUE mLapack);
-extern void init_lapack_zpftri(VALUE mLapack);
-extern void init_lapack_dla_syrcond(VALUE mLapack);
-extern void init_lapack_zgehd2(VALUE mLapack);
-extern void init_lapack_zla_porfsx_extended(VALUE mLapack);
-extern void init_lapack_dporfs(VALUE mLapack);
-extern void init_lapack_zgesdd(VALUE mLapack);
-extern void init_lapack_dlagv2(VALUE mLapack);
-extern void init_lapack_cggrqf(VALUE mLapack);
-extern void init_lapack_dlasrt(VALUE mLapack);
-extern void init_lapack_sorml2(VALUE mLapack);
-extern void init_lapack_slar1v(VALUE mLapack);
-extern void init_lapack_dpbcon(VALUE mLapack);
-extern void init_lapack_cgebak(VALUE mLapack);
-extern void init_lapack_chetrs2(VALUE mLapack);
-extern void init_lapack_zstein(VALUE mLapack);
-extern void init_lapack_chpcon(VALUE mLapack);
-extern void init_lapack_zla_hercond_x(VALUE mLapack);
-extern void init_lapack_chesv(VALUE mLapack);
-extern void init_lapack_ztgsen(VALUE mLapack);
-extern void init_lapack_sorg2l(VALUE mLapack);
-extern void init_lapack_strevc(VALUE mLapack);
-extern void init_lapack_dlansy(VALUE mLapack);
-extern void init_lapack_dggqrf(VALUE mLapack);
-extern void init_lapack_cpttrf(VALUE mLapack);
-extern void init_lapack_zla_gbrcond_c(VALUE mLapack);
-extern void init_lapack_cupgtr(VALUE mLapack);
-extern void init_lapack_zsytri2(VALUE mLapack);
-extern void init_lapack_izmax1(VALUE mLapack);
-extern void init_lapack_dlaed0(VALUE mLapack);
-extern void init_lapack_zunghr(VALUE mLapack);
-extern void init_lapack_sorgl2(VALUE mLapack);
-extern void init_lapack_dsbgv(VALUE mLapack);
-extern void init_lapack_dstevd(VALUE mLapack);
-extern void init_lapack_dladiv(VALUE mLapack);
-extern void init_lapack_dgelqf(VALUE mLapack);
-extern void init_lapack_dla_wwaddw(VALUE mLapack);
-extern void init_lapack_ztzrqf(VALUE mLapack);
-extern void init_lapack_sorgtr(VALUE mLapack);
-extern void init_lapack_dgbtf2(VALUE mLapack);
-extern void init_lapack_chegvx(VALUE mLapack);
-extern void init_lapack_zlaqsy(VALUE mLapack);
-extern void init_lapack_zlarfx(VALUE mLapack);
-extern void init_lapack_sspevx(VALUE mLapack);
-extern void init_lapack_dorgl2(VALUE mLapack);
-extern void init_lapack_slatdf(VALUE mLapack);
-extern void init_lapack_spprfs(VALUE mLapack);
-extern void init_lapack_zunmhr(VALUE mLapack);
-extern void init_lapack_slaqr1(VALUE mLapack);
-extern void init_lapack_zhptrs(VALUE mLapack);
-extern void init_lapack_zla_gbrfsx_extended(VALUE mLapack);
-extern void init_lapack_slarzb(VALUE mLapack);
-extern void init_lapack_cgbsvxx(VALUE mLapack);
-extern void init_lapack_dlatrz(VALUE mLapack);
-extern void init_lapack_cheevr(VALUE mLapack);
-extern void init_lapack_dlasq6(VALUE mLapack);
-extern void init_lapack_zlahrd(VALUE mLapack);
-extern void init_lapack_zlaqhp(VALUE mLapack);
-extern void init_lapack_zla_hercond_c(VALUE mLapack);
-extern void init_lapack_dgesdd(VALUE mLapack);
-extern void init_lapack_ztfttp(VALUE mLapack);
-extern void init_lapack_sspgvd(VALUE mLapack);
-extern void init_lapack_clasyf(VALUE mLapack);
-extern void init_lapack_dgetrs(VALUE mLapack);
-extern void init_lapack_dlarrk(VALUE mLapack);
-extern void init_lapack_slasyf(VALUE mLapack);
-extern void init_lapack_slatrz(VALUE mLapack);
-extern void init_lapack_dlatbs(VALUE mLapack);
-extern void init_lapack_spbequ(VALUE mLapack);
-extern void init_lapack_dppequ(VALUE mLapack);
-extern void init_lapack_cpotrs(VALUE mLapack);
-extern void init_lapack_zpotri(VALUE mLapack);
-extern void init_lapack_dsyequb(VALUE mLapack);
-extern void init_lapack_claesy(VALUE mLapack);
-extern void init_lapack_dgees(VALUE mLapack);
-extern void init_lapack_slasrt(VALUE mLapack);
-extern void init_lapack_stgsyl(VALUE mLapack);
-extern void init_lapack_ztftri(VALUE mLapack);
-extern void init_lapack_dlaed1(VALUE mLapack);
-extern void init_lapack_slarfg(VALUE mLapack);
-extern void init_lapack_zlacgv(VALUE mLapack);
-extern void init_lapack_slantr(VALUE mLapack);
-extern void init_lapack_dlaqtr(VALUE mLapack);
-extern void init_lapack_ddisna(VALUE mLapack);
-extern void init_lapack_cbdsqr(VALUE mLapack);
-extern void init_lapack_dtgsy2(VALUE mLapack);
-extern void init_lapack_zgels(VALUE mLapack);
-extern void init_lapack_cla_syamv(VALUE mLapack);
-extern void init_lapack_zheequb(VALUE mLapack);
-extern void init_lapack_cpbcon(VALUE mLapack);
-extern void init_lapack_dlartv(VALUE mLapack);
-extern void init_lapack_sla_gbrpvgrw(VALUE mLapack);
-extern void init_lapack_cla_heamv(VALUE mLapack);
-extern void init_lapack_dlanhs(VALUE mLapack);
-extern void init_lapack_zpteqr(VALUE mLapack);
-extern void init_lapack_slagts(VALUE mLapack);
-extern void init_lapack_dlange(VALUE mLapack);
-extern void init_lapack_slasq1(VALUE mLapack);
-extern void init_lapack_dgelss(VALUE mLapack);
-extern void init_lapack_cggsvp(VALUE mLapack);
-extern void init_lapack_dorbdb(VALUE mLapack);
-extern void init_lapack_dlacon(VALUE mLapack);
-extern void init_lapack_chptri(VALUE mLapack);
-extern void init_lapack_slatps(VALUE mLapack);
-extern void init_lapack_dlarf(VALUE mLapack);
-extern void init_lapack_slasdq(VALUE mLapack);
-extern void init_lapack_csycon(VALUE mLapack);
-extern void init_lapack_cggglm(VALUE mLapack);
-extern void init_lapack_zlanhp(VALUE mLapack);
-extern void init_lapack_zsymv(VALUE mLapack);
-extern void init_lapack_cpbsv(VALUE mLapack);
-extern void init_lapack_dlahqr(VALUE mLapack);
-extern void init_lapack_dorgbr(VALUE mLapack);
-extern void init_lapack_clarft(VALUE mLapack);
-extern void init_lapack_dgglse(VALUE mLapack);
-extern void init_lapack_sgerfsx(VALUE mLapack);
-extern void init_lapack_dtzrzf(VALUE mLapack);
-extern void init_lapack_dlauu2(VALUE mLapack);
-extern void init_lapack_ztzrzf(VALUE mLapack);
-extern void init_lapack_cgeql2(VALUE mLapack);
-extern void init_lapack_zungrq(VALUE mLapack);
-extern void init_lapack_sstedc(VALUE mLapack);
-extern void init_lapack_zgeequb(VALUE mLapack);
-extern void init_lapack_slartgp(VALUE mLapack);
-extern void init_lapack_slarrb(VALUE mLapack);
-extern void init_lapack_sggbal(VALUE mLapack);
-extern void init_lapack_slatbs(VALUE mLapack);
-extern void init_lapack_cunglq(VALUE mLapack);
-extern void init_lapack_dptsv(VALUE mLapack);
-extern void init_lapack_cunm2l(VALUE mLapack);
-extern void init_lapack_dlapy3(VALUE mLapack);
-extern void init_lapack_dlarrb(VALUE mLapack);
-extern void init_lapack_sgerqf(VALUE mLapack);
-extern void init_lapack_zungl2(VALUE mLapack);
-extern void init_lapack_classq(VALUE mLapack);
-extern void init_lapack_zptsv(VALUE mLapack);
-extern void init_lapack_cbbcsd(VALUE mLapack);
-extern void init_lapack_slarrd(VALUE mLapack);
-extern void init_lapack_cpstrf(VALUE mLapack);
-extern void init_lapack_sbdsdc(VALUE mLapack);
-extern void init_lapack_dstein(VALUE mLapack);
-extern void init_lapack_cgelqf(VALUE mLapack);
-extern void init_lapack_dgecon(VALUE mLapack);
-extern void init_lapack_dlansf(VALUE mLapack);
-extern void init_lapack_dlanst(VALUE mLapack);
-extern void init_lapack_claic1(VALUE mLapack);
-extern void init_lapack_zlansp(VALUE mLapack);
-extern void init_lapack_dgbcon(VALUE mLapack);
-extern void init_lapack_zgebd2(VALUE mLapack);
-extern void init_lapack_dlatzm(VALUE mLapack);
-extern void init_lapack_sormbr(VALUE mLapack);
-extern void init_lapack_cgeequ(VALUE mLapack);
-extern void init_lapack_ssyswapr(VALUE mLapack);
-extern void init_lapack_dla_porpvgrw(VALUE mLapack);
-extern void init_lapack_zgebak(VALUE mLapack);
-extern void init_lapack_dstebz(VALUE mLapack);
-extern void init_lapack_clahr2(VALUE mLapack);
-extern void init_lapack_dgetc2(VALUE mLapack);
-extern void init_lapack_dsygvd(VALUE mLapack);
-extern void init_lapack_zgbtrs(VALUE mLapack);
-extern void init_lapack_sptrfs(VALUE mLapack);
-extern void init_lapack_strsna(VALUE mLapack);
-extern void init_lapack_sorglq(VALUE mLapack);
-extern void init_lapack_dsygvx(VALUE mLapack);
-extern void init_lapack_cheevx(VALUE mLapack);
-extern void init_lapack_zsytri(VALUE mLapack);
-extern void init_lapack_dlassq(VALUE mLapack);
-extern void init_lapack_dsptrd(VALUE mLapack);
-extern void init_lapack_zla_gercond_c(VALUE mLapack);
-extern void init_lapack_cla_rpvgrw(VALUE mLapack);
-extern void init_lapack_slaebz(VALUE mLapack);
-extern void init_lapack_ztbtrs(VALUE mLapack);
-extern void init_lapack_slaqr4(VALUE mLapack);
-extern void init_lapack_dlaqps(VALUE mLapack);
-extern void init_lapack_dhsein(VALUE mLapack);
-extern void init_lapack_zggesx(VALUE mLapack);
-extern void init_lapack_dgtrfs(VALUE mLapack);
-extern void init_lapack_chgeqz(VALUE mLapack);
-extern void init_lapack_cungl2(VALUE mLapack);
-extern void init_lapack_dlasyf(VALUE mLapack);
-extern void init_lapack_dtzrqf(VALUE mLapack);
-extern void init_lapack_zhpcon(VALUE mLapack);
-extern void init_lapack_dgesv(VALUE mLapack);
-extern void init_lapack_cgeev(VALUE mLapack);
-extern void init_lapack_zbbcsd(VALUE mLapack);
-extern void init_lapack_dpprfs(VALUE mLapack);
-extern void init_lapack_zhesvx(VALUE mLapack);
-extern void init_lapack_cheevd(VALUE mLapack);
-extern void init_lapack_zhegvx(VALUE mLapack);
-extern void init_lapack_clanhp(VALUE mLapack);
-extern void init_lapack_cung2r(VALUE mLapack);
-extern void init_lapack_sgetrs(VALUE mLapack);
-extern void init_lapack_zung2l(VALUE mLapack);
-extern void init_lapack_zgehrd(VALUE mLapack);
-extern void init_lapack_cgeqrf(VALUE mLapack);
-extern void init_lapack_slatrd(VALUE mLapack);
-extern void init_lapack_zlaed0(VALUE mLapack);
-extern void init_lapack_dlaed9(VALUE mLapack);
-extern void init_lapack_sgeevx(VALUE mLapack);
-extern void init_lapack_sorgql(VALUE mLapack);
-extern void init_lapack_ctgevc(VALUE mLapack);
-extern void init_lapack_dgsvj0(VALUE mLapack);
-extern void init_lapack_cgehrd(VALUE mLapack);
-extern void init_lapack_spbsvx(VALUE mLapack);
-extern void init_lapack_cla_hercond_c(VALUE mLapack);
-extern void init_lapack_clacp2(VALUE mLapack);
-extern void init_lapack_zdrscl(VALUE mLapack);
-extern void init_lapack_chetrs(VALUE mLapack);
-extern void init_lapack_zsycon(VALUE mLapack);
-extern void init_lapack_ssytri(VALUE mLapack);
-extern void init_lapack_dorm2l(VALUE mLapack);
-extern void init_lapack_sgelsy(VALUE mLapack);
-extern void init_lapack_sla_gbrcond(VALUE mLapack);
-extern void init_lapack_chptrd(VALUE mLapack);
-extern void init_lapack_sgerfs(VALUE mLapack);
-extern void init_lapack_chegvd(VALUE mLapack);
-extern void init_lapack_dlaqr3(VALUE mLapack);
-extern void init_lapack_dsytd2(VALUE mLapack);
-extern void init_lapack_cposvxx(VALUE mLapack);
-extern void init_lapack_dspgst(VALUE mLapack);
-extern void init_lapack_ssygvx(VALUE mLapack);
-extern void init_lapack_slaexc(VALUE mLapack);
-extern void init_lapack_zla_gbamv(VALUE mLapack);
-extern void init_lapack_zsptri(VALUE mLapack);
-extern void init_lapack_zpbtrf(VALUE mLapack);
-extern void init_lapack_sgelsx(VALUE mLapack);
-extern void init_lapack_zspsvx(VALUE mLapack);
-extern void init_lapack_slacon(VALUE mLapack);
-extern void init_lapack_zlanhf(VALUE mLapack);
-extern void init_lapack_dgegv(VALUE mLapack);
-extern void init_lapack_slae2(VALUE mLapack);
-extern void init_lapack_cpbrfs(VALUE mLapack);
-extern void init_lapack_stgexc(VALUE mLapack);
-extern void init_lapack_slargv(VALUE mLapack);
-extern void init_lapack_clacn2(VALUE mLapack);
-extern void init_lapack_claqps(VALUE mLapack);
-extern void init_lapack_ssteqr(VALUE mLapack);
-extern void init_lapack_slasd3(VALUE mLapack);
-extern void init_lapack_zgeqpf(VALUE mLapack);
-extern void init_lapack_strexc(VALUE mLapack);
-extern void init_lapack_zla_gbrpvgrw(VALUE mLapack);
-extern void init_lapack_zla_heamv(VALUE mLapack);
-extern void init_lapack_slaed8(VALUE mLapack);
-extern void init_lapack_clatbs(VALUE mLapack);
-extern void init_lapack_zlange(VALUE mLapack);
-extern void init_lapack_zgbcon(VALUE mLapack);
-extern void init_lapack_slasdt(VALUE mLapack);
-extern void init_lapack_chpgvx(VALUE mLapack);
-extern void init_lapack_cpftrs(VALUE mLapack);
-extern void init_lapack_zhetri(VALUE mLapack);
-extern void init_lapack_slauum(VALUE mLapack);
-extern void init_lapack_ssyevr(VALUE mLapack);
-extern void init_lapack_dormr3(VALUE mLapack);
-extern void init_lapack_zung2r(VALUE mLapack);
-extern void init_lapack_csysvx(VALUE mLapack);
-extern void init_lapack_claed0(VALUE mLapack);
-extern void init_lapack_zgesvxx(VALUE mLapack);
-extern void init_lapack_dgbequ(VALUE mLapack);
-extern void init_lapack_clacrm(VALUE mLapack);
-extern void init_lapack_sgeqr2(VALUE mLapack);
-extern void init_lapack_cgbsvx(VALUE mLapack);
-extern void init_lapack_dlapy2(VALUE mLapack);
-extern void init_lapack_cggsvd(VALUE mLapack);
-extern void init_lapack_zlassq(VALUE mLapack);
-extern void init_lapack_dpotri(VALUE mLapack);
-extern void init_lapack_slaqr5(VALUE mLapack);
-extern void init_lapack_dlantp(VALUE mLapack);
-extern void init_lapack_dspevd(VALUE mLapack);
-extern void init_lapack_dporfsx(VALUE mLapack);
-extern void init_lapack_ztptri(VALUE mLapack);
-extern void init_lapack_sgesvx(VALUE mLapack);
-extern void init_lapack_dsbev(VALUE mLapack);
-extern void init_lapack_sormqr(VALUE mLapack);
-extern void init_lapack_dtbrfs(VALUE mLapack);
-extern void init_lapack_slasv2(VALUE mLapack);
-extern void init_lapack_dpttrs(VALUE mLapack);
-extern void init_lapack_zpbsvx(VALUE mLapack);
-extern void init_lapack_zpptrs(VALUE mLapack);
-extern void init_lapack_ztrexc(VALUE mLapack);
-extern void init_lapack_dla_syrfsx_extended(VALUE mLapack);
-extern void init_lapack_slasd4(VALUE mLapack);
-extern void init_lapack_dlasy2(VALUE mLapack);
-extern void init_lapack_dgeqlf(VALUE mLapack);
-extern void init_lapack_zunm2r(VALUE mLapack);
-extern void init_lapack_clarfgp(VALUE mLapack);
-extern void init_lapack_ssytrs(VALUE mLapack);
-extern void init_lapack_dtrcon(VALUE mLapack);
-extern void init_lapack_spttrs(VALUE mLapack);
-extern void init_lapack_spotri(VALUE mLapack);
-extern void init_lapack_slanst(VALUE mLapack);
-extern void init_lapack_dlaqsp(VALUE mLapack);
-extern void init_lapack_zgbtf2(VALUE mLapack);
-extern void init_lapack_chpgvd(VALUE mLapack);
-extern void init_lapack_zlapmt(VALUE mLapack);
-extern void init_lapack_cla_hercond_x(VALUE mLapack);
-extern void init_lapack_slaed1(VALUE mLapack);
-extern void init_lapack_zppequ(VALUE mLapack);
-extern void init_lapack_ssytf2(VALUE mLapack);
-extern void init_lapack_slag2d(VALUE mLapack);
-extern void init_lapack_sgeequb(VALUE mLapack);
-extern void init_lapack_chesvxx(VALUE mLapack);
-extern void init_lapack_cgebal(VALUE mLapack);
-extern void init_lapack_slarscl2(VALUE mLapack);
-extern void init_lapack_zpstf2(VALUE mLapack);
-extern void init_lapack_dsytri2x(VALUE mLapack);
-extern void init_lapack_dpptri(VALUE mLapack);
-extern void init_lapack_sla_syrcond(VALUE mLapack);
-extern void init_lapack_sggrqf(VALUE mLapack);
-extern void init_lapack_dormrz(VALUE mLapack);
-extern void init_lapack_ssytrs2(VALUE mLapack);
-extern void init_lapack_strtri(VALUE mLapack);
-extern void init_lapack_stfsm(VALUE mLapack);
-extern void init_lapack_ztpttf(VALUE mLapack);
-extern void init_lapack_dgetrf(VALUE mLapack);
-extern void init_lapack_strttf(VALUE mLapack);
-extern void init_lapack_cptts2(VALUE mLapack);
-extern void init_lapack_dlartg(VALUE mLapack);
-extern void init_lapack_slagtf(VALUE mLapack);
-extern void init_lapack_dormlq(VALUE mLapack);
-extern void init_lapack_zhpev(VALUE mLapack);
-extern void init_lapack_zlarnv(VALUE mLapack);
-extern void init_lapack_zpbstf(VALUE mLapack);
-extern void init_lapack_ssysvxx(VALUE mLapack);
-extern void init_lapack_cla_porcond_x(VALUE mLapack);
-extern void init_lapack_dlasq5(VALUE mLapack);
-extern void init_lapack_ctgsja(VALUE mLapack);
-extern void init_lapack_dtrsyl(VALUE mLapack);
-extern void init_lapack_dsposv(VALUE mLapack);
-extern void init_lapack_slaqr3(VALUE mLapack);
-extern void init_lapack_zhbgvd(VALUE mLapack);
-extern void init_lapack_ssyequb(VALUE mLapack);
-extern void init_lapack_dgttrs(VALUE mLapack);
-extern void init_lapack_zsteqr(VALUE mLapack);
-extern void init_lapack_dggrqf(VALUE mLapack);
-extern void init_lapack_cgtsvx(VALUE mLapack);
-extern void init_lapack_cgelss(VALUE mLapack);
-extern void init_lapack_zlangb(VALUE mLapack);
-extern void init_lapack_dgels(VALUE mLapack);
-extern void init_lapack_slarrr(VALUE mLapack);
-extern void init_lapack_zstedc(VALUE mLapack);
-extern void init_lapack_zhetrs2(VALUE mLapack);
-extern void init_lapack_dsprfs(VALUE mLapack);
-extern void init_lapack_dlasdq(VALUE mLapack);
-extern void init_lapack_csprfs(VALUE mLapack);
-extern void init_lapack_slarz(VALUE mLapack);
-extern void init_lapack_sggevx(VALUE mLapack);
-extern void init_lapack_ztfttr(VALUE mLapack);
-extern void init_lapack_zhegst(VALUE mLapack);
-extern void init_lapack_chpsv(VALUE mLapack);
-extern void init_lapack_dtrtri(VALUE mLapack);
-extern void init_lapack_clacgv(VALUE mLapack);
-extern void init_lapack_zpptri(VALUE mLapack);
-extern void init_lapack_chbtrd(VALUE mLapack);
-extern void init_lapack_cgesvx(VALUE mLapack);
-extern void init_lapack_slaneg(VALUE mLapack);
-extern void init_lapack_clag2z(VALUE mLapack);
-extern void init_lapack_slarra(VALUE mLapack);
-extern void init_lapack_sgsvj1(VALUE mLapack);
-extern void init_lapack_cla_gbrcond_x(VALUE mLapack);
-extern void init_lapack_cla_herpvgrw(VALUE mLapack);
-extern void init_lapack_zlascl(VALUE mLapack);
-extern void init_lapack_dsbgvx(VALUE mLapack);
-extern void init_lapack_sormhr(VALUE mLapack);
-extern void init_lapack_chetf2(VALUE mLapack);
-extern void init_lapack_ssycon(VALUE mLapack);
-extern void init_lapack_dlae2(VALUE mLapack);
-extern void init_lapack_zgelss(VALUE mLapack);
-extern void init_lapack_cgelq2(VALUE mLapack);
-extern void init_lapack_slarfb(VALUE mLapack);
-extern void init_lapack_ctrtrs(VALUE mLapack);
-extern void init_lapack_stfttr(VALUE mLapack);
-extern void init_lapack_drscl(VALUE mLapack);
-extern void init_lapack_clatdf(VALUE mLapack);
-extern void init_lapack_cherfs(VALUE mLapack);
-extern void init_lapack_dtbtrs(VALUE mLapack);
-extern void init_lapack_dlartgs(VALUE mLapack);
-extern void init_lapack_dlar2v(VALUE mLapack);
-extern void init_lapack_zlarrv(VALUE mLapack);
-extern void init_lapack_dsyswapr(VALUE mLapack);
-extern void init_lapack_dlag2s(VALUE mLapack);
-extern void init_lapack_ssprfs(VALUE mLapack);
-extern void init_lapack_cppsv(VALUE mLapack);
-extern void init_lapack_dlarfx(VALUE mLapack);
-extern void init_lapack_zppsvx(VALUE mLapack);
-extern void init_lapack_sgehd2(VALUE mLapack);
-extern void init_lapack_zheevr(VALUE mLapack);
-extern void init_lapack_ssygvd(VALUE mLapack);
-extern void init_lapack_zunglq(VALUE mLapack);
-extern void init_lapack_cungtr(VALUE mLapack);
-extern void init_lapack_zlauu2(VALUE mLapack);
-extern void init_lapack_ssfrk(VALUE mLapack);
-extern void init_lapack_dtpttr(VALUE mLapack);
-extern void init_lapack_spftrf(VALUE mLapack);
-extern void init_lapack_slascl2(VALUE mLapack);
-extern void init_lapack_slasd5(VALUE mLapack);
-extern void init_lapack_zhpsvx(VALUE mLapack);
-extern void init_lapack_dgghrd(VALUE mLapack);
-extern void init_lapack_zlasyf(VALUE mLapack);
-extern void init_lapack_zlabrd(VALUE mLapack);
-extern void init_lapack_cspr(VALUE mLapack);
-extern void init_lapack_zunm2l(VALUE mLapack);
-extern void init_lapack_dlaeda(VALUE mLapack);
-extern void init_lapack_csyr(VALUE mLapack);
-extern void init_lapack_dlangt(VALUE mLapack);
-extern void init_lapack_ctpttf(VALUE mLapack);
-extern void init_lapack_zpbcon(VALUE mLapack);
-extern void init_lapack_ztrsen(VALUE mLapack);
-extern void init_lapack_sla_syrfsx_extended(VALUE mLapack);
-extern void init_lapack_zlat2c(VALUE mLapack);
-extern void init_lapack_cunmlq(VALUE mLapack);
-extern void init_lapack_slals0(VALUE mLapack);
-extern void init_lapack_zlantr(VALUE mLapack);
-extern void init_lapack_sgels(VALUE mLapack);
-extern void init_lapack_dtgsja(VALUE mLapack);
-extern void init_lapack_sposv(VALUE mLapack);
-extern void init_lapack_dgtts2(VALUE mLapack);
-extern void init_lapack_zlaqhb(VALUE mLapack);
-extern void init_lapack_dlatrs(VALUE mLapack);
-extern void init_lapack_dsytrs2(VALUE mLapack);
-extern void init_lapack_zlansy(VALUE mLapack);
-extern void init_lapack_spbcon(VALUE mLapack);
-extern void init_lapack_dbdsdc(VALUE mLapack);
-extern void init_lapack_zlacp2(VALUE mLapack);
-extern void init_lapack_sladiv(VALUE mLapack);
-extern void init_lapack_spotrf(VALUE mLapack);
-extern void init_lapack_ilaslc(VALUE mLapack);
-extern void init_lapack_ctftri(VALUE mLapack);
-extern void init_lapack_dlamrg(VALUE mLapack);
-extern void init_lapack_dpbtf2(VALUE mLapack);
-extern void init_lapack_cgerfs(VALUE mLapack);
-extern void init_lapack_dla_gbrcond(VALUE mLapack);
-extern void init_lapack_dposvxx(VALUE mLapack);
-extern void init_lapack_dposv(VALUE mLapack);
-extern void init_lapack_cgbequ(VALUE mLapack);
-extern void init_lapack_sgeqpf(VALUE mLapack);
-extern void init_lapack_slasd6(VALUE mLapack);
-extern void init_lapack_zlarzt(VALUE mLapack);
-extern void init_lapack_csteqr(VALUE mLapack);
-extern void init_lapack_dbdsqr(VALUE mLapack);
-extern void init_lapack_zppsv(VALUE mLapack);
-extern void init_lapack_cunm2r(VALUE mLapack);
-extern void init_lapack_zla_gerfsx_extended(VALUE mLapack);
-extern void init_lapack_ssytrd(VALUE mLapack);
-extern void init_lapack_sgesc2(VALUE mLapack);
-extern void init_lapack_slanv2(VALUE mLapack);
-extern void init_lapack_sgttrf(VALUE mLapack);
-extern void init_lapack_sla_gbamv(VALUE mLapack);
-extern void init_lapack_zladiv(VALUE mLapack);
-extern void init_lapack_cpotri(VALUE mLapack);
-extern void init_lapack_zunmql(VALUE mLapack);
-extern void init_lapack_dtftri(VALUE mLapack);
-extern void init_lapack_spftrs(VALUE mLapack);
-extern void init_lapack_clahef(VALUE mLapack);
-extern void init_lapack_dppsvx(VALUE mLapack);
-extern void init_lapack_chla_transtype(VALUE mLapack);
-extern void init_lapack_slarf(VALUE mLapack);
-extern void init_lapack_dgeev(VALUE mLapack);
-extern void init_lapack_zlapll(VALUE mLapack);
-extern void init_lapack_dlarz(VALUE mLapack);
-extern void init_lapack_cungr2(VALUE mLapack);
-extern void init_lapack_dgeequ(VALUE mLapack);
-extern void init_lapack_chpev(VALUE mLapack);
-extern void init_lapack_dtpttf(VALUE mLapack);
-extern void init_lapack_zgbrfsx(VALUE mLapack);
-extern void init_lapack_dlaswp(VALUE mLapack);
-extern void init_lapack_ctgsen(VALUE mLapack);
-extern void init_lapack_dsbgvd(VALUE mLapack);
-extern void init_lapack_slags2(VALUE mLapack);
-extern void init_lapack_cgegs(VALUE mLapack);
-extern void init_lapack_dgeqr2(VALUE mLapack);
-extern void init_lapack_slansp(VALUE mLapack);
-extern void init_lapack_sgejsv(VALUE mLapack);
-extern void init_lapack_dlangb(VALUE mLapack);
-extern void init_lapack_sbbcsd(VALUE mLapack);
-extern void init_lapack_ilatrans(VALUE mLapack);
-extern void init_lapack_slacpy(VALUE mLapack);
-extern void init_lapack_cupmtr(VALUE mLapack);
-extern void init_lapack_cpoequ(VALUE mLapack);
-extern void init_lapack_clanhe(VALUE mLapack);
-extern void init_lapack_ztgevc(VALUE mLapack);
-extern void init_lapack_cla_porfsx_extended(VALUE mLapack);
-extern void init_lapack_sormql(VALUE mLapack);
-extern void init_lapack_claqgb(VALUE mLapack);
-extern void init_lapack_dlasd3(VALUE mLapack);
-extern void init_lapack_cgerfsx(VALUE mLapack);
-extern void init_lapack_dlarnv(VALUE mLapack);
-extern void init_lapack_zporfs(VALUE mLapack);
-extern void init_lapack_zposvx(VALUE mLapack);
-extern void init_lapack_sgelss(VALUE mLapack);
-extern void init_lapack_slaqsy(VALUE mLapack);
-extern void init_lapack_dlatps(VALUE mLapack);
-extern void init_lapack_dgebd2(VALUE mLapack);
-extern void init_lapack_zrot(VALUE mLapack);
-extern void init_lapack_zla_porcond_c(VALUE mLapack);
-extern void init_lapack_zhetd2(VALUE mLapack);
-extern void init_lapack_dgtsvx(VALUE mLapack);
-extern void init_lapack_sgeqrf(VALUE mLapack);
-extern void init_lapack_ctzrzf(VALUE mLapack);
-extern void init_lapack_dstedc(VALUE mLapack);
-extern void init_lapack_ssptrf(VALUE mLapack);
-extern void init_lapack_zpocon(VALUE mLapack);
-extern void init_lapack_cgeqr2(VALUE mLapack);
-extern void init_lapack_cppcon(VALUE mLapack);
-extern void init_lapack_sisnan(VALUE mLapack);
-extern void init_lapack_sppsv(VALUE mLapack);
-extern void init_lapack_dopmtr(VALUE mLapack);
-extern void init_lapack_zgeqp3(VALUE mLapack);
-extern void init_lapack_dsytrd(VALUE mLapack);
-extern void init_lapack_sopmtr(VALUE mLapack);
-extern void init_lapack_strsen(VALUE mLapack);
-extern void init_lapack_ssytri2x(VALUE mLapack);
-extern void init_lapack_cgbtrs(VALUE mLapack);
-extern void init_lapack_ctrttf(VALUE mLapack);
-extern void init_lapack_sposvx(VALUE mLapack);
-extern void init_lapack_dlasr(VALUE mLapack);
-extern void init_lapack_zunmrq(VALUE mLapack);
-extern void init_lapack_sgtrfs(VALUE mLapack);
-extern void init_lapack_dsyrfs(VALUE mLapack);
-extern void init_lapack_cgetc2(VALUE mLapack);
-extern void init_lapack_zgeevx(VALUE mLapack);
-extern void init_lapack_dstegr(VALUE mLapack);
-extern void init_lapack_sggglm(VALUE mLapack);
-extern void init_lapack_cspcon(VALUE mLapack);
-extern void init_lapack_sbdsqr(VALUE mLapack);
-extern void init_lapack_zpotrf(VALUE mLapack);
-extern void init_lapack_clahrd(VALUE mLapack);
-extern void init_lapack_dlarft(VALUE mLapack);
-extern void init_lapack_dlaneg(VALUE mLapack);
-extern void init_lapack_cgetri(VALUE mLapack);
-extern void init_lapack_zgtts2(VALUE mLapack);
-extern void init_lapack_dlasdt(VALUE mLapack);
-extern void init_lapack_zhpevx(VALUE mLapack);
-extern void init_lapack_claqsp(VALUE mLapack);
-extern void init_lapack_ztpcon(VALUE mLapack);
-extern void init_lapack_ztbrfs(VALUE mLapack);
-extern void init_lapack_slaic1(VALUE mLapack);
-extern void init_lapack_dorm2r(VALUE mLapack);
-extern void init_lapack_claqr4(VALUE mLapack);
-extern void init_lapack_zpbequ(VALUE mLapack);
-extern void init_lapack_dlapmr(VALUE mLapack);
-extern void init_lapack_dlaed8(VALUE mLapack);
-extern void init_lapack_cgerq2(VALUE mLapack);
-extern void init_lapack_sptts2(VALUE mLapack);
-extern void init_lapack_zhpgvx(VALUE mLapack);
-extern void init_lapack_dlabad(VALUE mLapack);
-extern void init_lapack_ctpttr(VALUE mLapack);
-extern void init_lapack_cungbr(VALUE mLapack);
-extern void init_lapack_dgetf2(VALUE mLapack);
-extern void init_lapack_zunmr3(VALUE mLapack);
-extern void init_lapack_ilaclc(VALUE mLapack);
-extern void init_lapack_cunmhr(VALUE mLapack);
-extern void init_lapack_dorghr(VALUE mLapack);
-extern void init_lapack_cgttrf(VALUE mLapack);
-extern void init_lapack_sormlq(VALUE mLapack);
-extern void init_lapack_zspr(VALUE mLapack);
-extern void init_lapack_cpocon(VALUE mLapack);
-extern void init_lapack_zlaed7(VALUE mLapack);
-extern void init_lapack_ztpttr(VALUE mLapack);
-extern void init_lapack_ctbtrs(VALUE mLapack);
-extern void init_lapack_dlahr2(VALUE mLapack);
-extern void init_lapack_sorm2r(VALUE mLapack);
-extern void init_lapack_sgetf2(VALUE mLapack);
-extern void init_lapack_zpbtf2(VALUE mLapack);
-extern void init_lapack_cggesx(VALUE mLapack);
-extern void init_lapack_zlaqr2(VALUE mLapack);
-extern void init_lapack_dgeql2(VALUE mLapack);
-extern void init_lapack_spbrfs(VALUE mLapack);
-extern void init_lapack_dgerq2(VALUE mLapack);
-extern void init_lapack_dgelq2(VALUE mLapack);
-extern void init_lapack_zcposv(VALUE mLapack);
-extern void init_lapack_zhbgv(VALUE mLapack);
-extern void init_lapack_dgetri(VALUE mLapack);
-extern void init_lapack_zspsv(VALUE mLapack);
-extern void init_lapack_cla_gbrpvgrw(VALUE mLapack);
-extern void init_lapack_dgehd2(VALUE mLapack);
-extern void init_lapack_stbtrs(VALUE mLapack);
-extern void init_lapack_zungtr(VALUE mLapack);
-extern void init_lapack_zspcon(VALUE mLapack);
-extern void init_lapack_sgebal(VALUE mLapack);
-extern void init_lapack_clarz(VALUE mLapack);
-extern void init_lapack_clals0(VALUE mLapack);
-extern void init_lapack_stpcon(VALUE mLapack);
-extern void init_lapack_dsytrf(VALUE mLapack);
-extern void init_lapack_slaeda(VALUE mLapack);
-extern void init_lapack_dpteqr(VALUE mLapack);
-extern void init_lapack_zgtsv(VALUE mLapack);
-extern void init_lapack_sgges(VALUE mLapack);
-extern void init_lapack_cptcon(VALUE mLapack);
-extern void init_lapack_chesvx(VALUE mLapack);
-extern void init_lapack_cpftri(VALUE mLapack);
-extern void init_lapack_dpbrfs(VALUE mLapack);
-extern void init_lapack_sla_gerfsx_extended(VALUE mLapack);
-extern void init_lapack_sla_wwaddw(VALUE mLapack);
-extern void init_lapack_zlatrd(VALUE mLapack);
-extern void init_lapack_dsytf2(VALUE mLapack);
-extern void init_lapack_csytrs(VALUE mLapack);
-extern void init_lapack_cla_gbamv(VALUE mLapack);
-extern void init_lapack_lsamen(VALUE mLapack);
-extern void init_lapack_sla_porfsx_extended(VALUE mLapack);
-extern void init_lapack_iladiag(VALUE mLapack);
-extern void init_lapack_clascl2(VALUE mLapack);
-extern void init_lapack_cheequb(VALUE mLapack);
-extern void init_lapack_cpprfs(VALUE mLapack);
-extern void init_lapack_dormr2(VALUE mLapack);
-extern void init_lapack_zhpsv(VALUE mLapack);
-extern void init_lapack_sgbbrd(VALUE mLapack);
-extern void init_lapack_dsptrs(VALUE mLapack);
-extern void init_lapack_csymv(VALUE mLapack);
-extern void init_lapack_ztrcon(VALUE mLapack);
-extern void init_lapack_cppsvx(VALUE mLapack);
-extern void init_lapack_clartv(VALUE mLapack);
-extern void init_lapack_slag2(VALUE mLapack);
-extern void init_lapack_dlasd5(VALUE mLapack);
-extern void init_lapack_chseqr(VALUE mLapack);
-extern void init_lapack_ssbgvd(VALUE mLapack);
-extern void init_lapack_clacrt(VALUE mLapack);
-extern void init_lapack_zhetrd(VALUE mLapack);
-extern void init_lapack_sgetc2(VALUE mLapack);
-extern void init_lapack_dptsvx(VALUE mLapack);
-extern void init_lapack_slange(VALUE mLapack);
-extern void init_lapack_zlatrz(VALUE mLapack);
-extern void init_lapack_cunmbr(VALUE mLapack);
-extern void init_lapack_zpstrf(VALUE mLapack);
-extern void init_lapack_slartg(VALUE mLapack);
-extern void init_lapack_zlahef(VALUE mLapack);
-extern void init_lapack_dlascl(VALUE mLapack);
-extern void init_lapack_zlarf(VALUE mLapack);
-extern void init_lapack_sspcon(VALUE mLapack);
-extern void init_lapack_cpbsvx(VALUE mLapack);
-extern void init_lapack_dlaed7(VALUE mLapack);
-extern void init_lapack_slapmr(VALUE mLapack);
-extern void init_lapack_zsytf2(VALUE mLapack);
-extern void init_lapack_ztrrfs(VALUE mLapack);
-extern void init_lapack_cggevx(VALUE mLapack);
-extern void init_lapack_zsyrfsx(VALUE mLapack);
-extern void init_lapack_cla_gbrfsx_extended(VALUE mLapack);
-extern void init_lapack_dptcon(VALUE mLapack);
-extern void init_lapack_sggev(VALUE mLapack);
-extern void init_lapack_ilaslr(VALUE mLapack);
-extern void init_lapack_dhgeqz(VALUE mLapack);
-extern void init_lapack_sgghrd(VALUE mLapack);
-extern void init_lapack_zsysv(VALUE mLapack);
-extern void init_lapack_stbrfs(VALUE mLapack);
-extern void init_lapack_claqsy(VALUE mLapack);
-extern void init_lapack_clalsa(VALUE mLapack);
-extern void init_lapack_zla_wwaddw(VALUE mLapack);
-extern void init_lapack_sla_syrpvgrw(VALUE mLapack);
-extern void init_lapack_ilaclr(VALUE mLapack);
-extern void init_lapack_slasq5(VALUE mLapack);
-extern void init_lapack_sorbdb(VALUE mLapack);
-extern void init_lapack_dtprfs(VALUE mLapack);
-extern void init_lapack_chegs2(VALUE mLapack);
-extern void init_lapack_ssbev(VALUE mLapack);
-extern void init_lapack_strttp(VALUE mLapack);
-extern void init_lapack_zhgeqz(VALUE mLapack);
-extern void init_lapack_zlaqsp(VALUE mLapack);
-extern void init_lapack_zgbequ(VALUE mLapack);
-extern void init_lapack_claswp(VALUE mLapack);
-extern void init_lapack_dlaqr1(VALUE mLapack);
-extern void init_lapack_cpstf2(VALUE mLapack);
-extern void init_lapack_claev2(VALUE mLapack);
-extern void init_lapack_cgeqpf(VALUE mLapack);
-extern void init_lapack_sgesv(VALUE mLapack);
-extern void init_lapack_zgesvx(VALUE mLapack);
-extern void init_lapack_stfttp(VALUE mLapack);
-extern void init_lapack_dggbak(VALUE mLapack);
-extern void init_lapack_zla_herpvgrw(VALUE mLapack);
-extern void init_lapack_zppcon(VALUE mLapack);
-extern void init_lapack_dlansp(VALUE mLapack);
-extern void init_lapack_slarnv(VALUE mLapack);
-extern void init_lapack_cla_syrcond_x(VALUE mLapack);
-extern void init_lapack_cunmr3(VALUE mLapack);
-extern void init_lapack_zgbtrf(VALUE mLapack);
-extern void init_lapack_dlarscl2(VALUE mLapack);
-extern void init_lapack_zlaqsb(VALUE mLapack);
-extern void init_lapack_dsyevx(VALUE mLapack);
-extern void init_lapack_dgerqf(VALUE mLapack);
-extern void init_lapack_dgbequb(VALUE mLapack);
-extern void init_lapack_zlacpy(VALUE mLapack);
-extern void init_lapack_claein(VALUE mLapack);
-extern void init_lapack_dlat2s(VALUE mLapack);
-extern void init_lapack_cgehd2(VALUE mLapack);
-extern void init_lapack_ssyconv(VALUE mLapack);
-extern void init_lapack_dgeqrf(VALUE mLapack);
-extern void init_lapack_slabrd(VALUE mLapack);
-extern void init_lapack_cgtrfs(VALUE mLapack);
-extern void init_lapack_sgbtrs(VALUE mLapack);
-extern void init_lapack_slangb(VALUE mLapack);
-extern void init_lapack_zgbequb(VALUE mLapack);
-extern void init_lapack_dsytri2(VALUE mLapack);
-extern void init_lapack_slarrk(VALUE mLapack);
-extern void init_lapack_chsein(VALUE mLapack);
-extern void init_lapack_sgebrd(VALUE mLapack);
-extern void init_lapack_zlarfb(VALUE mLapack);
-extern void init_lapack_slasda(VALUE mLapack);
-extern void init_lapack_cpbstf(VALUE mLapack);
-extern void init_lapack_zlacon(VALUE mLapack);
-extern void init_lapack_dtrsen(VALUE mLapack);
-extern void init_lapack_clarnv(VALUE mLapack);
-extern void init_lapack_slagtm(VALUE mLapack);
-extern void init_lapack_sgerq2(VALUE mLapack);
-extern void init_lapack_dormqr(VALUE mLapack);
-extern void init_lapack_dlaqr5(VALUE mLapack);
-extern void init_lapack_zpttrf(VALUE mLapack);
-extern void init_lapack_ztrsna(VALUE mLapack);
-extern void init_lapack_dgejsv(VALUE mLapack);
-extern void init_lapack_dtptrs(VALUE mLapack);
-extern void init_lapack_cposvx(VALUE mLapack);
-extern void init_lapack_claed8(VALUE mLapack);
-extern void init_lapack_ctrti2(VALUE mLapack);
-extern void init_lapack_sormr2(VALUE mLapack);
-extern void init_lapack_dlaqp2(VALUE mLapack);
-extern void init_lapack_stgsna(VALUE mLapack);
-extern void init_lapack_dlascl2(VALUE mLapack);
-extern void init_lapack_cgecon(VALUE mLapack);
-extern void init_lapack_zsyswapr(VALUE mLapack);
-extern void init_lapack_zgeqr2p(VALUE mLapack);
-extern void init_lapack_stpttr(VALUE mLapack);
-extern void init_lapack_dlansb(VALUE mLapack);
-extern void init_lapack_zungqr(VALUE mLapack);
-extern void init_lapack_zsyconv(VALUE mLapack);
-extern void init_lapack_zunmr2(VALUE mLapack);
-extern void init_lapack_slasy2(VALUE mLapack);
-extern void init_lapack_dsbevx(VALUE mLapack);
-extern void init_lapack_dsyrfsx(VALUE mLapack);
-extern void init_lapack_cgeqp3(VALUE mLapack);
-extern void init_lapack_stprfs(VALUE mLapack);
-extern void init_lapack_zpoequ(VALUE mLapack);
-extern void init_lapack_zlahqr(VALUE mLapack);
-extern void init_lapack_zunmrz(VALUE mLapack);
-extern void init_lapack_claqr2(VALUE mLapack);
-extern void init_lapack_slaqr0(VALUE mLapack);
-extern void init_lapack_ztprfs(VALUE mLapack);
-extern void init_lapack_ztgexc(VALUE mLapack);
-extern void init_lapack_dorglq(VALUE mLapack);
-extern void init_lapack_dgelsy(VALUE mLapack);
-extern void init_lapack_ilaprec(VALUE mLapack);
-extern void init_lapack_ssyrfsx(VALUE mLapack);
-extern void init_lapack_zlaqhe(VALUE mLapack);
-extern void init_lapack_csptrs(VALUE mLapack);
-extern void init_lapack_spftri(VALUE mLapack);
-extern void init_lapack_shseqr(VALUE mLapack);
-extern void init_lapack_zlaed8(VALUE mLapack);
-extern void init_lapack_chbevd(VALUE mLapack);
-extern void init_lapack_dsyev(VALUE mLapack);
-extern void init_lapack_dspgvx(VALUE mLapack);
-extern void init_lapack_zgtsvx(VALUE mLapack);
-extern void init_lapack_sgegv(VALUE mLapack);
-extern void init_lapack_slantb(VALUE mLapack);
-extern void init_lapack_zla_syrcond_x(VALUE mLapack);
-extern void init_lapack_dlar1v(VALUE mLapack);
-extern void init_lapack_zgeesx(VALUE mLapack);
-extern void init_lapack_stgex2(VALUE mLapack);
-extern void init_lapack_ctgsna(VALUE mLapack);
-extern void init_lapack_dlauum(VALUE mLapack);
-extern void init_lapack_cgetf2(VALUE mLapack);
-extern void init_lapack_dtgsna(VALUE mLapack);
-extern void init_lapack_crot(VALUE mLapack);
-extern void init_lapack_zpotrs(VALUE mLapack);
-extern void init_lapack_cpftrf(VALUE mLapack);
-extern void init_lapack_zgbsv(VALUE mLapack);
-extern void init_lapack_cpttrs(VALUE mLapack);
-extern void init_lapack_slarfx(VALUE mLapack);
-extern void init_lapack_chprfs(VALUE mLapack);
-extern void init_lapack_sgecon(VALUE mLapack);
-extern void init_lapack_dlartgp(VALUE mLapack);
-extern void init_lapack_dgebak(VALUE mLapack);
-extern void init_lapack_ssbtrd(VALUE mLapack);
-extern void init_lapack_cggbal(VALUE mLapack);
-extern void init_lapack_dlaed2(VALUE mLapack);
-extern void init_lapack_zgbbrd(VALUE mLapack);
-extern void init_lapack_dorg2l(VALUE mLapack);
-extern void init_lapack_dsygs2(VALUE mLapack);
-extern void init_lapack_ssyev(VALUE mLapack);
-extern void init_lapack_dgerfs(VALUE mLapack);
-extern void init_lapack_cpbtrs(VALUE mLapack);
-extern void init_lapack_zlaesy(VALUE mLapack);
-extern void init_lapack_zla_herfsx_extended(VALUE mLapack);
-extern void init_lapack_dspcon(VALUE mLapack);
-extern void init_lapack_slaqge(VALUE mLapack);
-extern void init_lapack_cposv(VALUE mLapack);
-extern void init_lapack_dppcon(VALUE mLapack);
-extern void init_lapack_sgeequ(VALUE mLapack);
-extern void init_lapack_slamrg(VALUE mLapack);
-extern void init_lapack_dgesvx(VALUE mLapack);
-extern void init_lapack_zgegs(VALUE mLapack);
-extern void init_lapack_dlaset(VALUE mLapack);
-extern void init_lapack_sstevx(VALUE mLapack);
-extern void init_lapack_dtgsyl(VALUE mLapack);
-extern void init_lapack_zposv(VALUE mLapack);
-extern void init_lapack_zhpgvd(VALUE mLapack);
-extern void init_lapack_dlargv(VALUE mLapack);
-extern void init_lapack_sgeev(VALUE mLapack);
-extern void init_lapack_clahqr(VALUE mLapack);
-extern void init_lapack_cgbtrf(VALUE mLapack);
-extern void init_lapack_dsytrs(VALUE mLapack);
-extern void init_lapack_ztgsy2(VALUE mLapack);
-extern void init_lapack_zlatzm(VALUE mLapack);
-extern void init_lapack_zgetrs(VALUE mLapack);
-extern void init_lapack_slarfgp(VALUE mLapack);
-extern void init_lapack_zunmbr(VALUE mLapack);
-extern void init_lapack_dlagts(VALUE mLapack);
-extern void init_lapack_zgeev(VALUE mLapack);
-extern void init_lapack_zlar2v(VALUE mLapack);
-extern void init_lapack_sorgbr(VALUE mLapack);
-extern void init_lapack_sggsvd(VALUE mLapack);
-extern void init_lapack_chbgst(VALUE mLapack);
-extern void init_lapack_zheevd(VALUE mLapack);
-extern void init_lapack_dgesvxx(VALUE mLapack);
-extern void init_lapack_sla_porpvgrw(VALUE mLapack);
-extern void init_lapack_slaed5(VALUE mLapack);
-extern void init_lapack_clarf(VALUE mLapack);
-extern void init_lapack_clascl(VALUE mLapack);
-extern void init_lapack_dgbrfsx(VALUE mLapack);
-extern void init_lapack_cunml2(VALUE mLapack);
-extern void init_lapack_ctrcon(VALUE mLapack);
-extern void init_lapack_dsygst(VALUE mLapack);
-extern void init_lapack_zla_rpvgrw(VALUE mLapack);
-extern void init_lapack_dlaed4(VALUE mLapack);
-extern void init_lapack_zlaqr4(VALUE mLapack);
-extern void init_lapack_csysvxx(VALUE mLapack);
-extern void init_lapack_zpoequb(VALUE mLapack);
-extern void init_lapack_zgghrd(VALUE mLapack);
-extern void init_lapack_chptrf(VALUE mLapack);
-extern void init_lapack_dgsvj1(VALUE mLapack);
-extern void init_lapack_dhseqr(VALUE mLapack);
-extern void init_lapack_dlasv2(VALUE mLapack);
-extern void init_lapack_cpteqr(VALUE mLapack);
-extern void init_lapack_sggsvp(VALUE mLapack);
-extern void init_lapack_cspsvx(VALUE mLapack);
-extern void init_lapack_zungql(VALUE mLapack);
-extern void init_lapack_ztrttp(VALUE mLapack);
-extern void init_lapack_zgelsd(VALUE mLapack);
-extern void init_lapack_dlaein(VALUE mLapack);
-extern void init_lapack_slaqr2(VALUE mLapack);
-extern void init_lapack_dlagtm(VALUE mLapack);
-extern void init_lapack_dlasd1(VALUE mLapack);
-extern void init_lapack_zla_syamv(VALUE mLapack);
-extern void init_lapack_cpptrf(VALUE mLapack);
-extern void init_lapack_dlaed5(VALUE mLapack);
-extern void init_lapack_cgbrfs(VALUE mLapack);
-extern void init_lapack_dlaqr4(VALUE mLapack);
-extern void init_lapack_cgesv(VALUE mLapack);
-extern void init_lapack_checon(VALUE mLapack);
-extern void init_lapack_zgelqf(VALUE mLapack);
-extern void init_lapack_zlansb(VALUE mLapack);
-extern void init_lapack_zla_porcond_x(VALUE mLapack);
-extern void init_lapack_slarrf(VALUE mLapack);
-extern void init_lapack_strti2(VALUE mLapack);
-extern void init_lapack_sorm2l(VALUE mLapack);
-extern void init_lapack_zhpevd(VALUE mLapack);
-extern void init_lapack_zposvxx(VALUE mLapack);
-extern void init_lapack_csyswapr(VALUE mLapack);
-extern void init_lapack_sptsv(VALUE mLapack);
-extern void init_lapack_zstemr(VALUE mLapack);
-extern void init_lapack_zhetf2(VALUE mLapack);
-extern void init_lapack_dtbcon(VALUE mLapack);
-extern void init_lapack_dlaev2(VALUE mLapack);
-extern void init_lapack_ssysv(VALUE mLapack);
-extern void init_lapack_dla_gbrpvgrw(VALUE mLapack);
-extern void init_lapack_cgtts2(VALUE mLapack);
-extern void init_lapack_dsyconv(VALUE mLapack);
-extern void init_lapack_cgtcon(VALUE mLapack);
-extern void init_lapack_zlantb(VALUE mLapack);
-extern void init_lapack_sormrz(VALUE mLapack);
-extern void init_lapack_zgeqrfp(VALUE mLapack);
-extern void init_lapack_sgeqrfp(VALUE mLapack);
-extern void init_lapack_zgges(VALUE mLapack);
-extern void init_lapack_slassq(VALUE mLapack);
-extern void init_lapack_stftri(VALUE mLapack);
-extern void init_lapack_ssytrf(VALUE mLapack);
-extern void init_lapack_sgebak(VALUE mLapack);
-extern void init_lapack_ztbcon(VALUE mLapack);
-extern void init_lapack_ssygst(VALUE mLapack);
-extern void init_lapack_dbbcsd(VALUE mLapack);
-extern void init_lapack_spbsv(VALUE mLapack);
-extern void init_lapack_csyrfsx(VALUE mLapack);
-extern void init_lapack_slaev2(VALUE mLapack);
-extern void init_lapack_dgbsvxx(VALUE mLapack);
-extern void init_lapack_zcgesv(VALUE mLapack);
-extern void init_lapack_zsyr(VALUE mLapack);
-extern void init_lapack_slas2(VALUE mLapack);
-extern void init_lapack_clauum(VALUE mLapack);
-extern void init_lapack_zspmv(VALUE mLapack);
-extern void init_lapack_csyrfs(VALUE mLapack);
-extern void init_lapack_clatzm(VALUE mLapack);
-extern void init_lapack_claqr0(VALUE mLapack);
-extern void init_lapack_dgbsv(VALUE mLapack);
-extern void init_lapack_ilauplo(VALUE mLapack);
-extern void init_lapack_cla_gbrcond_c(VALUE mLapack);
-extern void init_lapack_zheevx(VALUE mLapack);
-extern void init_lapack_csptrf(VALUE mLapack);
-extern void init_lapack_cladiv(VALUE mLapack);
-extern void init_lapack_spstf2(VALUE mLapack);
-extern void init_lapack_claqhp(VALUE mLapack);
-extern void init_lapack_dla_rpvgrw(VALUE mLapack);
-extern void init_lapack_dgtcon(VALUE mLapack);
-extern void init_lapack_zlaqp2(VALUE mLapack);
-extern void init_lapack_slapy2(VALUE mLapack);
-extern void init_lapack_spptri(VALUE mLapack);
-extern void init_lapack_sptcon(VALUE mLapack);
-extern void init_lapack_ssbevd(VALUE mLapack);
-extern void init_lapack_cggbak(VALUE mLapack);
-extern void init_lapack_cunmr2(VALUE mLapack);
-extern void init_lapack_dgesvj(VALUE mLapack);
-extern void init_lapack_cpptri(VALUE mLapack);
-extern void init_lapack_slarzt(VALUE mLapack);
-extern void init_lapack_zla_porpvgrw(VALUE mLapack);
-extern void init_lapack_dla_syamv(VALUE mLapack);
-extern void init_lapack_zlartg(VALUE mLapack);
-extern void init_lapack_ieeeck(VALUE mLapack);
-extern void init_lapack_sgeqr2p(VALUE mLapack);
-extern void init_lapack_slasq6(VALUE mLapack);
-extern void init_lapack_zgesv(VALUE mLapack);
-extern void init_lapack_shgeqz(VALUE mLapack);
-extern void init_lapack_ctrevc(VALUE mLapack);
-extern void init_lapack_sgegs(VALUE mLapack);
-extern void init_lapack_cporfs(VALUE mLapack);
-extern void init_lapack_dlasq1(VALUE mLapack);
-extern void init_lapack_dsysvxx(VALUE mLapack);
-extern void init_lapack_chbgvx(VALUE mLapack);
-extern void init_lapack_zgelsx(VALUE mLapack);
-extern void init_lapack_zggsvp(VALUE mLapack);
-extern void init_lapack_sppsvx(VALUE mLapack);
-extern void init_lapack_cgelsd(VALUE mLapack);
-extern void init_lapack_dpocon(VALUE mLapack);
-extern void init_lapack_sopgtr(VALUE mLapack);
-extern void init_lapack_slarre(VALUE mLapack);
-extern void init_lapack_zlargv(VALUE mLapack);
-extern void init_lapack_cpptrs(VALUE mLapack);
-extern void init_lapack_zuncsd(VALUE mLapack);
-extern void init_lapack_zunmtr(VALUE mLapack);
-extern void init_lapack_cgees(VALUE mLapack);
-extern void init_lapack_stgsy2(VALUE mLapack);
-extern void init_lapack_dlasd0(VALUE mLapack);
-extern void init_lapack_slasd0(VALUE mLapack);
-extern void init_lapack_dsbevd(VALUE mLapack);
-extern void init_lapack_cgbsv(VALUE mLapack);
-extern void init_lapack_dla_porcond(VALUE mLapack);
-extern void init_lapack_cptsvx(VALUE mLapack);
-extern void init_lapack_chetrf(VALUE mLapack);
-extern void init_lapack_sgtsvx(VALUE mLapack);
-extern void init_lapack_clacon(VALUE mLapack);
-extern void init_lapack_dpftrs(VALUE mLapack);
-extern void init_lapack_xerbla(VALUE mLapack);
-extern void init_lapack_clatrz(VALUE mLapack);
-extern void init_lapack_ctrsyl(VALUE mLapack);
-extern void init_lapack_cgges(VALUE mLapack);
-extern void init_lapack_cgetrs(VALUE mLapack);
-extern void init_lapack_sormtr(VALUE mLapack);
-extern void init_lapack_chpevx(VALUE mLapack);
-extern void init_lapack_dla_lin_berr(VALUE mLapack);
-extern void init_lapack_csyequb(VALUE mLapack);
-extern void init_lapack_ztrtri(VALUE mLapack);
-extern void init_lapack_chpevd(VALUE mLapack);
-extern void init_lapack_sgees(VALUE mLapack);
-extern void init_lapack_csytri2x(VALUE mLapack);
-extern void init_lapack_zsyrfs(VALUE mLapack);
-extern void init_lapack_zlanhs(VALUE mLapack);
-extern void init_lapack_dgbbrd(VALUE mLapack);
-extern void init_lapack_slangt(VALUE mLapack);
-extern void init_lapack_clalsd(VALUE mLapack);
-extern void init_lapack_ctrsen(VALUE mLapack);
-extern void init_lapack_dpoequb(VALUE mLapack);
-extern void init_lapack_dla_gerfsx_extended(VALUE mLapack);
-extern void init_lapack_zggsvd(VALUE mLapack);
-extern void init_lapack_dtpcon(VALUE mLapack);
-extern void init_lapack_ztgsja(VALUE mLapack);
-extern void init_lapack_zlacrt(VALUE mLapack);
-extern void init_lapack_dlarrr(VALUE mLapack);
-extern void init_lapack_dormrq(VALUE mLapack);
-extern void init_lapack_cungrq(VALUE mLapack);
-extern void init_lapack_zlals0(VALUE mLapack);
-extern void init_lapack_cgebrd(VALUE mLapack);
-extern void init_lapack_cpbtrf(VALUE mLapack);
-extern void init_lapack_clargv(VALUE mLapack);
-extern void init_lapack_dstevr(VALUE mLapack);
-extern void init_lapack_dlasd4(VALUE mLapack);
-extern void init_lapack_cpotrf(VALUE mLapack);
-extern void init_lapack_sgbsvx(VALUE mLapack);
-extern void init_lapack_zhbevx(VALUE mLapack);
-extern void init_lapack_dpptrs(VALUE mLapack);
-extern void init_lapack_sporfs(VALUE mLapack);
-extern void init_lapack_clabrd(VALUE mLapack);
-extern void init_lapack_ssyevx(VALUE mLapack);
-extern void init_lapack_cptsv(VALUE mLapack);
-extern void init_lapack_ctptri(VALUE mLapack);
-extern void init_lapack_slasr(VALUE mLapack);
-extern void init_lapack_dtgsen(VALUE mLapack);
-extern void init_lapack_cunghr(VALUE mLapack);
-extern void init_lapack_clatps(VALUE mLapack);
-extern void init_lapack_stgsja(VALUE mLapack);
-extern void init_lapack_zsysvx(VALUE mLapack);
-extern void init_lapack_ssygs2(VALUE mLapack);
-extern void init_lapack_zlanhe(VALUE mLapack);
-extern void init_lapack_sgelq2(VALUE mLapack);
-extern void init_lapack_cunmrz(VALUE mLapack);
-extern void init_lapack_ssygv(VALUE mLapack);
-extern void init_lapack_slabad(VALUE mLapack);
-extern void init_lapack_clar1v(VALUE mLapack);
-extern void init_lapack_sspgv(VALUE mLapack);
-extern void init_lapack_sgbrfs(VALUE mLapack);
-extern void init_lapack_dlasd2(VALUE mLapack);
-extern void init_lapack_clanhb(VALUE mLapack);
-extern void init_lapack_dorg2r(VALUE mLapack);
-extern void init_lapack_dla_geamv(VALUE mLapack);
-extern void init_lapack_clangt(VALUE mLapack);
-extern void init_lapack_dgebal(VALUE mLapack);
-extern void init_lapack_cla_gerfsx_extended(VALUE mLapack);
-extern void init_lapack_slaed0(VALUE mLapack);
-extern void init_lapack_cla_wwaddw(VALUE mLapack);
-extern void init_lapack_sstegr(VALUE mLapack);
-extern void init_lapack_dggesx(VALUE mLapack);
-extern void init_lapack_slansf(VALUE mLapack);
-extern void init_lapack_slaein(VALUE mLapack);
-extern void init_lapack_ztrttf(VALUE mLapack);
-extern void init_lapack_dlatdf(VALUE mLapack);
-extern void init_lapack_zlatdf(VALUE mLapack);
-extern void init_lapack_sgeql2(VALUE mLapack);
-extern void init_lapack_zlacn2(VALUE mLapack);
-extern void init_lapack_sgeesx(VALUE mLapack);
-extern void init_lapack_dggglm(VALUE mLapack);
-extern void init_lapack_dlaqsy(VALUE mLapack);
-extern void init_lapack_dpotrs(VALUE mLapack);
-extern void init_lapack_zsprfs(VALUE mLapack);
-extern void init_lapack_slasd7(VALUE mLapack);
-extern void init_lapack_cla_geamv(VALUE mLapack);
-extern void init_lapack_zsytrs(VALUE mLapack);
-extern void init_lapack_cla_syrfsx_extended(VALUE mLapack);
-extern void init_lapack_dgges(VALUE mLapack);
-extern void init_lapack_dgeqrfp(VALUE mLapack);
-extern void init_lapack_slaset(VALUE mLapack);
-extern void init_lapack_zhetrs(VALUE mLapack);
-extern void init_lapack_dlacn2(VALUE mLapack);
-extern void init_lapack_cla_herfsx_extended(VALUE mLapack);
-extern void init_lapack_dsycon(VALUE mLapack);
-extern void init_lapack_dlarrc(VALUE mLapack);
-extern void init_lapack_zgbsvxx(VALUE mLapack);
-extern void init_lapack_dsptrf(VALUE mLapack);
-extern void init_lapack_sporfsx(VALUE mLapack);
-extern void init_lapack_ilaenv(VALUE mLapack);
-extern void init_lapack_strtrs(VALUE mLapack);
-extern void init_lapack_cppequ(VALUE mLapack);
-extern void init_lapack_slaed4(VALUE mLapack);
-extern void init_lapack_zlagtm(VALUE mLapack);
-extern void init_lapack_dormbr(VALUE mLapack);
-extern void init_lapack_dlarzb(VALUE mLapack);
-extern void init_lapack_zhetrf(VALUE mLapack);
-extern void init_lapack_clartg(VALUE mLapack);
-extern void init_lapack_dsterf(VALUE mLapack);
-extern void init_lapack_zhpgst(VALUE mLapack);
-extern void init_lapack_ctgex2(VALUE mLapack);
-extern void init_lapack_clange(VALUE mLapack);
-extern void init_lapack_dlaed3(VALUE mLapack);
-extern void init_lapack_dsgesv(VALUE mLapack);
-extern void init_lapack_dpftri(VALUE mLapack);
-extern void init_lapack_dggbal(VALUE mLapack);
-extern void init_lapack_dspevx(VALUE mLapack);
-extern void init_lapack_slansb(VALUE mLapack);
-extern void init_lapack_sgglse(VALUE mLapack);
-extern void init_lapack_cpotf2(VALUE mLapack);
-extern void init_lapack_dpbtrs(VALUE mLapack);
-extern void init_lapack_clarfb(VALUE mLapack);
-extern void init_lapack_clanhs(VALUE mLapack);
-extern void init_lapack_sla_gbrfsx_extended(VALUE mLapack);
-extern void init_lapack_zlatrs(VALUE mLapack);
-extern void init_lapack_ztrsyl(VALUE mLapack);
-extern void init_lapack_slalsa(VALUE mLapack);
-extern void init_lapack_csytf2(VALUE mLapack);
-extern void init_lapack_zlarft(VALUE mLapack);
-extern void init_lapack_dlabrd(VALUE mLapack);
-extern void init_lapack_sspsvx(VALUE mLapack);
-extern void init_lapack_zhseqr(VALUE mLapack);
-extern void init_lapack_zgelq2(VALUE mLapack);
-extern void init_lapack_zherfs(VALUE mLapack);
-extern void init_lapack_dtfttp(VALUE mLapack);
-extern void init_lapack_zlasr(VALUE mLapack);
-extern void init_lapack_stptrs(VALUE mLapack);
-extern void init_lapack_sla_syamv(VALUE mLapack);
-extern void init_lapack_cgeqr2p(VALUE mLapack);
-extern void init_lapack_sstev(VALUE mLapack);
-extern void init_lapack_sgesvxx(VALUE mLapack);
-extern void init_lapack_ssptrs(VALUE mLapack);
-extern void init_lapack_cunmqr(VALUE mLapack);
-extern void init_lapack_zhpgv(VALUE mLapack);
-extern void init_lapack_zlalsd(VALUE mLapack);
-extern void init_lapack_clansy(VALUE mLapack);
-extern void init_lapack_ssyevd(VALUE mLapack);
-extern void init_lapack_ssyrfs(VALUE mLapack);
-extern void init_lapack_claqsb(VALUE mLapack);
-extern void init_lapack_cunmrq(VALUE mLapack);
-extern void init_lapack_sgeqlf(VALUE mLapack);
-extern void init_lapack_ztrtrs(VALUE mLapack);
-extern void init_lapack_dpbequ(VALUE mLapack);
-extern void init_lapack_zggbal(VALUE mLapack);
-extern void init_lapack_dspgv(VALUE mLapack);
-extern void init_lapack_dlarrf(VALUE mLapack);
-extern void init_lapack_dpbstf(VALUE mLapack);
-extern void init_lapack_zgesvd(VALUE mLapack);
-extern void init_lapack_cgbbrd(VALUE mLapack);
-extern void init_lapack_ssytd2(VALUE mLapack);
-extern void init_lapack_zupgtr(VALUE mLapack);
-extern void init_lapack_slantp(VALUE mLapack);
-extern void init_lapack_ssbevx(VALUE mLapack);
-extern void init_lapack_ctrsna(VALUE mLapack);
-extern void init_lapack_zlarfg(VALUE mLapack);
-extern void init_lapack_slasq2(VALUE mLapack);
-extern void init_lapack_zherfsx(VALUE mLapack);
-extern void init_lapack_clarfx(VALUE mLapack);
-extern void init_lapack_zpptrf(VALUE mLapack);
-extern void init_lapack_zggevx(VALUE mLapack);
-extern void init_lapack_chpgv(VALUE mLapack);
-extern void init_lapack_slarft(VALUE mLapack);
-extern void init_lapack_sgesdd(VALUE mLapack);
-extern void init_lapack_zsytri2x(VALUE mLapack);
-extern void init_lapack_dsytri(VALUE mLapack);
-extern void init_lapack_spocon(VALUE mLapack);
-extern void init_lapack_sgtts2(VALUE mLapack);
-extern void init_lapack_sgesvd(VALUE mLapack);
-extern void init_lapack_clantp(VALUE mLapack);
-extern void init_lapack_dlalsd(VALUE mLapack);
-extern void init_lapack_ctrtri(VALUE mLapack);
-extern void init_lapack_cstemr(VALUE mLapack);
-extern void init_lapack_zlanht(VALUE mLapack);
-extern void init_lapack_ctptrs(VALUE mLapack);
-extern void init_lapack_dlarrv(VALUE mLapack);
-extern void init_lapack_ztgex2(VALUE mLapack);
-extern void init_lapack_sla_porcond(VALUE mLapack);
-extern void init_lapack_zgeqlf(VALUE mLapack);
-extern void init_lapack_dlaexc(VALUE mLapack);
-extern void init_lapack_zgecon(VALUE mLapack);
-extern void init_lapack_cgghrd(VALUE mLapack);
-extern void init_lapack_sggesx(VALUE mLapack);
-extern void init_lapack_dtrevc(VALUE mLapack);
-extern void init_lapack_spotf2(VALUE mLapack);
-extern void init_lapack_cgelsx(VALUE mLapack);
-extern void init_lapack_zhesv(VALUE mLapack);
-extern void init_lapack_zhegs2(VALUE mLapack);
-extern void init_lapack_strrfs(VALUE mLapack);
-extern void init_lapack_zlarz(VALUE mLapack);
-extern void init_lapack_dsbgst(VALUE mLapack);
-extern void init_lapack_dopgtr(VALUE mLapack);
-extern void init_lapack_zlaic1(VALUE mLapack);
-extern void init_lapack_iladlc(VALUE mLapack);
-extern void init_lapack_dla_gercond(VALUE mLapack);
-extern void init_lapack_sla_geamv(VALUE mLapack);
-extern void init_lapack_dgegs(VALUE mLapack);
-extern void init_lapack_zungr2(VALUE mLapack);
-extern void init_lapack_dlaqgb(VALUE mLapack);
-extern void init_lapack_zhptrd(VALUE mLapack);
-extern void init_lapack_dorgrq(VALUE mLapack);
-extern void init_lapack_csysv(VALUE mLapack);
-extern void init_lapack_slaqsb(VALUE mLapack);
-extern void init_lapack_zlaqr3(VALUE mLapack);
-extern void init_lapack_sspgvx(VALUE mLapack);
-extern void init_lapack_chetrd(VALUE mLapack);
-extern void init_lapack_chetd2(VALUE mLapack);
-extern void init_lapack_zgetc2(VALUE mLapack);
-extern void init_lapack_sstevd(VALUE mLapack);
-extern void init_lapack_dsyevd(VALUE mLapack);
-extern void init_lapack_dpotrf(VALUE mLapack);
-extern void init_lapack_dpstf2(VALUE mLapack);
-extern void init_lapack_zhegvd(VALUE mLapack);
-extern void init_lapack_cungql(VALUE mLapack);
-extern void init_lapack_zgeqr2(VALUE mLapack);
-extern void init_lapack_zlaqge(VALUE mLapack);
-extern void init_lapack_cgesdd(VALUE mLapack);
-extern void init_lapack_sggbak(VALUE mLapack);
-extern void init_lapack_zhsein(VALUE mLapack);
-extern void init_lapack_zunbdb(VALUE mLapack);
-extern void init_lapack_clarfg(VALUE mLapack);
-extern void init_lapack_slansy(VALUE mLapack);
-extern void init_lapack_dstev(VALUE mLapack);
-extern void init_lapack_dgbtrs(VALUE mLapack);
-extern void init_lapack_zgeql2(VALUE mLapack);
-extern void init_lapack_slahqr(VALUE mLapack);
-extern void init_lapack_zheev(VALUE mLapack);
-extern void init_lapack_chbev(VALUE mLapack);
-extern void init_lapack_cgbrfsx(VALUE mLapack);
-extern void init_lapack_sppcon(VALUE mLapack);
-extern void init_lapack_zhesvxx(VALUE mLapack);
-extern void init_lapack_clantr(VALUE mLapack);
-extern void init_lapack_dpoequ(VALUE mLapack);
-extern void init_lapack_zgbsvx(VALUE mLapack);
-extern void init_lapack_zsyequb(VALUE mLapack);
-extern void init_lapack_ssytri2(VALUE mLapack);
-extern void init_lapack_zlarcm(VALUE mLapack);
-extern void init_lapack_chfrk(VALUE mLapack);
-extern void init_lapack_cgetrf(VALUE mLapack);
-extern void init_lapack_zhecon(VALUE mLapack);
-extern void init_lapack_spbtrf(VALUE mLapack);
-extern void init_lapack_zgerfsx(VALUE mLapack);
-extern void init_lapack_sppequ(VALUE mLapack);
-extern void init_lapack_cgttrs(VALUE mLapack);
-extern void init_lapack_dlarfgp(VALUE mLapack);
-extern void init_lapack_zgegv(VALUE mLapack);
-extern void init_lapack_zlags2(VALUE mLapack);
-extern void init_lapack_zungbr(VALUE mLapack);
-extern void init_lapack_dlarzt(VALUE mLapack);
-extern void init_lapack_clacpy(VALUE mLapack);
-extern void init_lapack_dorgr2(VALUE mLapack);
-extern void init_lapack_chetri(VALUE mLapack);
-extern void init_lapack_slaqgb(VALUE mLapack);
-extern void init_lapack_dlapmt(VALUE mLapack);
-extern void init_lapack_dlags2(VALUE mLapack);
-extern void init_lapack_sorghr(VALUE mLapack);
-extern void init_lapack_dggsvp(VALUE mLapack);
-extern void init_lapack_zlar1v(VALUE mLapack);
-extern void init_lapack_dlaqge(VALUE mLapack);
-extern void init_lapack_ilazlc(VALUE mLapack);
-extern void init_lapack_slarrv(VALUE mLapack);
-extern void init_lapack_sorgrq(VALUE mLapack);
-extern void init_lapack_sgtcon(VALUE mLapack);
-extern void init_lapack_dlapll(VALUE mLapack);
-extern void init_lapack_cgeevx(VALUE mLapack);
-extern void init_lapack_zla_gbrcond_x(VALUE mLapack);
-extern void init_lapack_zhegv(VALUE mLapack);
-extern void init_lapack_dlanv2(VALUE mLapack);
-extern void init_lapack_clapmr(VALUE mLapack);
-extern void init_lapack_dggevx(VALUE mLapack);
-extern void init_lapack_dlarfb(VALUE mLapack);
-extern void init_lapack_slapmt(VALUE mLapack);
-extern void init_lapack_chpsvx(VALUE mLapack);
-extern void init_lapack_dpbsv(VALUE mLapack);
-extern void init_lapack_cgeequb(VALUE mLapack);
-extern void init_lapack_slalsd(VALUE mLapack);
-extern void init_lapack_chegst(VALUE mLapack);
-extern void init_lapack_sspevd(VALUE mLapack);
-extern void init_lapack_claqhb(VALUE mLapack);
-extern void init_lapack_sorgr2(VALUE mLapack);
-extern void init_lapack_zupmtr(VALUE mLapack);
-extern void init_lapack_dorgtr(VALUE mLapack);
-extern void init_lapack_zgesc2(VALUE mLapack);
-extern void init_lapack_zlaswp(VALUE mLapack);
-extern void init_lapack_zsysvxx(VALUE mLapack);
-extern void init_lapack_dzsum1(VALUE mLapack);
-extern void init_lapack_dlaed6(VALUE mLapack);
-extern void init_lapack_zpftrs(VALUE mLapack);
-extern void init_lapack_strsyl(VALUE mLapack);
-extern void init_lapack_slarrc(VALUE mLapack);
-extern void init_lapack_zla_gercond_x(VALUE mLapack);
-extern void init_lapack_zhbgst(VALUE mLapack);
-extern void init_lapack_cla_porcond_c(VALUE mLapack);
-extern void init_lapack_dgeqr2p(VALUE mLapack);
-extern void init_lapack_sspev(VALUE mLapack);
-extern void init_lapack_cgbequb(VALUE mLapack);
-extern void init_lapack_sorgqr(VALUE mLapack);
-extern void init_lapack_dlarre(VALUE mLapack);
-extern void init_lapack_dtptri(VALUE mLapack);
-extern void init_lapack_zlatbs(VALUE mLapack);
-extern void init_lapack_zpprfs(VALUE mLapack);
-extern void init_lapack_dpbsvx(VALUE mLapack);
-extern void init_lapack_cstegr(VALUE mLapack);
-extern void init_lapack_dgbsvx(VALUE mLapack);
-extern void init_lapack_clatrs(VALUE mLapack);
-extern void init_lapack_sormr3(VALUE mLapack);
-extern void init_lapack_stpttf(VALUE mLapack);
-extern void init_lapack_zpftrf(VALUE mLapack);
-extern void init_lapack_dgehrd(VALUE mLapack);
-extern void init_lapack_dlag2(VALUE mLapack);
-extern void init_lapack_ztptrs(VALUE mLapack);
-extern void init_lapack_sstebz(VALUE mLapack);
-extern void init_lapack_dpstrf(VALUE mLapack);
-extern void init_lapack_zhptri(VALUE mLapack);
-extern void init_lapack_sgehrd(VALUE mLapack);
-extern void init_lapack_spbtrs(VALUE mLapack);
-extern void init_lapack_slaed3(VALUE mLapack);
-extern void init_lapack_cla_gercond_c(VALUE mLapack);
-extern void init_lapack_zlaqgb(VALUE mLapack);
-extern void init_lapack_dla_gbamv(VALUE mLapack);
-extern void init_lapack_ilazlr(VALUE mLapack);
-extern void init_lapack_chbgvd(VALUE mLapack);
-extern void init_lapack_ssysvx(VALUE mLapack);
-extern void init_lapack_clapmt(VALUE mLapack);
-extern void init_lapack_ctfttr(VALUE mLapack);
-extern void init_lapack_dlacpy(VALUE mLapack);
-extern void init_lapack_dtgevc(VALUE mLapack);
-extern void init_lapack_dtrttp(VALUE mLapack);
-extern void init_lapack_dtrsna(VALUE mLapack);
-extern void init_lapack_dgeesx(VALUE mLapack);
-extern void init_lapack_zlarfgp(VALUE mLapack);
-extern void init_lapack_slahr2(VALUE mLapack);
-extern void init_lapack_sgesvj(VALUE mLapack);
-extern void init_lapack_dspsvx(VALUE mLapack);
-extern void init_lapack_dlals0(VALUE mLapack);
-extern void init_lapack_sgelqf(VALUE mLapack);
-extern void init_lapack_sptsvx(VALUE mLapack);
-extern void init_lapack_cherfsx(VALUE mLapack);
-extern void init_lapack_ctprfs(VALUE mLapack);
-extern void init_lapack_dgelsd(VALUE mLapack);
-extern void init_lapack_dgbtrf(VALUE mLapack);
-extern void init_lapack_sla_gercond(VALUE mLapack);
-extern void init_lapack_zhbtrd(VALUE mLapack);
-extern void init_lapack_cung2l(VALUE mLapack);
-extern void init_lapack_zgeqrf(VALUE mLapack);
-extern void init_lapack_claqge(VALUE mLapack);
-extern void init_lapack_sstein(VALUE mLapack);
-extern void init_lapack_slaed2(VALUE mLapack);
-extern void init_lapack_csrscl(VALUE mLapack);
-extern void init_lapack_slaqtr(VALUE mLapack);
-extern void init_lapack_ctfsm(VALUE mLapack);
-extern void init_lapack_zlartv(VALUE mLapack);
-extern void init_lapack_dtrrfs(VALUE mLapack);
-extern void init_lapack_slatzm(VALUE mLapack);
-extern void init_lapack_dlarrd(VALUE mLapack);
-extern void init_lapack_dlaruv(VALUE mLapack);
-extern void init_lapack_dtfsm(VALUE mLapack);
-extern void init_lapack_clar2v(VALUE mLapack);
-extern void init_lapack_zlag2c(VALUE mLapack);
-extern void init_lapack_zpotf2(VALUE mLapack);
-extern void init_lapack_ilaver(VALUE mLapack);
-extern void init_lapack_zgttrf(VALUE mLapack);
-extern void init_lapack_sla_rpvgrw(VALUE mLapack);
-extern void init_lapack_dormhr(VALUE mLapack);
-extern void init_lapack_dlaqr0(VALUE mLapack);
-extern void init_lapack_cggqrf(VALUE mLapack);
-extern void init_lapack_zunml2(VALUE mLapack);
-extern void init_lapack_spptrf(VALUE mLapack);
-extern void init_lapack_claqr3(VALUE mLapack);
-extern void init_lapack_zlangt(VALUE mLapack);
-
-void Init_lapack(){
- VALUE mNumRu;
- VALUE mLapack;
-
- rb_require("narray");
-
- mNumRu = rb_define_module("NumRu");
- mLapack = rb_define_module_under(mNumRu, "Lapack");
-
- init_lapack_sgetri(mLapack);
- init_lapack_scsum1(mLapack);
- init_lapack_zgelsy(mLapack);
- init_lapack_chbgv(mLapack);
- init_lapack_slahrd(mLapack);
- init_lapack_zptts2(mLapack);
- init_lapack_dorgqr(mLapack);
- init_lapack_cspmv(mLapack);
- init_lapack_zggev(mLapack);
- init_lapack_cgerqf(mLapack);
- init_lapack_dpttrf(mLapack);
- init_lapack_zgerfs(mLapack);
- init_lapack_ctrrfs(mLapack);
- init_lapack_slartv(mLapack);
- init_lapack_dlarra(mLapack);
- init_lapack_dgesvd(mLapack);
- init_lapack_dspev(mLapack);
- init_lapack_zlaqps(mLapack);
- init_lapack_ztrevc(mLapack);
- init_lapack_cgeqrfp(mLapack);
- init_lapack_cunbdb(mLapack);
- init_lapack_ztrti2(mLapack);
- init_lapack_stzrzf(mLapack);
- init_lapack_dlaic1(mLapack);
- init_lapack_dlalsa(mLapack);
- init_lapack_zgetri(mLapack);
- init_lapack_zsytrf(mLapack);
- init_lapack_zsptrs(mLapack);
- init_lapack_zlaein(mLapack);
- init_lapack_dtrti2(mLapack);
- init_lapack_zstegr(mLapack);
- init_lapack_cgbtf2(mLapack);
- init_lapack_dtrtrs(mLapack);
- init_lapack_csytri2(mLapack);
- init_lapack_zla_syrcond_c(mLapack);
- init_lapack_dlaqr2(mLapack);
- init_lapack_sgebd2(mLapack);
- init_lapack_chpgst(mLapack);
- init_lapack_zla_lin_berr(mLapack);
- init_lapack_sgbtrf(mLapack);
- init_lapack_clasr(mLapack);
- init_lapack_dlarfg(mLapack);
- init_lapack_zggbak(mLapack);
- init_lapack_csytri(mLapack);
- init_lapack_ctgsy2(mLapack);
- init_lapack_clarzt(mLapack);
- init_lapack_ztfsm(mLapack);
- init_lapack_dlasq3(mLapack);
- init_lapack_dgbrfs(mLapack);
- init_lapack_cla_porpvgrw(mLapack);
- init_lapack_slaqsp(mLapack);
- init_lapack_dlatrd(mLapack);
- init_lapack_zlahr2(mLapack);
- init_lapack_dgelsx(mLapack);
- init_lapack_zporfsx(mLapack);
- init_lapack_slaed7(mLapack);
- init_lapack_zggglm(mLapack);
- init_lapack_ctzrqf(mLapack);
- init_lapack_sstevr(mLapack);
- init_lapack_dpftrf(mLapack);
- init_lapack_zlaqr1(mLapack);
- init_lapack_cgels(mLapack);
- init_lapack_dtrexc(mLapack);
- init_lapack_cgglse(mLapack);
- init_lapack_zgerqf(mLapack);
- init_lapack_claset(mLapack);
- init_lapack_spptrs(mLapack);
- init_lapack_zunmlq(mLapack);
- init_lapack_zhptrf(mLapack);
- init_lapack_zpbtrs(mLapack);
- init_lapack_zlaqr5(mLapack);
- init_lapack_cstein(mLapack);
- init_lapack_dsfrk(mLapack);
- init_lapack_slarrj(mLapack);
- init_lapack_spotrs(mLapack);
- init_lapack_dlagtf(mLapack);
- init_lapack_zpbrfs(mLapack);
- init_lapack_sdisna(mLapack);
- init_lapack_slaruv(mLapack);
- init_lapack_cpbequ(mLapack);
- init_lapack_dormtr(mLapack);
- init_lapack_sgtsv(mLapack);
- init_lapack_clarzb(mLapack);
- init_lapack_dla_syrpvgrw(mLapack);
- init_lapack_slasq3(mLapack);
- init_lapack_dposvx(mLapack);
- init_lapack_zlapmr(mLapack);
- init_lapack_clatrd(mLapack);
- init_lapack_cla_syrpvgrw(mLapack);
- init_lapack_dlaln2(mLapack);
- init_lapack_zgttrs(mLapack);
- init_lapack_dlasd7(mLapack);
- init_lapack_zgetf2(mLapack);
- init_lapack_zgebal(mLapack);
- init_lapack_dspgvd(mLapack);
- init_lapack_cgtsv(mLapack);
- init_lapack_ctrexc(mLapack);
- init_lapack_slasd1(mLapack);
- init_lapack_zpbsv(mLapack);
- init_lapack_dormql(mLapack);
- init_lapack_sgbcon(mLapack);
- init_lapack_clansp(mLapack);
- init_lapack_cla_gercond_x(mLapack);
- init_lapack_dtrttf(mLapack);
- init_lapack_stgsen(mLapack);
- init_lapack_shsein(mLapack);
- init_lapack_zhfrk(mLapack);
- init_lapack_sgbequ(mLapack);
- init_lapack_slapll(mLapack);
- init_lapack_spbstf(mLapack);
- init_lapack_dptts2(mLapack);
- init_lapack_ctpcon(mLapack);
- init_lapack_dgeqp3(mLapack);
- init_lapack_dstevx(mLapack);
- init_lapack_sormrq(mLapack);
- init_lapack_spteqr(mLapack);
- init_lapack_sspgst(mLapack);
- init_lapack_clagtm(mLapack);
- init_lapack_clanht(mLapack);
- init_lapack_sstemr(mLapack);
- init_lapack_ssbgv(mLapack);
- init_lapack_slascl(mLapack);
- init_lapack_ssbgvx(mLapack);
- init_lapack_disnan(mLapack);
- init_lapack_zlaset(mLapack);
- init_lapack_zggqrf(mLapack);
- init_lapack_zlarscl2(mLapack);
- init_lapack_dgtsv(mLapack);
- init_lapack_zptrfs(mLapack);
- init_lapack_cungqr(mLapack);
- init_lapack_dstemr(mLapack);
- init_lapack_clapll(mLapack);
- init_lapack_slasd8(mLapack);
- init_lapack_dlahrd(mLapack);
- init_lapack_sgbrfsx(mLapack);
- init_lapack_cla_syrcond_c(mLapack);
- init_lapack_slaswp(mLapack);
- init_lapack_zlatps(mLapack);
- init_lapack_dpptrf(mLapack);
- init_lapack_cgegv(mLapack);
- init_lapack_slacn2(mLapack);
- init_lapack_ctbrfs(mLapack);
- init_lapack_cporfsx(mLapack);
- init_lapack_dlasq2(mLapack);
- init_lapack_dtfttr(mLapack);
- init_lapack_clarcm(mLapack);
- init_lapack_zgglse(mLapack);
- init_lapack_ssptri(mLapack);
- init_lapack_cgbcon(mLapack);
- init_lapack_chptrs(mLapack);
- init_lapack_sspsv(mLapack);
- init_lapack_cpoequb(mLapack);
- init_lapack_zlaev2(mLapack);
- init_lapack_spbtf2(mLapack);
- init_lapack_cgesc2(mLapack);
- init_lapack_chegv(mLapack);
- init_lapack_slatrs(mLapack);
- init_lapack_dgeevx(mLapack);
- init_lapack_sgbequb(mLapack);
- init_lapack_clangb(mLapack);
- init_lapack_dla_porfsx_extended(mLapack);
- init_lapack_spoequb(mLapack);
- init_lapack_dlaqsb(mLapack);
- init_lapack_zlascl2(mLapack);
- init_lapack_zpttrs(mLapack);
- init_lapack_dspsv(mLapack);
- init_lapack_slaed9(mLapack);
- init_lapack_ztgsyl(mLapack);
- init_lapack_zlauum(mLapack);
- init_lapack_zbdsqr(mLapack);
- init_lapack_stptri(mLapack);
- init_lapack_dlasd6(mLapack);
- init_lapack_slar2v(mLapack);
- init_lapack_claqp2(mLapack);
- init_lapack_slaed6(mLapack);
- init_lapack_spttrf(mLapack);
- init_lapack_dtgex2(mLapack);
- init_lapack_dla_gbrfsx_extended(mLapack);
- init_lapack_claqr5(mLapack);
- init_lapack_zptsvx(mLapack);
- init_lapack_zgerq2(mLapack);
- init_lapack_dsysvx(mLapack);
- init_lapack_strcon(mLapack);
- init_lapack_stbcon(mLapack);
- init_lapack_dlantr(mLapack);
- init_lapack_slapy3(mLapack);
- init_lapack_slauu2(mLapack);
- init_lapack_sgetrf(mLapack);
- init_lapack_sggqrf(mLapack);
- init_lapack_dsyevr(mLapack);
- init_lapack_chbevx(mLapack);
- init_lapack_zgtrfs(mLapack);
- init_lapack_zgtcon(mLapack);
- init_lapack_claqr1(mLapack);
- init_lapack_zhbev(mLapack);
- init_lapack_srscl(mLapack);
- init_lapack_csytrs2(mLapack);
- init_lapack_clarrv(mLapack);
- init_lapack_iparmq(mLapack);
- init_lapack_zlantp(mLapack);
- init_lapack_zla_geamv(mLapack);
- init_lapack_cgesvxx(mLapack);
- init_lapack_cla_lin_berr(mLapack);
- init_lapack_ctgsyl(mLapack);
- init_lapack_dlas2(mLapack);
- init_lapack_dlaebz(mLapack);
- init_lapack_zlarzb(mLapack);
- init_lapack_sgbtf2(mLapack);
- init_lapack_zlanhb(mLapack);
- init_lapack_spstrf(mLapack);
- init_lapack_cheev(mLapack);
- init_lapack_claed7(mLapack);
- init_lapack_cpbtf2(mLapack);
- init_lapack_dsysv(mLapack);
- init_lapack_zsytrs2(mLapack);
- init_lapack_csytrf(mLapack);
- init_lapack_sgsvj0(mLapack);
- init_lapack_zlaqr0(mLapack);
- init_lapack_cptrfs(mLapack);
- init_lapack_claqhe(mLapack);
- init_lapack_ssterf(mLapack);
- init_lapack_zhbgvx(mLapack);
- init_lapack_dgerfsx(mLapack);
- init_lapack_zla_syrpvgrw(mLapack);
- init_lapack_sorcsd(mLapack);
- init_lapack_dorml2(mLapack);
- init_lapack_slaqp2(mLapack);
- init_lapack_ctrttp(mLapack);
- init_lapack_ztgsna(mLapack);
- init_lapack_dgebrd(mLapack);
- init_lapack_slartgs(mLapack);
- init_lapack_dgeequb(mLapack);
- init_lapack_stzrqf(mLapack);
- init_lapack_zgbrfs(mLapack);
- init_lapack_dgesc2(mLapack);
- init_lapack_zgees(mLapack);
- init_lapack_dtgexc(mLapack);
- init_lapack_ssptrd(mLapack);
- init_lapack_slanhs(mLapack);
- init_lapack_dgttrf(mLapack);
- init_lapack_zptcon(mLapack);
- init_lapack_slaln2(mLapack);
- init_lapack_cgesvd(mLapack);
- init_lapack_xerbla_array(mLapack);
- init_lapack_sposvxx(mLapack);
- init_lapack_zhprfs(mLapack);
- init_lapack_zlacrm(mLapack);
- init_lapack_dsteqr(mLapack);
- init_lapack_csyconv(mLapack);
- init_lapack_sgttrs(mLapack);
- init_lapack_csptri(mLapack);
- init_lapack_dlasq4(mLapack);
- init_lapack_zla_syrfsx_extended(mLapack);
- init_lapack_dgeqpf(mLapack);
- init_lapack_clansb(mLapack);
- init_lapack_dsptri(mLapack);
- init_lapack_dpbtrf(mLapack);
- init_lapack_ctbcon(mLapack);
- init_lapack_sgeqp3(mLapack);
- init_lapack_cspsv(mLapack);
- init_lapack_stgevc(mLapack);
- init_lapack_zsptrf(mLapack);
- init_lapack_ssbgst(mLapack);
- init_lapack_ctgexc(mLapack);
- init_lapack_slaqps(mLapack);
- init_lapack_dsbtrd(mLapack);
- init_lapack_zunmqr(mLapack);
- init_lapack_dlarrj(mLapack);
- init_lapack_clantb(mLapack);
- init_lapack_cgeesx(mLapack);
- init_lapack_zggrqf(mLapack);
- init_lapack_cunmtr(mLapack);
- init_lapack_dggev(mLapack);
- init_lapack_clarscl2(mLapack);
- init_lapack_dlasd8(mLapack);
- init_lapack_dsygv(mLapack);
- init_lapack_dlasda(mLapack);
- init_lapack_dorgql(mLapack);
- init_lapack_slagv2(mLapack);
- init_lapack_iladlr(mLapack);
- init_lapack_cuncsd(mLapack);
- init_lapack_icmax1(mLapack);
- init_lapack_dorcsd(mLapack);
- init_lapack_cgelsy(mLapack);
- init_lapack_dptrfs(mLapack);
- init_lapack_spoequ(mLapack);
- init_lapack_sgbsvxx(mLapack);
- init_lapack_zgeequ(mLapack);
- init_lapack_sgelsd(mLapack);
- init_lapack_sgbsv(mLapack);
- init_lapack_cstedc(mLapack);
- init_lapack_slasd2(mLapack);
- init_lapack_dggsvd(mLapack);
- init_lapack_clags2(mLapack);
- init_lapack_zlalsa(mLapack);
- init_lapack_dpotf2(mLapack);
- init_lapack_dlantb(mLapack);
- init_lapack_ctfttp(mLapack);
- init_lapack_zhbevd(mLapack);
- init_lapack_cggev(mLapack);
- init_lapack_sorg2r(mLapack);
- init_lapack_dppsv(mLapack);
- init_lapack_cgebd2(mLapack);
- init_lapack_zgebrd(mLapack);
- init_lapack_clanhf(mLapack);
- init_lapack_sla_lin_berr(mLapack);
- init_lapack_cgeqlf(mLapack);
- init_lapack_cunmql(mLapack);
- init_lapack_zgetrf(mLapack);
- init_lapack_clauu2(mLapack);
- init_lapack_slasq4(mLapack);
- init_lapack_zpftri(mLapack);
- init_lapack_dla_syrcond(mLapack);
- init_lapack_zgehd2(mLapack);
- init_lapack_zla_porfsx_extended(mLapack);
- init_lapack_dporfs(mLapack);
- init_lapack_zgesdd(mLapack);
- init_lapack_dlagv2(mLapack);
- init_lapack_cggrqf(mLapack);
- init_lapack_dlasrt(mLapack);
- init_lapack_sorml2(mLapack);
- init_lapack_slar1v(mLapack);
- init_lapack_dpbcon(mLapack);
- init_lapack_cgebak(mLapack);
- init_lapack_chetrs2(mLapack);
- init_lapack_zstein(mLapack);
- init_lapack_chpcon(mLapack);
- init_lapack_zla_hercond_x(mLapack);
- init_lapack_chesv(mLapack);
- init_lapack_ztgsen(mLapack);
- init_lapack_sorg2l(mLapack);
- init_lapack_strevc(mLapack);
- init_lapack_dlansy(mLapack);
- init_lapack_dggqrf(mLapack);
- init_lapack_cpttrf(mLapack);
- init_lapack_zla_gbrcond_c(mLapack);
- init_lapack_cupgtr(mLapack);
- init_lapack_zsytri2(mLapack);
- init_lapack_izmax1(mLapack);
- init_lapack_dlaed0(mLapack);
- init_lapack_zunghr(mLapack);
- init_lapack_sorgl2(mLapack);
- init_lapack_dsbgv(mLapack);
- init_lapack_dstevd(mLapack);
- init_lapack_dladiv(mLapack);
- init_lapack_dgelqf(mLapack);
- init_lapack_dla_wwaddw(mLapack);
- init_lapack_ztzrqf(mLapack);
- init_lapack_sorgtr(mLapack);
- init_lapack_dgbtf2(mLapack);
- init_lapack_chegvx(mLapack);
- init_lapack_zlaqsy(mLapack);
- init_lapack_zlarfx(mLapack);
- init_lapack_sspevx(mLapack);
- init_lapack_dorgl2(mLapack);
- init_lapack_slatdf(mLapack);
- init_lapack_spprfs(mLapack);
- init_lapack_zunmhr(mLapack);
- init_lapack_slaqr1(mLapack);
- init_lapack_zhptrs(mLapack);
- init_lapack_zla_gbrfsx_extended(mLapack);
- init_lapack_slarzb(mLapack);
- init_lapack_cgbsvxx(mLapack);
- init_lapack_dlatrz(mLapack);
- init_lapack_cheevr(mLapack);
- init_lapack_dlasq6(mLapack);
- init_lapack_zlahrd(mLapack);
- init_lapack_zlaqhp(mLapack);
- init_lapack_zla_hercond_c(mLapack);
- init_lapack_dgesdd(mLapack);
- init_lapack_ztfttp(mLapack);
- init_lapack_sspgvd(mLapack);
- init_lapack_clasyf(mLapack);
- init_lapack_dgetrs(mLapack);
- init_lapack_dlarrk(mLapack);
- init_lapack_slasyf(mLapack);
- init_lapack_slatrz(mLapack);
- init_lapack_dlatbs(mLapack);
- init_lapack_spbequ(mLapack);
- init_lapack_dppequ(mLapack);
- init_lapack_cpotrs(mLapack);
- init_lapack_zpotri(mLapack);
- init_lapack_dsyequb(mLapack);
- init_lapack_claesy(mLapack);
- init_lapack_dgees(mLapack);
- init_lapack_slasrt(mLapack);
- init_lapack_stgsyl(mLapack);
- init_lapack_ztftri(mLapack);
- init_lapack_dlaed1(mLapack);
- init_lapack_slarfg(mLapack);
- init_lapack_zlacgv(mLapack);
- init_lapack_slantr(mLapack);
- init_lapack_dlaqtr(mLapack);
- init_lapack_ddisna(mLapack);
- init_lapack_cbdsqr(mLapack);
- init_lapack_dtgsy2(mLapack);
- init_lapack_zgels(mLapack);
- init_lapack_cla_syamv(mLapack);
- init_lapack_zheequb(mLapack);
- init_lapack_cpbcon(mLapack);
- init_lapack_dlartv(mLapack);
- init_lapack_sla_gbrpvgrw(mLapack);
- init_lapack_cla_heamv(mLapack);
- init_lapack_dlanhs(mLapack);
- init_lapack_zpteqr(mLapack);
- init_lapack_slagts(mLapack);
- init_lapack_dlange(mLapack);
- init_lapack_slasq1(mLapack);
- init_lapack_dgelss(mLapack);
- init_lapack_cggsvp(mLapack);
- init_lapack_dorbdb(mLapack);
- init_lapack_dlacon(mLapack);
- init_lapack_chptri(mLapack);
- init_lapack_slatps(mLapack);
- init_lapack_dlarf(mLapack);
- init_lapack_slasdq(mLapack);
- init_lapack_csycon(mLapack);
- init_lapack_cggglm(mLapack);
- init_lapack_zlanhp(mLapack);
- init_lapack_zsymv(mLapack);
- init_lapack_cpbsv(mLapack);
- init_lapack_dlahqr(mLapack);
- init_lapack_dorgbr(mLapack);
- init_lapack_clarft(mLapack);
- init_lapack_dgglse(mLapack);
- init_lapack_sgerfsx(mLapack);
- init_lapack_dtzrzf(mLapack);
- init_lapack_dlauu2(mLapack);
- init_lapack_ztzrzf(mLapack);
- init_lapack_cgeql2(mLapack);
- init_lapack_zungrq(mLapack);
- init_lapack_sstedc(mLapack);
- init_lapack_zgeequb(mLapack);
- init_lapack_slartgp(mLapack);
- init_lapack_slarrb(mLapack);
- init_lapack_sggbal(mLapack);
- init_lapack_slatbs(mLapack);
- init_lapack_cunglq(mLapack);
- init_lapack_dptsv(mLapack);
- init_lapack_cunm2l(mLapack);
- init_lapack_dlapy3(mLapack);
- init_lapack_dlarrb(mLapack);
- init_lapack_sgerqf(mLapack);
- init_lapack_zungl2(mLapack);
- init_lapack_classq(mLapack);
- init_lapack_zptsv(mLapack);
- init_lapack_cbbcsd(mLapack);
- init_lapack_slarrd(mLapack);
- init_lapack_cpstrf(mLapack);
- init_lapack_sbdsdc(mLapack);
- init_lapack_dstein(mLapack);
- init_lapack_cgelqf(mLapack);
- init_lapack_dgecon(mLapack);
- init_lapack_dlansf(mLapack);
- init_lapack_dlanst(mLapack);
- init_lapack_claic1(mLapack);
- init_lapack_zlansp(mLapack);
- init_lapack_dgbcon(mLapack);
- init_lapack_zgebd2(mLapack);
- init_lapack_dlatzm(mLapack);
- init_lapack_sormbr(mLapack);
- init_lapack_cgeequ(mLapack);
- init_lapack_ssyswapr(mLapack);
- init_lapack_dla_porpvgrw(mLapack);
- init_lapack_zgebak(mLapack);
- init_lapack_dstebz(mLapack);
- init_lapack_clahr2(mLapack);
- init_lapack_dgetc2(mLapack);
- init_lapack_dsygvd(mLapack);
- init_lapack_zgbtrs(mLapack);
- init_lapack_sptrfs(mLapack);
- init_lapack_strsna(mLapack);
- init_lapack_sorglq(mLapack);
- init_lapack_dsygvx(mLapack);
- init_lapack_cheevx(mLapack);
- init_lapack_zsytri(mLapack);
- init_lapack_dlassq(mLapack);
- init_lapack_dsptrd(mLapack);
- init_lapack_zla_gercond_c(mLapack);
- init_lapack_cla_rpvgrw(mLapack);
- init_lapack_slaebz(mLapack);
- init_lapack_ztbtrs(mLapack);
- init_lapack_slaqr4(mLapack);
- init_lapack_dlaqps(mLapack);
- init_lapack_dhsein(mLapack);
- init_lapack_zggesx(mLapack);
- init_lapack_dgtrfs(mLapack);
- init_lapack_chgeqz(mLapack);
- init_lapack_cungl2(mLapack);
- init_lapack_dlasyf(mLapack);
- init_lapack_dtzrqf(mLapack);
- init_lapack_zhpcon(mLapack);
- init_lapack_dgesv(mLapack);
- init_lapack_cgeev(mLapack);
- init_lapack_zbbcsd(mLapack);
- init_lapack_dpprfs(mLapack);
- init_lapack_zhesvx(mLapack);
- init_lapack_cheevd(mLapack);
- init_lapack_zhegvx(mLapack);
- init_lapack_clanhp(mLapack);
- init_lapack_cung2r(mLapack);
- init_lapack_sgetrs(mLapack);
- init_lapack_zung2l(mLapack);
- init_lapack_zgehrd(mLapack);
- init_lapack_cgeqrf(mLapack);
- init_lapack_slatrd(mLapack);
- init_lapack_zlaed0(mLapack);
- init_lapack_dlaed9(mLapack);
- init_lapack_sgeevx(mLapack);
- init_lapack_sorgql(mLapack);
- init_lapack_ctgevc(mLapack);
- init_lapack_dgsvj0(mLapack);
- init_lapack_cgehrd(mLapack);
- init_lapack_spbsvx(mLapack);
- init_lapack_cla_hercond_c(mLapack);
- init_lapack_clacp2(mLapack);
- init_lapack_zdrscl(mLapack);
- init_lapack_chetrs(mLapack);
- init_lapack_zsycon(mLapack);
- init_lapack_ssytri(mLapack);
- init_lapack_dorm2l(mLapack);
- init_lapack_sgelsy(mLapack);
- init_lapack_sla_gbrcond(mLapack);
- init_lapack_chptrd(mLapack);
- init_lapack_sgerfs(mLapack);
- init_lapack_chegvd(mLapack);
- init_lapack_dlaqr3(mLapack);
- init_lapack_dsytd2(mLapack);
- init_lapack_cposvxx(mLapack);
- init_lapack_dspgst(mLapack);
- init_lapack_ssygvx(mLapack);
- init_lapack_slaexc(mLapack);
- init_lapack_zla_gbamv(mLapack);
- init_lapack_zsptri(mLapack);
- init_lapack_zpbtrf(mLapack);
- init_lapack_sgelsx(mLapack);
- init_lapack_zspsvx(mLapack);
- init_lapack_slacon(mLapack);
- init_lapack_zlanhf(mLapack);
- init_lapack_dgegv(mLapack);
- init_lapack_slae2(mLapack);
- init_lapack_cpbrfs(mLapack);
- init_lapack_stgexc(mLapack);
- init_lapack_slargv(mLapack);
- init_lapack_clacn2(mLapack);
- init_lapack_claqps(mLapack);
- init_lapack_ssteqr(mLapack);
- init_lapack_slasd3(mLapack);
- init_lapack_zgeqpf(mLapack);
- init_lapack_strexc(mLapack);
- init_lapack_zla_gbrpvgrw(mLapack);
- init_lapack_zla_heamv(mLapack);
- init_lapack_slaed8(mLapack);
- init_lapack_clatbs(mLapack);
- init_lapack_zlange(mLapack);
- init_lapack_zgbcon(mLapack);
- init_lapack_slasdt(mLapack);
- init_lapack_chpgvx(mLapack);
- init_lapack_cpftrs(mLapack);
- init_lapack_zhetri(mLapack);
- init_lapack_slauum(mLapack);
- init_lapack_ssyevr(mLapack);
- init_lapack_dormr3(mLapack);
- init_lapack_zung2r(mLapack);
- init_lapack_csysvx(mLapack);
- init_lapack_claed0(mLapack);
- init_lapack_zgesvxx(mLapack);
- init_lapack_dgbequ(mLapack);
- init_lapack_clacrm(mLapack);
- init_lapack_sgeqr2(mLapack);
- init_lapack_cgbsvx(mLapack);
- init_lapack_dlapy2(mLapack);
- init_lapack_cggsvd(mLapack);
- init_lapack_zlassq(mLapack);
- init_lapack_dpotri(mLapack);
- init_lapack_slaqr5(mLapack);
- init_lapack_dlantp(mLapack);
- init_lapack_dspevd(mLapack);
- init_lapack_dporfsx(mLapack);
- init_lapack_ztptri(mLapack);
- init_lapack_sgesvx(mLapack);
- init_lapack_dsbev(mLapack);
- init_lapack_sormqr(mLapack);
- init_lapack_dtbrfs(mLapack);
- init_lapack_slasv2(mLapack);
- init_lapack_dpttrs(mLapack);
- init_lapack_zpbsvx(mLapack);
- init_lapack_zpptrs(mLapack);
- init_lapack_ztrexc(mLapack);
- init_lapack_dla_syrfsx_extended(mLapack);
- init_lapack_slasd4(mLapack);
- init_lapack_dlasy2(mLapack);
- init_lapack_dgeqlf(mLapack);
- init_lapack_zunm2r(mLapack);
- init_lapack_clarfgp(mLapack);
- init_lapack_ssytrs(mLapack);
- init_lapack_dtrcon(mLapack);
- init_lapack_spttrs(mLapack);
- init_lapack_spotri(mLapack);
- init_lapack_slanst(mLapack);
- init_lapack_dlaqsp(mLapack);
- init_lapack_zgbtf2(mLapack);
- init_lapack_chpgvd(mLapack);
- init_lapack_zlapmt(mLapack);
- init_lapack_cla_hercond_x(mLapack);
- init_lapack_slaed1(mLapack);
- init_lapack_zppequ(mLapack);
- init_lapack_ssytf2(mLapack);
- init_lapack_slag2d(mLapack);
- init_lapack_sgeequb(mLapack);
- init_lapack_chesvxx(mLapack);
- init_lapack_cgebal(mLapack);
- init_lapack_slarscl2(mLapack);
- init_lapack_zpstf2(mLapack);
- init_lapack_dsytri2x(mLapack);
- init_lapack_dpptri(mLapack);
- init_lapack_sla_syrcond(mLapack);
- init_lapack_sggrqf(mLapack);
- init_lapack_dormrz(mLapack);
- init_lapack_ssytrs2(mLapack);
- init_lapack_strtri(mLapack);
- init_lapack_stfsm(mLapack);
- init_lapack_ztpttf(mLapack);
- init_lapack_dgetrf(mLapack);
- init_lapack_strttf(mLapack);
- init_lapack_cptts2(mLapack);
- init_lapack_dlartg(mLapack);
- init_lapack_slagtf(mLapack);
- init_lapack_dormlq(mLapack);
- init_lapack_zhpev(mLapack);
- init_lapack_zlarnv(mLapack);
- init_lapack_zpbstf(mLapack);
- init_lapack_ssysvxx(mLapack);
- init_lapack_cla_porcond_x(mLapack);
- init_lapack_dlasq5(mLapack);
- init_lapack_ctgsja(mLapack);
- init_lapack_dtrsyl(mLapack);
- init_lapack_dsposv(mLapack);
- init_lapack_slaqr3(mLapack);
- init_lapack_zhbgvd(mLapack);
- init_lapack_ssyequb(mLapack);
- init_lapack_dgttrs(mLapack);
- init_lapack_zsteqr(mLapack);
- init_lapack_dggrqf(mLapack);
- init_lapack_cgtsvx(mLapack);
- init_lapack_cgelss(mLapack);
- init_lapack_zlangb(mLapack);
- init_lapack_dgels(mLapack);
- init_lapack_slarrr(mLapack);
- init_lapack_zstedc(mLapack);
- init_lapack_zhetrs2(mLapack);
- init_lapack_dsprfs(mLapack);
- init_lapack_dlasdq(mLapack);
- init_lapack_csprfs(mLapack);
- init_lapack_slarz(mLapack);
- init_lapack_sggevx(mLapack);
- init_lapack_ztfttr(mLapack);
- init_lapack_zhegst(mLapack);
- init_lapack_chpsv(mLapack);
- init_lapack_dtrtri(mLapack);
- init_lapack_clacgv(mLapack);
- init_lapack_zpptri(mLapack);
- init_lapack_chbtrd(mLapack);
- init_lapack_cgesvx(mLapack);
- init_lapack_slaneg(mLapack);
- init_lapack_clag2z(mLapack);
- init_lapack_slarra(mLapack);
- init_lapack_sgsvj1(mLapack);
- init_lapack_cla_gbrcond_x(mLapack);
- init_lapack_cla_herpvgrw(mLapack);
- init_lapack_zlascl(mLapack);
- init_lapack_dsbgvx(mLapack);
- init_lapack_sormhr(mLapack);
- init_lapack_chetf2(mLapack);
- init_lapack_ssycon(mLapack);
- init_lapack_dlae2(mLapack);
- init_lapack_zgelss(mLapack);
- init_lapack_cgelq2(mLapack);
- init_lapack_slarfb(mLapack);
- init_lapack_ctrtrs(mLapack);
- init_lapack_stfttr(mLapack);
- init_lapack_drscl(mLapack);
- init_lapack_clatdf(mLapack);
- init_lapack_cherfs(mLapack);
- init_lapack_dtbtrs(mLapack);
- init_lapack_dlartgs(mLapack);
- init_lapack_dlar2v(mLapack);
- init_lapack_zlarrv(mLapack);
- init_lapack_dsyswapr(mLapack);
- init_lapack_dlag2s(mLapack);
- init_lapack_ssprfs(mLapack);
- init_lapack_cppsv(mLapack);
- init_lapack_dlarfx(mLapack);
- init_lapack_zppsvx(mLapack);
- init_lapack_sgehd2(mLapack);
- init_lapack_zheevr(mLapack);
- init_lapack_ssygvd(mLapack);
- init_lapack_zunglq(mLapack);
- init_lapack_cungtr(mLapack);
- init_lapack_zlauu2(mLapack);
- init_lapack_ssfrk(mLapack);
- init_lapack_dtpttr(mLapack);
- init_lapack_spftrf(mLapack);
- init_lapack_slascl2(mLapack);
- init_lapack_slasd5(mLapack);
- init_lapack_zhpsvx(mLapack);
- init_lapack_dgghrd(mLapack);
- init_lapack_zlasyf(mLapack);
- init_lapack_zlabrd(mLapack);
- init_lapack_cspr(mLapack);
- init_lapack_zunm2l(mLapack);
- init_lapack_dlaeda(mLapack);
- init_lapack_csyr(mLapack);
- init_lapack_dlangt(mLapack);
- init_lapack_ctpttf(mLapack);
- init_lapack_zpbcon(mLapack);
- init_lapack_ztrsen(mLapack);
- init_lapack_sla_syrfsx_extended(mLapack);
- init_lapack_zlat2c(mLapack);
- init_lapack_cunmlq(mLapack);
- init_lapack_slals0(mLapack);
- init_lapack_zlantr(mLapack);
- init_lapack_sgels(mLapack);
- init_lapack_dtgsja(mLapack);
- init_lapack_sposv(mLapack);
- init_lapack_dgtts2(mLapack);
- init_lapack_zlaqhb(mLapack);
- init_lapack_dlatrs(mLapack);
- init_lapack_dsytrs2(mLapack);
- init_lapack_zlansy(mLapack);
- init_lapack_spbcon(mLapack);
- init_lapack_dbdsdc(mLapack);
- init_lapack_zlacp2(mLapack);
- init_lapack_sladiv(mLapack);
- init_lapack_spotrf(mLapack);
- init_lapack_ilaslc(mLapack);
- init_lapack_ctftri(mLapack);
- init_lapack_dlamrg(mLapack);
- init_lapack_dpbtf2(mLapack);
- init_lapack_cgerfs(mLapack);
- init_lapack_dla_gbrcond(mLapack);
- init_lapack_dposvxx(mLapack);
- init_lapack_dposv(mLapack);
- init_lapack_cgbequ(mLapack);
- init_lapack_sgeqpf(mLapack);
- init_lapack_slasd6(mLapack);
- init_lapack_zlarzt(mLapack);
- init_lapack_csteqr(mLapack);
- init_lapack_dbdsqr(mLapack);
- init_lapack_zppsv(mLapack);
- init_lapack_cunm2r(mLapack);
- init_lapack_zla_gerfsx_extended(mLapack);
- init_lapack_ssytrd(mLapack);
- init_lapack_sgesc2(mLapack);
- init_lapack_slanv2(mLapack);
- init_lapack_sgttrf(mLapack);
- init_lapack_sla_gbamv(mLapack);
- init_lapack_zladiv(mLapack);
- init_lapack_cpotri(mLapack);
- init_lapack_zunmql(mLapack);
- init_lapack_dtftri(mLapack);
- init_lapack_spftrs(mLapack);
- init_lapack_clahef(mLapack);
- init_lapack_dppsvx(mLapack);
- init_lapack_chla_transtype(mLapack);
- init_lapack_slarf(mLapack);
- init_lapack_dgeev(mLapack);
- init_lapack_zlapll(mLapack);
- init_lapack_dlarz(mLapack);
- init_lapack_cungr2(mLapack);
- init_lapack_dgeequ(mLapack);
- init_lapack_chpev(mLapack);
- init_lapack_dtpttf(mLapack);
- init_lapack_zgbrfsx(mLapack);
- init_lapack_dlaswp(mLapack);
- init_lapack_ctgsen(mLapack);
- init_lapack_dsbgvd(mLapack);
- init_lapack_slags2(mLapack);
- init_lapack_cgegs(mLapack);
- init_lapack_dgeqr2(mLapack);
- init_lapack_slansp(mLapack);
- init_lapack_sgejsv(mLapack);
- init_lapack_dlangb(mLapack);
- init_lapack_sbbcsd(mLapack);
- init_lapack_ilatrans(mLapack);
- init_lapack_slacpy(mLapack);
- init_lapack_cupmtr(mLapack);
- init_lapack_cpoequ(mLapack);
- init_lapack_clanhe(mLapack);
- init_lapack_ztgevc(mLapack);
- init_lapack_cla_porfsx_extended(mLapack);
- init_lapack_sormql(mLapack);
- init_lapack_claqgb(mLapack);
- init_lapack_dlasd3(mLapack);
- init_lapack_cgerfsx(mLapack);
- init_lapack_dlarnv(mLapack);
- init_lapack_zporfs(mLapack);
- init_lapack_zposvx(mLapack);
- init_lapack_sgelss(mLapack);
- init_lapack_slaqsy(mLapack);
- init_lapack_dlatps(mLapack);
- init_lapack_dgebd2(mLapack);
- init_lapack_zrot(mLapack);
- init_lapack_zla_porcond_c(mLapack);
- init_lapack_zhetd2(mLapack);
- init_lapack_dgtsvx(mLapack);
- init_lapack_sgeqrf(mLapack);
- init_lapack_ctzrzf(mLapack);
- init_lapack_dstedc(mLapack);
- init_lapack_ssptrf(mLapack);
- init_lapack_zpocon(mLapack);
- init_lapack_cgeqr2(mLapack);
- init_lapack_cppcon(mLapack);
- init_lapack_sisnan(mLapack);
- init_lapack_sppsv(mLapack);
- init_lapack_dopmtr(mLapack);
- init_lapack_zgeqp3(mLapack);
- init_lapack_dsytrd(mLapack);
- init_lapack_sopmtr(mLapack);
- init_lapack_strsen(mLapack);
- init_lapack_ssytri2x(mLapack);
- init_lapack_cgbtrs(mLapack);
- init_lapack_ctrttf(mLapack);
- init_lapack_sposvx(mLapack);
- init_lapack_dlasr(mLapack);
- init_lapack_zunmrq(mLapack);
- init_lapack_sgtrfs(mLapack);
- init_lapack_dsyrfs(mLapack);
- init_lapack_cgetc2(mLapack);
- init_lapack_zgeevx(mLapack);
- init_lapack_dstegr(mLapack);
- init_lapack_sggglm(mLapack);
- init_lapack_cspcon(mLapack);
- init_lapack_sbdsqr(mLapack);
- init_lapack_zpotrf(mLapack);
- init_lapack_clahrd(mLapack);
- init_lapack_dlarft(mLapack);
- init_lapack_dlaneg(mLapack);
- init_lapack_cgetri(mLapack);
- init_lapack_zgtts2(mLapack);
- init_lapack_dlasdt(mLapack);
- init_lapack_zhpevx(mLapack);
- init_lapack_claqsp(mLapack);
- init_lapack_ztpcon(mLapack);
- init_lapack_ztbrfs(mLapack);
- init_lapack_slaic1(mLapack);
- init_lapack_dorm2r(mLapack);
- init_lapack_claqr4(mLapack);
- init_lapack_zpbequ(mLapack);
- init_lapack_dlapmr(mLapack);
- init_lapack_dlaed8(mLapack);
- init_lapack_cgerq2(mLapack);
- init_lapack_sptts2(mLapack);
- init_lapack_zhpgvx(mLapack);
- init_lapack_dlabad(mLapack);
- init_lapack_ctpttr(mLapack);
- init_lapack_cungbr(mLapack);
- init_lapack_dgetf2(mLapack);
- init_lapack_zunmr3(mLapack);
- init_lapack_ilaclc(mLapack);
- init_lapack_cunmhr(mLapack);
- init_lapack_dorghr(mLapack);
- init_lapack_cgttrf(mLapack);
- init_lapack_sormlq(mLapack);
- init_lapack_zspr(mLapack);
- init_lapack_cpocon(mLapack);
- init_lapack_zlaed7(mLapack);
- init_lapack_ztpttr(mLapack);
- init_lapack_ctbtrs(mLapack);
- init_lapack_dlahr2(mLapack);
- init_lapack_sorm2r(mLapack);
- init_lapack_sgetf2(mLapack);
- init_lapack_zpbtf2(mLapack);
- init_lapack_cggesx(mLapack);
- init_lapack_zlaqr2(mLapack);
- init_lapack_dgeql2(mLapack);
- init_lapack_spbrfs(mLapack);
- init_lapack_dgerq2(mLapack);
- init_lapack_dgelq2(mLapack);
- init_lapack_zcposv(mLapack);
- init_lapack_zhbgv(mLapack);
- init_lapack_dgetri(mLapack);
- init_lapack_zspsv(mLapack);
- init_lapack_cla_gbrpvgrw(mLapack);
- init_lapack_dgehd2(mLapack);
- init_lapack_stbtrs(mLapack);
- init_lapack_zungtr(mLapack);
- init_lapack_zspcon(mLapack);
- init_lapack_sgebal(mLapack);
- init_lapack_clarz(mLapack);
- init_lapack_clals0(mLapack);
- init_lapack_stpcon(mLapack);
- init_lapack_dsytrf(mLapack);
- init_lapack_slaeda(mLapack);
- init_lapack_dpteqr(mLapack);
- init_lapack_zgtsv(mLapack);
- init_lapack_sgges(mLapack);
- init_lapack_cptcon(mLapack);
- init_lapack_chesvx(mLapack);
- init_lapack_cpftri(mLapack);
- init_lapack_dpbrfs(mLapack);
- init_lapack_sla_gerfsx_extended(mLapack);
- init_lapack_sla_wwaddw(mLapack);
- init_lapack_zlatrd(mLapack);
- init_lapack_dsytf2(mLapack);
- init_lapack_csytrs(mLapack);
- init_lapack_cla_gbamv(mLapack);
- init_lapack_lsamen(mLapack);
- init_lapack_sla_porfsx_extended(mLapack);
- init_lapack_iladiag(mLapack);
- init_lapack_clascl2(mLapack);
- init_lapack_cheequb(mLapack);
- init_lapack_cpprfs(mLapack);
- init_lapack_dormr2(mLapack);
- init_lapack_zhpsv(mLapack);
- init_lapack_sgbbrd(mLapack);
- init_lapack_dsptrs(mLapack);
- init_lapack_csymv(mLapack);
- init_lapack_ztrcon(mLapack);
- init_lapack_cppsvx(mLapack);
- init_lapack_clartv(mLapack);
- init_lapack_slag2(mLapack);
- init_lapack_dlasd5(mLapack);
- init_lapack_chseqr(mLapack);
- init_lapack_ssbgvd(mLapack);
- init_lapack_clacrt(mLapack);
- init_lapack_zhetrd(mLapack);
- init_lapack_sgetc2(mLapack);
- init_lapack_dptsvx(mLapack);
- init_lapack_slange(mLapack);
- init_lapack_zlatrz(mLapack);
- init_lapack_cunmbr(mLapack);
- init_lapack_zpstrf(mLapack);
- init_lapack_slartg(mLapack);
- init_lapack_zlahef(mLapack);
- init_lapack_dlascl(mLapack);
- init_lapack_zlarf(mLapack);
- init_lapack_sspcon(mLapack);
- init_lapack_cpbsvx(mLapack);
- init_lapack_dlaed7(mLapack);
- init_lapack_slapmr(mLapack);
- init_lapack_zsytf2(mLapack);
- init_lapack_ztrrfs(mLapack);
- init_lapack_cggevx(mLapack);
- init_lapack_zsyrfsx(mLapack);
- init_lapack_cla_gbrfsx_extended(mLapack);
- init_lapack_dptcon(mLapack);
- init_lapack_sggev(mLapack);
- init_lapack_ilaslr(mLapack);
- init_lapack_dhgeqz(mLapack);
- init_lapack_sgghrd(mLapack);
- init_lapack_zsysv(mLapack);
- init_lapack_stbrfs(mLapack);
- init_lapack_claqsy(mLapack);
- init_lapack_clalsa(mLapack);
- init_lapack_zla_wwaddw(mLapack);
- init_lapack_sla_syrpvgrw(mLapack);
- init_lapack_ilaclr(mLapack);
- init_lapack_slasq5(mLapack);
- init_lapack_sorbdb(mLapack);
- init_lapack_dtprfs(mLapack);
- init_lapack_chegs2(mLapack);
- init_lapack_ssbev(mLapack);
- init_lapack_strttp(mLapack);
- init_lapack_zhgeqz(mLapack);
- init_lapack_zlaqsp(mLapack);
- init_lapack_zgbequ(mLapack);
- init_lapack_claswp(mLapack);
- init_lapack_dlaqr1(mLapack);
- init_lapack_cpstf2(mLapack);
- init_lapack_claev2(mLapack);
- init_lapack_cgeqpf(mLapack);
- init_lapack_sgesv(mLapack);
- init_lapack_zgesvx(mLapack);
- init_lapack_stfttp(mLapack);
- init_lapack_dggbak(mLapack);
- init_lapack_zla_herpvgrw(mLapack);
- init_lapack_zppcon(mLapack);
- init_lapack_dlansp(mLapack);
- init_lapack_slarnv(mLapack);
- init_lapack_cla_syrcond_x(mLapack);
- init_lapack_cunmr3(mLapack);
- init_lapack_zgbtrf(mLapack);
- init_lapack_dlarscl2(mLapack);
- init_lapack_zlaqsb(mLapack);
- init_lapack_dsyevx(mLapack);
- init_lapack_dgerqf(mLapack);
- init_lapack_dgbequb(mLapack);
- init_lapack_zlacpy(mLapack);
- init_lapack_claein(mLapack);
- init_lapack_dlat2s(mLapack);
- init_lapack_cgehd2(mLapack);
- init_lapack_ssyconv(mLapack);
- init_lapack_dgeqrf(mLapack);
- init_lapack_slabrd(mLapack);
- init_lapack_cgtrfs(mLapack);
- init_lapack_sgbtrs(mLapack);
- init_lapack_slangb(mLapack);
- init_lapack_zgbequb(mLapack);
- init_lapack_dsytri2(mLapack);
- init_lapack_slarrk(mLapack);
- init_lapack_chsein(mLapack);
- init_lapack_sgebrd(mLapack);
- init_lapack_zlarfb(mLapack);
- init_lapack_slasda(mLapack);
- init_lapack_cpbstf(mLapack);
- init_lapack_zlacon(mLapack);
- init_lapack_dtrsen(mLapack);
- init_lapack_clarnv(mLapack);
- init_lapack_slagtm(mLapack);
- init_lapack_sgerq2(mLapack);
- init_lapack_dormqr(mLapack);
- init_lapack_dlaqr5(mLapack);
- init_lapack_zpttrf(mLapack);
- init_lapack_ztrsna(mLapack);
- init_lapack_dgejsv(mLapack);
- init_lapack_dtptrs(mLapack);
- init_lapack_cposvx(mLapack);
- init_lapack_claed8(mLapack);
- init_lapack_ctrti2(mLapack);
- init_lapack_sormr2(mLapack);
- init_lapack_dlaqp2(mLapack);
- init_lapack_stgsna(mLapack);
- init_lapack_dlascl2(mLapack);
- init_lapack_cgecon(mLapack);
- init_lapack_zsyswapr(mLapack);
- init_lapack_zgeqr2p(mLapack);
- init_lapack_stpttr(mLapack);
- init_lapack_dlansb(mLapack);
- init_lapack_zungqr(mLapack);
- init_lapack_zsyconv(mLapack);
- init_lapack_zunmr2(mLapack);
- init_lapack_slasy2(mLapack);
- init_lapack_dsbevx(mLapack);
- init_lapack_dsyrfsx(mLapack);
- init_lapack_cgeqp3(mLapack);
- init_lapack_stprfs(mLapack);
- init_lapack_zpoequ(mLapack);
- init_lapack_zlahqr(mLapack);
- init_lapack_zunmrz(mLapack);
- init_lapack_claqr2(mLapack);
- init_lapack_slaqr0(mLapack);
- init_lapack_ztprfs(mLapack);
- init_lapack_ztgexc(mLapack);
- init_lapack_dorglq(mLapack);
- init_lapack_dgelsy(mLapack);
- init_lapack_ilaprec(mLapack);
- init_lapack_ssyrfsx(mLapack);
- init_lapack_zlaqhe(mLapack);
- init_lapack_csptrs(mLapack);
- init_lapack_spftri(mLapack);
- init_lapack_shseqr(mLapack);
- init_lapack_zlaed8(mLapack);
- init_lapack_chbevd(mLapack);
- init_lapack_dsyev(mLapack);
- init_lapack_dspgvx(mLapack);
- init_lapack_zgtsvx(mLapack);
- init_lapack_sgegv(mLapack);
- init_lapack_slantb(mLapack);
- init_lapack_zla_syrcond_x(mLapack);
- init_lapack_dlar1v(mLapack);
- init_lapack_zgeesx(mLapack);
- init_lapack_stgex2(mLapack);
- init_lapack_ctgsna(mLapack);
- init_lapack_dlauum(mLapack);
- init_lapack_cgetf2(mLapack);
- init_lapack_dtgsna(mLapack);
- init_lapack_crot(mLapack);
- init_lapack_zpotrs(mLapack);
- init_lapack_cpftrf(mLapack);
- init_lapack_zgbsv(mLapack);
- init_lapack_cpttrs(mLapack);
- init_lapack_slarfx(mLapack);
- init_lapack_chprfs(mLapack);
- init_lapack_sgecon(mLapack);
- init_lapack_dlartgp(mLapack);
- init_lapack_dgebak(mLapack);
- init_lapack_ssbtrd(mLapack);
- init_lapack_cggbal(mLapack);
- init_lapack_dlaed2(mLapack);
- init_lapack_zgbbrd(mLapack);
- init_lapack_dorg2l(mLapack);
- init_lapack_dsygs2(mLapack);
- init_lapack_ssyev(mLapack);
- init_lapack_dgerfs(mLapack);
- init_lapack_cpbtrs(mLapack);
- init_lapack_zlaesy(mLapack);
- init_lapack_zla_herfsx_extended(mLapack);
- init_lapack_dspcon(mLapack);
- init_lapack_slaqge(mLapack);
- init_lapack_cposv(mLapack);
- init_lapack_dppcon(mLapack);
- init_lapack_sgeequ(mLapack);
- init_lapack_slamrg(mLapack);
- init_lapack_dgesvx(mLapack);
- init_lapack_zgegs(mLapack);
- init_lapack_dlaset(mLapack);
- init_lapack_sstevx(mLapack);
- init_lapack_dtgsyl(mLapack);
- init_lapack_zposv(mLapack);
- init_lapack_zhpgvd(mLapack);
- init_lapack_dlargv(mLapack);
- init_lapack_sgeev(mLapack);
- init_lapack_clahqr(mLapack);
- init_lapack_cgbtrf(mLapack);
- init_lapack_dsytrs(mLapack);
- init_lapack_ztgsy2(mLapack);
- init_lapack_zlatzm(mLapack);
- init_lapack_zgetrs(mLapack);
- init_lapack_slarfgp(mLapack);
- init_lapack_zunmbr(mLapack);
- init_lapack_dlagts(mLapack);
- init_lapack_zgeev(mLapack);
- init_lapack_zlar2v(mLapack);
- init_lapack_sorgbr(mLapack);
- init_lapack_sggsvd(mLapack);
- init_lapack_chbgst(mLapack);
- init_lapack_zheevd(mLapack);
- init_lapack_dgesvxx(mLapack);
- init_lapack_sla_porpvgrw(mLapack);
- init_lapack_slaed5(mLapack);
- init_lapack_clarf(mLapack);
- init_lapack_clascl(mLapack);
- init_lapack_dgbrfsx(mLapack);
- init_lapack_cunml2(mLapack);
- init_lapack_ctrcon(mLapack);
- init_lapack_dsygst(mLapack);
- init_lapack_zla_rpvgrw(mLapack);
- init_lapack_dlaed4(mLapack);
- init_lapack_zlaqr4(mLapack);
- init_lapack_csysvxx(mLapack);
- init_lapack_zpoequb(mLapack);
- init_lapack_zgghrd(mLapack);
- init_lapack_chptrf(mLapack);
- init_lapack_dgsvj1(mLapack);
- init_lapack_dhseqr(mLapack);
- init_lapack_dlasv2(mLapack);
- init_lapack_cpteqr(mLapack);
- init_lapack_sggsvp(mLapack);
- init_lapack_cspsvx(mLapack);
- init_lapack_zungql(mLapack);
- init_lapack_ztrttp(mLapack);
- init_lapack_zgelsd(mLapack);
- init_lapack_dlaein(mLapack);
- init_lapack_slaqr2(mLapack);
- init_lapack_dlagtm(mLapack);
- init_lapack_dlasd1(mLapack);
- init_lapack_zla_syamv(mLapack);
- init_lapack_cpptrf(mLapack);
- init_lapack_dlaed5(mLapack);
- init_lapack_cgbrfs(mLapack);
- init_lapack_dlaqr4(mLapack);
- init_lapack_cgesv(mLapack);
- init_lapack_checon(mLapack);
- init_lapack_zgelqf(mLapack);
- init_lapack_zlansb(mLapack);
- init_lapack_zla_porcond_x(mLapack);
- init_lapack_slarrf(mLapack);
- init_lapack_strti2(mLapack);
- init_lapack_sorm2l(mLapack);
- init_lapack_zhpevd(mLapack);
- init_lapack_zposvxx(mLapack);
- init_lapack_csyswapr(mLapack);
- init_lapack_sptsv(mLapack);
- init_lapack_zstemr(mLapack);
- init_lapack_zhetf2(mLapack);
- init_lapack_dtbcon(mLapack);
- init_lapack_dlaev2(mLapack);
- init_lapack_ssysv(mLapack);
- init_lapack_dla_gbrpvgrw(mLapack);
- init_lapack_cgtts2(mLapack);
- init_lapack_dsyconv(mLapack);
- init_lapack_cgtcon(mLapack);
- init_lapack_zlantb(mLapack);
- init_lapack_sormrz(mLapack);
- init_lapack_zgeqrfp(mLapack);
- init_lapack_sgeqrfp(mLapack);
- init_lapack_zgges(mLapack);
- init_lapack_slassq(mLapack);
- init_lapack_stftri(mLapack);
- init_lapack_ssytrf(mLapack);
- init_lapack_sgebak(mLapack);
- init_lapack_ztbcon(mLapack);
- init_lapack_ssygst(mLapack);
- init_lapack_dbbcsd(mLapack);
- init_lapack_spbsv(mLapack);
- init_lapack_csyrfsx(mLapack);
- init_lapack_slaev2(mLapack);
- init_lapack_dgbsvxx(mLapack);
- init_lapack_zcgesv(mLapack);
- init_lapack_zsyr(mLapack);
- init_lapack_slas2(mLapack);
- init_lapack_clauum(mLapack);
- init_lapack_zspmv(mLapack);
- init_lapack_csyrfs(mLapack);
- init_lapack_clatzm(mLapack);
- init_lapack_claqr0(mLapack);
- init_lapack_dgbsv(mLapack);
- init_lapack_ilauplo(mLapack);
- init_lapack_cla_gbrcond_c(mLapack);
- init_lapack_zheevx(mLapack);
- init_lapack_csptrf(mLapack);
- init_lapack_cladiv(mLapack);
- init_lapack_spstf2(mLapack);
- init_lapack_claqhp(mLapack);
- init_lapack_dla_rpvgrw(mLapack);
- init_lapack_dgtcon(mLapack);
- init_lapack_zlaqp2(mLapack);
- init_lapack_slapy2(mLapack);
- init_lapack_spptri(mLapack);
- init_lapack_sptcon(mLapack);
- init_lapack_ssbevd(mLapack);
- init_lapack_cggbak(mLapack);
- init_lapack_cunmr2(mLapack);
- init_lapack_dgesvj(mLapack);
- init_lapack_cpptri(mLapack);
- init_lapack_slarzt(mLapack);
- init_lapack_zla_porpvgrw(mLapack);
- init_lapack_dla_syamv(mLapack);
- init_lapack_zlartg(mLapack);
- init_lapack_ieeeck(mLapack);
- init_lapack_sgeqr2p(mLapack);
- init_lapack_slasq6(mLapack);
- init_lapack_zgesv(mLapack);
- init_lapack_shgeqz(mLapack);
- init_lapack_ctrevc(mLapack);
- init_lapack_sgegs(mLapack);
- init_lapack_cporfs(mLapack);
- init_lapack_dlasq1(mLapack);
- init_lapack_dsysvxx(mLapack);
- init_lapack_chbgvx(mLapack);
- init_lapack_zgelsx(mLapack);
- init_lapack_zggsvp(mLapack);
- init_lapack_sppsvx(mLapack);
- init_lapack_cgelsd(mLapack);
- init_lapack_dpocon(mLapack);
- init_lapack_sopgtr(mLapack);
- init_lapack_slarre(mLapack);
- init_lapack_zlargv(mLapack);
- init_lapack_cpptrs(mLapack);
- init_lapack_zuncsd(mLapack);
- init_lapack_zunmtr(mLapack);
- init_lapack_cgees(mLapack);
- init_lapack_stgsy2(mLapack);
- init_lapack_dlasd0(mLapack);
- init_lapack_slasd0(mLapack);
- init_lapack_dsbevd(mLapack);
- init_lapack_cgbsv(mLapack);
- init_lapack_dla_porcond(mLapack);
- init_lapack_cptsvx(mLapack);
- init_lapack_chetrf(mLapack);
- init_lapack_sgtsvx(mLapack);
- init_lapack_clacon(mLapack);
- init_lapack_dpftrs(mLapack);
- init_lapack_xerbla(mLapack);
- init_lapack_clatrz(mLapack);
- init_lapack_ctrsyl(mLapack);
- init_lapack_cgges(mLapack);
- init_lapack_cgetrs(mLapack);
- init_lapack_sormtr(mLapack);
- init_lapack_chpevx(mLapack);
- init_lapack_dla_lin_berr(mLapack);
- init_lapack_csyequb(mLapack);
- init_lapack_ztrtri(mLapack);
- init_lapack_chpevd(mLapack);
- init_lapack_sgees(mLapack);
- init_lapack_csytri2x(mLapack);
- init_lapack_zsyrfs(mLapack);
- init_lapack_zlanhs(mLapack);
- init_lapack_dgbbrd(mLapack);
- init_lapack_slangt(mLapack);
- init_lapack_clalsd(mLapack);
- init_lapack_ctrsen(mLapack);
- init_lapack_dpoequb(mLapack);
- init_lapack_dla_gerfsx_extended(mLapack);
- init_lapack_zggsvd(mLapack);
- init_lapack_dtpcon(mLapack);
- init_lapack_ztgsja(mLapack);
- init_lapack_zlacrt(mLapack);
- init_lapack_dlarrr(mLapack);
- init_lapack_dormrq(mLapack);
- init_lapack_cungrq(mLapack);
- init_lapack_zlals0(mLapack);
- init_lapack_cgebrd(mLapack);
- init_lapack_cpbtrf(mLapack);
- init_lapack_clargv(mLapack);
- init_lapack_dstevr(mLapack);
- init_lapack_dlasd4(mLapack);
- init_lapack_cpotrf(mLapack);
- init_lapack_sgbsvx(mLapack);
- init_lapack_zhbevx(mLapack);
- init_lapack_dpptrs(mLapack);
- init_lapack_sporfs(mLapack);
- init_lapack_clabrd(mLapack);
- init_lapack_ssyevx(mLapack);
- init_lapack_cptsv(mLapack);
- init_lapack_ctptri(mLapack);
- init_lapack_slasr(mLapack);
- init_lapack_dtgsen(mLapack);
- init_lapack_cunghr(mLapack);
- init_lapack_clatps(mLapack);
- init_lapack_stgsja(mLapack);
- init_lapack_zsysvx(mLapack);
- init_lapack_ssygs2(mLapack);
- init_lapack_zlanhe(mLapack);
- init_lapack_sgelq2(mLapack);
- init_lapack_cunmrz(mLapack);
- init_lapack_ssygv(mLapack);
- init_lapack_slabad(mLapack);
- init_lapack_clar1v(mLapack);
- init_lapack_sspgv(mLapack);
- init_lapack_sgbrfs(mLapack);
- init_lapack_dlasd2(mLapack);
- init_lapack_clanhb(mLapack);
- init_lapack_dorg2r(mLapack);
- init_lapack_dla_geamv(mLapack);
- init_lapack_clangt(mLapack);
- init_lapack_dgebal(mLapack);
- init_lapack_cla_gerfsx_extended(mLapack);
- init_lapack_slaed0(mLapack);
- init_lapack_cla_wwaddw(mLapack);
- init_lapack_sstegr(mLapack);
- init_lapack_dggesx(mLapack);
- init_lapack_slansf(mLapack);
- init_lapack_slaein(mLapack);
- init_lapack_ztrttf(mLapack);
- init_lapack_dlatdf(mLapack);
- init_lapack_zlatdf(mLapack);
- init_lapack_sgeql2(mLapack);
- init_lapack_zlacn2(mLapack);
- init_lapack_sgeesx(mLapack);
- init_lapack_dggglm(mLapack);
- init_lapack_dlaqsy(mLapack);
- init_lapack_dpotrs(mLapack);
- init_lapack_zsprfs(mLapack);
- init_lapack_slasd7(mLapack);
- init_lapack_cla_geamv(mLapack);
- init_lapack_zsytrs(mLapack);
- init_lapack_cla_syrfsx_extended(mLapack);
- init_lapack_dgges(mLapack);
- init_lapack_dgeqrfp(mLapack);
- init_lapack_slaset(mLapack);
- init_lapack_zhetrs(mLapack);
- init_lapack_dlacn2(mLapack);
- init_lapack_cla_herfsx_extended(mLapack);
- init_lapack_dsycon(mLapack);
- init_lapack_dlarrc(mLapack);
- init_lapack_zgbsvxx(mLapack);
- init_lapack_dsptrf(mLapack);
- init_lapack_sporfsx(mLapack);
- init_lapack_ilaenv(mLapack);
- init_lapack_strtrs(mLapack);
- init_lapack_cppequ(mLapack);
- init_lapack_slaed4(mLapack);
- init_lapack_zlagtm(mLapack);
- init_lapack_dormbr(mLapack);
- init_lapack_dlarzb(mLapack);
- init_lapack_zhetrf(mLapack);
- init_lapack_clartg(mLapack);
- init_lapack_dsterf(mLapack);
- init_lapack_zhpgst(mLapack);
- init_lapack_ctgex2(mLapack);
- init_lapack_clange(mLapack);
- init_lapack_dlaed3(mLapack);
- init_lapack_dsgesv(mLapack);
- init_lapack_dpftri(mLapack);
- init_lapack_dggbal(mLapack);
- init_lapack_dspevx(mLapack);
- init_lapack_slansb(mLapack);
- init_lapack_sgglse(mLapack);
- init_lapack_cpotf2(mLapack);
- init_lapack_dpbtrs(mLapack);
- init_lapack_clarfb(mLapack);
- init_lapack_clanhs(mLapack);
- init_lapack_sla_gbrfsx_extended(mLapack);
- init_lapack_zlatrs(mLapack);
- init_lapack_ztrsyl(mLapack);
- init_lapack_slalsa(mLapack);
- init_lapack_csytf2(mLapack);
- init_lapack_zlarft(mLapack);
- init_lapack_dlabrd(mLapack);
- init_lapack_sspsvx(mLapack);
- init_lapack_zhseqr(mLapack);
- init_lapack_zgelq2(mLapack);
- init_lapack_zherfs(mLapack);
- init_lapack_dtfttp(mLapack);
- init_lapack_zlasr(mLapack);
- init_lapack_stptrs(mLapack);
- init_lapack_sla_syamv(mLapack);
- init_lapack_cgeqr2p(mLapack);
- init_lapack_sstev(mLapack);
- init_lapack_sgesvxx(mLapack);
- init_lapack_ssptrs(mLapack);
- init_lapack_cunmqr(mLapack);
- init_lapack_zhpgv(mLapack);
- init_lapack_zlalsd(mLapack);
- init_lapack_clansy(mLapack);
- init_lapack_ssyevd(mLapack);
- init_lapack_ssyrfs(mLapack);
- init_lapack_claqsb(mLapack);
- init_lapack_cunmrq(mLapack);
- init_lapack_sgeqlf(mLapack);
- init_lapack_ztrtrs(mLapack);
- init_lapack_dpbequ(mLapack);
- init_lapack_zggbal(mLapack);
- init_lapack_dspgv(mLapack);
- init_lapack_dlarrf(mLapack);
- init_lapack_dpbstf(mLapack);
- init_lapack_zgesvd(mLapack);
- init_lapack_cgbbrd(mLapack);
- init_lapack_ssytd2(mLapack);
- init_lapack_zupgtr(mLapack);
- init_lapack_slantp(mLapack);
- init_lapack_ssbevx(mLapack);
- init_lapack_ctrsna(mLapack);
- init_lapack_zlarfg(mLapack);
- init_lapack_slasq2(mLapack);
- init_lapack_zherfsx(mLapack);
- init_lapack_clarfx(mLapack);
- init_lapack_zpptrf(mLapack);
- init_lapack_zggevx(mLapack);
- init_lapack_chpgv(mLapack);
- init_lapack_slarft(mLapack);
- init_lapack_sgesdd(mLapack);
- init_lapack_zsytri2x(mLapack);
- init_lapack_dsytri(mLapack);
- init_lapack_spocon(mLapack);
- init_lapack_sgtts2(mLapack);
- init_lapack_sgesvd(mLapack);
- init_lapack_clantp(mLapack);
- init_lapack_dlalsd(mLapack);
- init_lapack_ctrtri(mLapack);
- init_lapack_cstemr(mLapack);
- init_lapack_zlanht(mLapack);
- init_lapack_ctptrs(mLapack);
- init_lapack_dlarrv(mLapack);
- init_lapack_ztgex2(mLapack);
- init_lapack_sla_porcond(mLapack);
- init_lapack_zgeqlf(mLapack);
- init_lapack_dlaexc(mLapack);
- init_lapack_zgecon(mLapack);
- init_lapack_cgghrd(mLapack);
- init_lapack_sggesx(mLapack);
- init_lapack_dtrevc(mLapack);
- init_lapack_spotf2(mLapack);
- init_lapack_cgelsx(mLapack);
- init_lapack_zhesv(mLapack);
- init_lapack_zhegs2(mLapack);
- init_lapack_strrfs(mLapack);
- init_lapack_zlarz(mLapack);
- init_lapack_dsbgst(mLapack);
- init_lapack_dopgtr(mLapack);
- init_lapack_zlaic1(mLapack);
- init_lapack_iladlc(mLapack);
- init_lapack_dla_gercond(mLapack);
- init_lapack_sla_geamv(mLapack);
- init_lapack_dgegs(mLapack);
- init_lapack_zungr2(mLapack);
- init_lapack_dlaqgb(mLapack);
- init_lapack_zhptrd(mLapack);
- init_lapack_dorgrq(mLapack);
- init_lapack_csysv(mLapack);
- init_lapack_slaqsb(mLapack);
- init_lapack_zlaqr3(mLapack);
- init_lapack_sspgvx(mLapack);
- init_lapack_chetrd(mLapack);
- init_lapack_chetd2(mLapack);
- init_lapack_zgetc2(mLapack);
- init_lapack_sstevd(mLapack);
- init_lapack_dsyevd(mLapack);
- init_lapack_dpotrf(mLapack);
- init_lapack_dpstf2(mLapack);
- init_lapack_zhegvd(mLapack);
- init_lapack_cungql(mLapack);
- init_lapack_zgeqr2(mLapack);
- init_lapack_zlaqge(mLapack);
- init_lapack_cgesdd(mLapack);
- init_lapack_sggbak(mLapack);
- init_lapack_zhsein(mLapack);
- init_lapack_zunbdb(mLapack);
- init_lapack_clarfg(mLapack);
- init_lapack_slansy(mLapack);
- init_lapack_dstev(mLapack);
- init_lapack_dgbtrs(mLapack);
- init_lapack_zgeql2(mLapack);
- init_lapack_slahqr(mLapack);
- init_lapack_zheev(mLapack);
- init_lapack_chbev(mLapack);
- init_lapack_cgbrfsx(mLapack);
- init_lapack_sppcon(mLapack);
- init_lapack_zhesvxx(mLapack);
- init_lapack_clantr(mLapack);
- init_lapack_dpoequ(mLapack);
- init_lapack_zgbsvx(mLapack);
- init_lapack_zsyequb(mLapack);
- init_lapack_ssytri2(mLapack);
- init_lapack_zlarcm(mLapack);
- init_lapack_chfrk(mLapack);
- init_lapack_cgetrf(mLapack);
- init_lapack_zhecon(mLapack);
- init_lapack_spbtrf(mLapack);
- init_lapack_zgerfsx(mLapack);
- init_lapack_sppequ(mLapack);
- init_lapack_cgttrs(mLapack);
- init_lapack_dlarfgp(mLapack);
- init_lapack_zgegv(mLapack);
- init_lapack_zlags2(mLapack);
- init_lapack_zungbr(mLapack);
- init_lapack_dlarzt(mLapack);
- init_lapack_clacpy(mLapack);
- init_lapack_dorgr2(mLapack);
- init_lapack_chetri(mLapack);
- init_lapack_slaqgb(mLapack);
- init_lapack_dlapmt(mLapack);
- init_lapack_dlags2(mLapack);
- init_lapack_sorghr(mLapack);
- init_lapack_dggsvp(mLapack);
- init_lapack_zlar1v(mLapack);
- init_lapack_dlaqge(mLapack);
- init_lapack_ilazlc(mLapack);
- init_lapack_slarrv(mLapack);
- init_lapack_sorgrq(mLapack);
- init_lapack_sgtcon(mLapack);
- init_lapack_dlapll(mLapack);
- init_lapack_cgeevx(mLapack);
- init_lapack_zla_gbrcond_x(mLapack);
- init_lapack_zhegv(mLapack);
- init_lapack_dlanv2(mLapack);
- init_lapack_clapmr(mLapack);
- init_lapack_dggevx(mLapack);
- init_lapack_dlarfb(mLapack);
- init_lapack_slapmt(mLapack);
- init_lapack_chpsvx(mLapack);
- init_lapack_dpbsv(mLapack);
- init_lapack_cgeequb(mLapack);
- init_lapack_slalsd(mLapack);
- init_lapack_chegst(mLapack);
- init_lapack_sspevd(mLapack);
- init_lapack_claqhb(mLapack);
- init_lapack_sorgr2(mLapack);
- init_lapack_zupmtr(mLapack);
- init_lapack_dorgtr(mLapack);
- init_lapack_zgesc2(mLapack);
- init_lapack_zlaswp(mLapack);
- init_lapack_zsysvxx(mLapack);
- init_lapack_dzsum1(mLapack);
- init_lapack_dlaed6(mLapack);
- init_lapack_zpftrs(mLapack);
- init_lapack_strsyl(mLapack);
- init_lapack_slarrc(mLapack);
- init_lapack_zla_gercond_x(mLapack);
- init_lapack_zhbgst(mLapack);
- init_lapack_cla_porcond_c(mLapack);
- init_lapack_dgeqr2p(mLapack);
- init_lapack_sspev(mLapack);
- init_lapack_cgbequb(mLapack);
- init_lapack_sorgqr(mLapack);
- init_lapack_dlarre(mLapack);
- init_lapack_dtptri(mLapack);
- init_lapack_zlatbs(mLapack);
- init_lapack_zpprfs(mLapack);
- init_lapack_dpbsvx(mLapack);
- init_lapack_cstegr(mLapack);
- init_lapack_dgbsvx(mLapack);
- init_lapack_clatrs(mLapack);
- init_lapack_sormr3(mLapack);
- init_lapack_stpttf(mLapack);
- init_lapack_zpftrf(mLapack);
- init_lapack_dgehrd(mLapack);
- init_lapack_dlag2(mLapack);
- init_lapack_ztptrs(mLapack);
- init_lapack_sstebz(mLapack);
- init_lapack_dpstrf(mLapack);
- init_lapack_zhptri(mLapack);
- init_lapack_sgehrd(mLapack);
- init_lapack_spbtrs(mLapack);
- init_lapack_slaed3(mLapack);
- init_lapack_cla_gercond_c(mLapack);
- init_lapack_zlaqgb(mLapack);
- init_lapack_dla_gbamv(mLapack);
- init_lapack_ilazlr(mLapack);
- init_lapack_chbgvd(mLapack);
- init_lapack_ssysvx(mLapack);
- init_lapack_clapmt(mLapack);
- init_lapack_ctfttr(mLapack);
- init_lapack_dlacpy(mLapack);
- init_lapack_dtgevc(mLapack);
- init_lapack_dtrttp(mLapack);
- init_lapack_dtrsna(mLapack);
- init_lapack_dgeesx(mLapack);
- init_lapack_zlarfgp(mLapack);
- init_lapack_slahr2(mLapack);
- init_lapack_sgesvj(mLapack);
- init_lapack_dspsvx(mLapack);
- init_lapack_dlals0(mLapack);
- init_lapack_sgelqf(mLapack);
- init_lapack_sptsvx(mLapack);
- init_lapack_cherfsx(mLapack);
- init_lapack_ctprfs(mLapack);
- init_lapack_dgelsd(mLapack);
- init_lapack_dgbtrf(mLapack);
- init_lapack_sla_gercond(mLapack);
- init_lapack_zhbtrd(mLapack);
- init_lapack_cung2l(mLapack);
- init_lapack_zgeqrf(mLapack);
- init_lapack_claqge(mLapack);
- init_lapack_sstein(mLapack);
- init_lapack_slaed2(mLapack);
- init_lapack_csrscl(mLapack);
- init_lapack_slaqtr(mLapack);
- init_lapack_ctfsm(mLapack);
- init_lapack_zlartv(mLapack);
- init_lapack_dtrrfs(mLapack);
- init_lapack_slatzm(mLapack);
- init_lapack_dlarrd(mLapack);
- init_lapack_dlaruv(mLapack);
- init_lapack_dtfsm(mLapack);
- init_lapack_clar2v(mLapack);
- init_lapack_zlag2c(mLapack);
- init_lapack_zpotf2(mLapack);
- init_lapack_ilaver(mLapack);
- init_lapack_zgttrf(mLapack);
- init_lapack_sla_rpvgrw(mLapack);
- init_lapack_dormhr(mLapack);
- init_lapack_dlaqr0(mLapack);
- init_lapack_cggqrf(mLapack);
- init_lapack_zunml2(mLapack);
- init_lapack_spptrf(mLapack);
- init_lapack_claqr3(mLapack);
- init_lapack_zlangt(mLapack);
-}
diff --git a/rb_lapack.h b/rb_lapack.h
deleted file mode 100644
index a1eafcd..0000000
--- a/rb_lapack.h
+++ /dev/null
@@ -1,11 +0,0 @@
-#include <string.h>
-#include <math.h>
-#include "ruby.h"
-#include "narray.h"
-#include "f2c_minimal.h"
-
-#define MAX(a,b) (a > b ? a : b)
-#define MIN(a,b) (a < b ? a : b)
-#define LG(n) ((int)ceil(log((double)n)/log(2.0)))
-
-extern logical lsame_(char *ca, char *cb);
diff --git a/samples/dsyevr.rb b/samples/dsyevr.rb
index 6c17776..a3ac3ee 100644
--- a/samples/dsyevr.rb
+++ b/samples/dsyevr.rb
@@ -13,7 +13,7 @@ liwork = 30
m, w, z, isuppz, work, iwork, info, a =
NumRu::Lapack.dsyevr(jobz, range, uplo,
- a, vl, vu, il, iu, abstol, lwork, liwork)
+ a, vl, vu, il, iu, abstol, :lwork => lwork, :liwork => liwork)
p m
p w
@@ -23,37 +23,3 @@ p work
p iwork
p info
p a
-
-
-# result test
-eps = 1.0e-14
-
-flag = m==3
-
-flag &&= w[0].abs < eps
-flag &&= (w[1]-1.0).abs < eps
-flag &&= (w[2]-3.0).abs < eps
-
-sqrt2 = Math.sqrt(1/2.0)
-sqrt3 = Math.sqrt(1/3.0)
-sqrt6 = Math.sqrt(1/6.0)
-flag &&= (z[0,0]-sqrt3).abs < eps
-flag &&= (z[1,0]+sqrt3).abs < eps
-flag &&= (z[2,0]-sqrt3).abs < eps
-flag &&= (z[0,1]+sqrt2).abs < eps
-flag &&= z[1,1].abs < eps
-flag &&= (z[2,1]-sqrt2).abs < eps
-flag &&= (z[0,2]-sqrt6).abs < eps
-flag &&= (z[1,2]-sqrt6*2).abs < eps
-flag &&= (z[2,2]-sqrt6).abs < eps
-
-flag &&= (isuppz == NArray[1,3,1,3,1,3])
-flag &&= work[0].to_i == 78
-flag &&= iwork[0] == 30
-flag &&= info == 0
-
-if flag
- print "OK\n"
-else
- print "NG\n"
-end
diff --git a/sbbcsd.c b/sbbcsd.c
deleted file mode 100644
index 521a8eb..0000000
--- a/sbbcsd.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sbbcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, integer *m, integer *p, integer *q, real *theta, real *phi, real *u1, integer *ldu1, real *u2, integer *ldu2, real *v1t, integer *ldv1t, real *v2t, integer *ldv2t, real *b11d, real *b11e, real *b12d, real *b12e, real *b21d, real *b21e, real *b22d, real *b22e, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sbbcsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_theta;
- real *theta;
- VALUE rb_phi;
- real *phi;
- VALUE rb_u1;
- real *u1;
- VALUE rb_u2;
- real *u2;
- VALUE rb_v1t;
- real *v1t;
- VALUE rb_v2t;
- real *v2t;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_b11d;
- real *b11d;
- VALUE rb_b11e;
- real *b11e;
- VALUE rb_b12d;
- real *b12d;
- VALUE rb_b12e;
- real *b12e;
- VALUE rb_b21d;
- real *b21d;
- VALUE rb_b21e;
- real *b21e;
- VALUE rb_b22d;
- real *b22d;
- VALUE rb_b22e;
- real *b22e;
- VALUE rb_info;
- integer info;
- VALUE rb_theta_out__;
- real *theta_out__;
- VALUE rb_u1_out__;
- real *u1_out__;
- VALUE rb_u2_out__;
- real *u2_out__;
- VALUE rb_v1t_out__;
- real *v1t_out__;
- VALUE rb_v2t_out__;
- real *v2t_out__;
- real *work;
-
- integer q;
- integer ldu1;
- integer p;
- integer ldu2;
- integer ldv1t;
- integer ldv2t;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.sbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, lwork)\n or\n NumRu::Lapack.sbbcsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SBBCSD computes the CS decomposition of an orthogonal matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See SORCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the orthogonal matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) REAL array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) REAL array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) REAL array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) REAL array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) REAL array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) REAL array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) REAL array, dimension (Q)\n* When SBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If SBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) REAL array, dimension (Q-1)\n* When SBBCSD converges, B11E contains zeros. If SBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) REAL array, dimension (Q)\n* When SBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If SBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) REAL array, dimension (Q-1)\n* When SBBCSD converges, B12E contains zeros. If SBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* WORK (workspace) 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 >= MAX(1,8*Q).\n*\n* If LWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the WORK array,\n* returns this value as the first entry of the work array, and\n* no error 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* > 0: if SBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_m = argv[5];
- rb_theta = argv[6];
- rb_phi = argv[7];
- rb_u1 = argv[8];
- rb_u2 = argv[9];
- rb_v1t = argv[10];
- rb_v2t = argv[11];
- rb_lwork = argv[12];
-
- if (!NA_IsNArray(rb_theta))
- rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
- if (NA_RANK(rb_theta) != 1)
- rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
- q = NA_SHAPE0(rb_theta);
- if (NA_TYPE(rb_theta) != NA_SFLOAT)
- rb_theta = na_change_type(rb_theta, NA_SFLOAT);
- theta = NA_PTR_TYPE(rb_theta, real*);
- jobu1 = StringValueCStr(rb_jobu1)[0];
- trans = StringValueCStr(rb_trans)[0];
- m = NUM2INT(rb_m);
- jobu2 = StringValueCStr(rb_jobu2)[0];
- if (!NA_IsNArray(rb_v1t))
- rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
- if (NA_RANK(rb_v1t) != 2)
- rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v1t) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
- ldv1t = NA_SHAPE0(rb_v1t);
- if (NA_TYPE(rb_v1t) != NA_SFLOAT)
- rb_v1t = na_change_type(rb_v1t, NA_SFLOAT);
- v1t = NA_PTR_TYPE(rb_v1t, real*);
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- if (!NA_IsNArray(rb_u1))
- rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
- if (NA_RANK(rb_u1) != 2)
- rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
- p = NA_SHAPE1(rb_u1);
- ldu1 = NA_SHAPE0(rb_u1);
- if (NA_TYPE(rb_u1) != NA_SFLOAT)
- rb_u1 = na_change_type(rb_u1, NA_SFLOAT);
- u1 = NA_PTR_TYPE(rb_u1, real*);
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_u2))
- rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
- if (NA_RANK(rb_u2) != 2)
- rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u2) != (m-p))
- rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
- ldu2 = NA_SHAPE0(rb_u2);
- if (NA_TYPE(rb_u2) != NA_SFLOAT)
- rb_u2 = na_change_type(rb_u2, NA_SFLOAT);
- u2 = NA_PTR_TYPE(rb_u2, real*);
- if (!NA_IsNArray(rb_phi))
- rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
- if (NA_RANK(rb_phi) != 1)
- rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_phi) != (q-1))
- rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
- if (NA_TYPE(rb_phi) != NA_SFLOAT)
- rb_phi = na_change_type(rb_phi, NA_SFLOAT);
- phi = NA_PTR_TYPE(rb_phi, real*);
- if (!NA_IsNArray(rb_v2t))
- rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
- if (NA_RANK(rb_v2t) != 2)
- rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v2t) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
- ldv2t = NA_SHAPE0(rb_v2t);
- if (NA_TYPE(rb_v2t) != NA_SFLOAT)
- rb_v2t = na_change_type(rb_v2t, NA_SFLOAT);
- v2t = NA_PTR_TYPE(rb_v2t, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b11d = NA_PTR_TYPE(rb_b11d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b11e = NA_PTR_TYPE(rb_b11e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b12d = NA_PTR_TYPE(rb_b12d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b12e = NA_PTR_TYPE(rb_b12e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b21d = NA_PTR_TYPE(rb_b21d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b21e = NA_PTR_TYPE(rb_b21e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b22d = NA_PTR_TYPE(rb_b22d, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b22e = NA_PTR_TYPE(rb_b22e, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_theta_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- theta_out__ = NA_PTR_TYPE(rb_theta_out__, real*);
- MEMCPY(theta_out__, theta, real, NA_TOTAL(rb_theta));
- rb_theta = rb_theta_out__;
- theta = theta_out__;
- {
- int shape[2];
- shape[0] = ldu1;
- shape[1] = p;
- rb_u1_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u1_out__ = NA_PTR_TYPE(rb_u1_out__, real*);
- MEMCPY(u1_out__, u1, real, NA_TOTAL(rb_u1));
- rb_u1 = rb_u1_out__;
- u1 = u1_out__;
- {
- int shape[2];
- shape[0] = ldu2;
- shape[1] = m-p;
- rb_u2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u2_out__ = NA_PTR_TYPE(rb_u2_out__, real*);
- MEMCPY(u2_out__, u2, real, NA_TOTAL(rb_u2));
- rb_u2 = rb_u2_out__;
- u2 = u2_out__;
- {
- int shape[2];
- shape[0] = ldv1t;
- shape[1] = q;
- rb_v1t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v1t_out__ = NA_PTR_TYPE(rb_v1t_out__, real*);
- MEMCPY(v1t_out__, v1t, real, NA_TOTAL(rb_v1t));
- rb_v1t = rb_v1t_out__;
- v1t = v1t_out__;
- {
- int shape[2];
- shape[0] = ldv2t;
- shape[1] = m-q;
- rb_v2t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v2t_out__ = NA_PTR_TYPE(rb_v2t_out__, real*);
- MEMCPY(v2t_out__, v2t, real, NA_TOTAL(rb_v2t));
- rb_v2t = rb_v2t_out__;
- v2t = v2t_out__;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- sbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(14, rb_b11d, rb_b11e, rb_b12d, rb_b12e, rb_b21d, rb_b21e, rb_b22d, rb_b22e, rb_info, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t);
-}
-
-void
-init_lapack_sbbcsd(VALUE mLapack){
- rb_define_module_function(mLapack, "sbbcsd", rb_sbbcsd, -1);
-}
diff --git a/sbdsdc.c b/sbdsdc.c
deleted file mode 100644
index 8e128b2..0000000
--- a/sbdsdc.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sbdsdc_(char *uplo, char *compq, integer *n, real *d, real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q, integer *iq, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sbdsdc(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_compq;
- char compq;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_ldu;
- integer ldu;
- VALUE rb_ldvt;
- integer ldvt;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_q;
- real *q;
- VALUE rb_iq;
- integer *iq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer c__9;
- integer c__0;
- integer ldq;
- integer ldiq;
- integer lwork;
- integer smlsiz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n u, vt, q, iq, info, d, e = NumRu::Lapack.sbdsdc( uplo, compq, d, e, ldu, ldvt)\n or\n NumRu::Lapack.sbdsdc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SBDSDC computes the singular value decomposition (SVD) of a real\n* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,\n* using a divide and conquer method, where S is a diagonal matrix\n* with non-negative diagonal elements (the singular values of B), and\n* U and VT are orthogonal matrices of left and right singular vectors,\n* respectively. SBDSDC can be used to compute all singular values,\n* and optionally, singular vectors or singular vectors in compact form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See SLASD3 for details.\n*\n* The code currently calls SLASDQ if singular values only are desired.\n* However, it can be slightly modified to compute singular values\n* using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal.\n* = 'L': B is lower bidiagonal.\n*\n* COMPQ (input) CHARACTER*1\n* Specifies whether singular vectors are to be computed\n* as follows:\n* = 'N': Compute singular values only;\n* = 'P': Compute singular values and compute singular\n* vectors in compact form;\n* = 'I': Compute singular values and singular vectors.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the elements of E contain the offdiagonal\n* elements of the bidiagonal matrix whose SVD is desired.\n* On exit, E has been destroyed.\n*\n* U (output) REAL array, dimension (LDU,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, U contains the left singular vectors\n* of the bidiagonal matrix.\n* For other values of COMPQ, U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1.\n* If singular vectors are desired, then LDU >= max( 1, N ).\n*\n* VT (output) REAL array, dimension (LDVT,N)\n* If COMPQ = 'I', then:\n* On exit, if INFO = 0, VT' contains the right singular\n* vectors of the bidiagonal matrix.\n* For other values of COMPQ, VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1.\n* If singular vectors are desired, then LDVT >= max( 1, N ).\n*\n* Q (output) REAL array, dimension (LDQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, Q contains all the REAL data in\n* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, Q is not referenced.\n*\n* IQ (output) INTEGER array, dimension (LDIQ)\n* If COMPQ = 'P', then:\n* On exit, if INFO = 0, Q and IQ contain the left\n* and right singular vectors in a compact form,\n* requiring O(N log N) space instead of 2*N**2.\n* In particular, IQ contains all INTEGER data in\n* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n* words of memory, where SMLSIZ is returned by ILAENV and\n* is equal to the maximum size of the subproblems at the\n* bottom of the computation tree (usually about 25).\n* For other values of COMPQ, IQ is not referenced.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK))\n* If COMPQ = 'N' then LWORK >= (4 * N).\n* If COMPQ = 'P' then LWORK >= (6 * N).\n* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n*\n* IWORK (workspace) INTEGER array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value.\n* The update process of divide and conquer failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n* =====================================================================\n* Changed dimension statement in comment describing E from (N) to\n* (N-1). Sven, 17 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_compq = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_ldu = argv[4];
- rb_ldvt = argv[5];
-
- c__9 = 9;
- c__0 = 0;
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- compq = StringValueCStr(rb_compq)[0];
- ldvt = lsame_(&compq,"I") ? MAX(1,n) : 0;
- ldiq = lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0;
- lwork = lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0;
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- ldu = lsame_(&compq,"I") ? MAX(1,n) : 0;
- smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
- ldq = lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0;
- {
- int shape[2];
- shape[0] = lsame_(&compq,"I") ? ldu : 0;
- shape[1] = lsame_(&compq,"I") ? n : 0;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = lsame_(&compq,"I") ? ldvt : 0;
- shape[1] = lsame_(&compq,"I") ? n : 0;
- rb_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, real*);
- {
- int shape[1];
- shape[0] = lsame_(&compq,"I") ? ldq : 0;
- rb_q = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[1];
- shape[0] = lsame_(&compq,"I") ? ldiq : 0;
- rb_iq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iq = NA_PTR_TYPE(rb_iq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(real, (MAX(1,lwork)));
- iwork = ALLOC_N(integer, (8*n));
-
- sbdsdc_(&uplo, &compq, &n, d, e, u, &ldu, vt, &ldvt, q, iq, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_u, rb_vt, rb_q, rb_iq, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_sbdsdc(VALUE mLapack){
- rb_define_module_function(mLapack, "sbdsdc", rb_sbdsdc, -1);
-}
diff --git a/sbdsqr.c b/sbdsqr.c
deleted file mode 100644
index 45c6673..0000000
--- a/sbdsqr.c
+++ /dev/null
@@ -1,163 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sbdsqr_(char *uplo, integer *n, integer *ncvt, integer *nru, integer *ncc, real *d, real *e, real *vt, integer *ldvt, real *u, integer *ldu, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sbdsqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nru;
- integer nru;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vt;
- real *vt;
- VALUE rb_u;
- real *u;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_vt_out__;
- real *vt_out__;
- VALUE rb_u_out__;
- real *u_out__;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer n;
- integer ldvt;
- integer ncvt;
- integer ldu;
- integer ldc;
- integer ncc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.sbdsqr( uplo, nru, d, e, vt, u, c)\n or\n NumRu::Lapack.sbdsqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**T\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**T*VT instead of\n* P**T, for given real input matrices U and VT. When U and VT are the\n* orthogonal matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by SGEBRD, then\n* \n* A = (U*Q) * S * (P**T*VT)\n* \n* is the SVD of A. Optionally, the subroutine may also compute Q**T*C\n* for a given real input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B.\n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) REAL array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**T * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) REAL array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) REAL array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**T * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0:\n* if NCVT = NRU = NCC = 0,\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n* else NCVT = NRU = NCC = 0,\n* the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_nru = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vt = argv[4];
- rb_u = argv[5];
- rb_c = argv[6];
-
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (6th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_SFLOAT)
- rb_u = na_change_type(rb_u, NA_SFLOAT);
- u = NA_PTR_TYPE(rb_u, real*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
- ncvt = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_SFLOAT)
- rb_vt = na_change_type(rb_vt, NA_SFLOAT);
- vt = NA_PTR_TYPE(rb_vt, real*);
- nru = NUM2INT(rb_nru);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = ncvt;
- rb_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, real*);
- MEMCPY(vt_out__, vt, real, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, real*);
- MEMCPY(u_out__, u, real, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (4*n));
-
- sbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_info, rb_d, rb_e, rb_vt, rb_u, rb_c);
-}
-
-void
-init_lapack_sbdsqr(VALUE mLapack){
- rb_define_module_function(mLapack, "sbdsqr", rb_sbdsqr, -1);
-}
diff --git a/scsum1.c b/scsum1.c
deleted file mode 100644
index f349af4..0000000
--- a/scsum1.c
+++ /dev/null
@@ -1,44 +0,0 @@
-#include "rb_lapack.h"
-
-extern real scsum1_(integer *n, complex *cx, integer *incx);
-
-static VALUE
-rb_scsum1(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- complex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb___out__;
- real __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.scsum1( cx, incx)\n or\n NumRu::Lapack.scsum1 # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SCSUM1( N, CX, INCX )\n\n* Purpose\n* =======\n*\n* SCSUM1 takes the sum of the absolute values of a complex\n* vector and returns a single precision result.\n*\n* Based on SCASUM from the Level 1 BLAS.\n* The change is to use the 'genuine' absolute value.\n*\n* Contributed by Nick Higham for use with CLACON.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vector CX.\n*\n* CX (input) COMPLEX array, dimension (N)\n* The vector whose elements will be summed.\n*\n* INCX (input) INTEGER\n* The spacing between successive values of CX. INCX > 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, NINCX\n REAL STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
-
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cx);
- if (NA_TYPE(rb_cx) != NA_SCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_SCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, complex*);
-
- __out__ = scsum1_(&n, cx, &incx);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_scsum1(VALUE mLapack){
- rb_define_module_function(mLapack, "scsum1", rb_scsum1, -1);
-}
diff --git a/sdisna.c b/sdisna.c
deleted file mode 100644
index 26f159e..0000000
--- a/sdisna.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sdisna_(char *job, integer *m, integer *n, real *d, real *sep, integer *info);
-
-static VALUE
-rb_sdisna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_n;
- integer n;
- VALUE rb_d;
- real *d;
- VALUE rb_sep;
- real *sep;
- VALUE rb_info;
- integer info;
-
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sep, info = NumRu::Lapack.sdisna( job, n, d)\n or\n NumRu::Lapack.sdisna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )\n\n* Purpose\n* =======\n*\n* SDISNA computes the reciprocal condition numbers for the eigenvectors\n* of a real symmetric or complex Hermitian matrix or for the left or\n* right singular vectors of a general m-by-n matrix. The reciprocal\n* condition number is the 'gap' between the corresponding eigenvalue or\n* singular value and the nearest other one.\n*\n* The bound on the error, measured by angle in radians, in the I-th\n* computed vector is given by\n*\n* SLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n*\n* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed\n* to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of\n* the error bound.\n*\n* SDISNA may also be used to compute error bounds for eigenvectors of\n* the generalized symmetric definite eigenproblem.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies for which problem the reciprocal condition numbers\n* should be computed:\n* = 'E': the eigenvectors of a symmetric/Hermitian matrix;\n* = 'L': the left singular vectors of a general matrix;\n* = 'R': the right singular vectors of a general matrix.\n*\n* M (input) INTEGER\n* The number of rows of the matrix. M >= 0.\n*\n* N (input) INTEGER\n* If JOB = 'L' or 'R', the number of columns of the matrix,\n* in which case N >= 0. Ignored if JOB = 'E'.\n*\n* D (input) REAL array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The eigenvalues (if JOB = 'E') or singular values (if JOB =\n* 'L' or 'R') of the matrix, in either increasing or decreasing\n* order. If singular values, they must be non-negative.\n*\n* SEP (output) REAL array, dimension (M) if JOB = 'E'\n* dimension (min(M,N)) if JOB = 'L' or 'R'\n* The reciprocal condition numbers of the vectors.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_job = argv[0];
- rb_n = argv[1];
- rb_d = argv[2];
-
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = lsame_(&job,"E") ? m : ((lsame_(&job,"L")) || (lsame_(&job,"R"))) ? MIN(m,n) : 0;
- rb_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sep = NA_PTR_TYPE(rb_sep, real*);
-
- sdisna_(&job, &m, &n, d, sep, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_sep, rb_info);
-}
-
-void
-init_lapack_sdisna(VALUE mLapack){
- rb_define_module_function(mLapack, "sdisna", rb_sdisna, -1);
-}
diff --git a/sgbbrd.c b/sgbbrd.c
deleted file mode 100644
index 8436d14..0000000
--- a/sgbbrd.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbbrd_(char *vect, integer *m, integer *n, integer *ncc, integer *kl, integer *ku, real *ab, integer *ldab, real *d, real *e, real *q, integer *ldq, real *pt, integer *ldpt, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sgbbrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_c;
- real *c;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_q;
- real *q;
- VALUE rb_pt;
- real *pt;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer ldab;
- integer n;
- integer ldc;
- integer ncc;
- integer ldq;
- integer m;
- integer ldpt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.sgbbrd( vect, kl, ku, ab, c)\n or\n NumRu::Lapack.sgbbrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBBRD reduces a real general m-by-n band matrix A to upper\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) REAL array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) REAL array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) REAL array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) REAL array, dimension (2*max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- vect = StringValueCStr(rb_vect)[0];
- ku = NUM2INT(rb_ku);
- m = ldab;
- ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
- ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = m;
- rb_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[2];
- shape[0] = ldpt;
- shape[1] = n;
- rb_pt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- pt = NA_PTR_TYPE(rb_pt, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (2*MAX(m,n)));
-
- sgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_q, rb_pt, rb_info, rb_ab, rb_c);
-}
-
-void
-init_lapack_sgbbrd(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbbrd", rb_sgbbrd, -1);
-}
diff --git a/sgbcon.c b/sgbcon.c
deleted file mode 100644
index 57f3be9..0000000
--- a/sgbcon.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbcon_(char *norm, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.sgbcon( norm, kl, ku, ab, ipiv, anorm)\n or\n NumRu::Lapack.sgbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBCON estimates the reciprocal of the condition number of a real\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by SGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\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/(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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_anorm = argv[5];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_sgbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbcon", rb_sgbcon, -1);
-}
diff --git a/sgbequ.c b/sgbequ.c
deleted file mode 100644
index 5298121..0000000
--- a/sgbequ.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbequ_(integer *m, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_sgbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequ( m, kl, ku, ab)\n or\n NumRu::Lapack.sgbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MAX(1,m);
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- sgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_sgbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbequ", rb_sgbequ, -1);
-}
diff --git a/sgbequb.c b/sgbequb.c
deleted file mode 100644
index 2ef6fcc..0000000
--- a/sgbequb.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbequb_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_sgbequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequb( kl, ku, ab)\n or\n NumRu::Lapack.sgbequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from SGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", m);
- m = ldab;
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- ku = NUM2INT(rb_ku);
- ldab = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- sgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_sgbequb(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbequb", rb_sgbequb, -1);
-}
diff --git a/sgbrfs.c b/sgbrfs.c
deleted file mode 100644
index 06c973f..0000000
--- a/sgbrfs.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbrfs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.sgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)\n or\n NumRu::Lapack.sgbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\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 SGBTRS.\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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_sgbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbrfs", rb_sgbrfs, -1);
-}
diff --git a/sgbrfsx.c b/sgbrfsx.c
deleted file mode 100644
index 29551bd..0000000
--- a/sgbrfsx.c
+++ /dev/null
@@ -1,230 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbrfsx_(char *trans, char *equed, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgbrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.sgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.sgbrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_r = argv[7];
- rb_c = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
- rb_params = argv[11];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (8th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- ku = NUM2INT(rb_ku);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- sgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_r, rb_c, rb_x, rb_params);
-}
-
-void
-init_lapack_sgbrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbrfsx", rb_sgbrfsx, -1);
-}
diff --git a/sgbsv.c b/sgbsv.c
deleted file mode 100644
index 0edddb3..0000000
--- a/sgbsv.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbsv_(integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sgbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_b;
- real *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.sgbsv( kl, ku, ab, b)\n or\n NumRu::Lapack.sgbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGBSV computes the solution to a real system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL SGBTRF, SGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_sgbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbsv", rb_sgbsv, -1);
-}
diff --git a/sgbsvx.c b/sgbsvx.c
deleted file mode 100644
index 76d02e2..0000000
--- a/sgbsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbsvx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, char *equed, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_afb_out__;
- real *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- real *b_out__;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.sgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.sgbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by SGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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/output) REAL array, dimension (3*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n*\n* value of RCOND would suggest.\n\n* =====================================================================\n* Moved setting of INFO = N+1 so INFO does not subsequently get\n* overwritten. Sven, 17 Mar 05. \n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- equed = StringValueCStr(rb_equed)[0];
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = 3*n;
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, real*);
- MEMCPY(afb_out__, afb, real, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
-
- sgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_sgbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbsvx", rb_sgbsvx, -1);
-}
diff --git a/sgbsvxx.c b/sgbsvxx.c
deleted file mode 100644
index 0c92cf5..0000000
--- a/sgbsvxx.c
+++ /dev/null
@@ -1,270 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbsvxx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, char *equed, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgbsvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_afb_out__;
- real *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.sgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.sgbsvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGBSVXX uses the LU factorization to compute the solution to a\n* real system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In SGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
- rb_params = argv[11];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- fact = StringValueCStr(rb_fact)[0];
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, real*);
- MEMCPY(afb_out__, afb, real, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- sgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_sgbsvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbsvxx", rb_sgbsvxx, -1);
-}
diff --git a/sgbtf2.c b/sgbtf2.c
deleted file mode 100644
index 8957093..0000000
--- a/sgbtf2.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbtf2_(integer *m, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_sgbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.sgbtf2( m, kl, ku, ab)\n or\n NumRu::Lapack.sgbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGBTF2 computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- sgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_sgbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbtf2", rb_sgbtf2, -1);
-}
diff --git a/sgbtrf.c b/sgbtrf.c
deleted file mode 100644
index a745dfe..0000000
--- a/sgbtrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbtrf_(integer *m, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_sgbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.sgbtrf( m, kl, ku, ab)\n or\n NumRu::Lapack.sgbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGBTRF computes an LU factorization of a real m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- sgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_sgbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbtrf", rb_sgbtrf, -1);
-}
diff --git a/sgbtrs.c b/sgbtrs.c
deleted file mode 100644
index b09fd95..0000000
--- a/sgbtrs.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgbtrs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sgbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.sgbtrs( trans, kl, ku, ab, ipiv, b)\n or\n NumRu::Lapack.sgbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGBTRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general band matrix A using the LU factorization computed\n* by SGBTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) REAL array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_sgbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "sgbtrs", rb_sgbtrs, -1);
-}
diff --git a/sgebak.c b/sgebak.c
deleted file mode 100644
index 721c89b..0000000
--- a/sgebak.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, real *scale, integer *m, real *v, integer *ldv, integer *info);
-
-static VALUE
-rb_sgebak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- real *scale;
- VALUE rb_v;
- real *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- real *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.sgebak( job, side, ilo, ihi, scale, v)\n or\n NumRu::Lapack.sgebak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* SGEBAK forms the right or left eigenvectors of a real general matrix\n* by backward transformation on the computed eigenvectors of the\n* balanced matrix output by SGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to SGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by SGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) REAL array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by SGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) REAL array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by SHSEIN or STREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_scale = argv[4];
- rb_v = argv[5];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- if (!NA_IsNArray(rb_scale))
- rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
- if (NA_RANK(rb_scale) != 1)
- rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_scale);
- if (NA_TYPE(rb_scale) != NA_SFLOAT)
- rb_scale = na_change_type(rb_scale, NA_SFLOAT);
- scale = NA_PTR_TYPE(rb_scale, real*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- job = StringValueCStr(rb_job)[0];
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- sgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_sgebak(VALUE mLapack){
- rb_define_module_function(mLapack, "sgebak", rb_sgebak, -1);
-}
diff --git a/sgebal.c b/sgebal.c
deleted file mode 100644
index d70383f..0000000
--- a/sgebal.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgebal_(char *job, integer *n, real *a, integer *lda, integer *ilo, integer *ihi, real *scale, integer *info);
-
-static VALUE
-rb_sgebal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- real *a;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- real *scale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.sgebal( job, a)\n or\n NumRu::Lapack.sgebal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* SGEBAL balances a general real matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine BALANC.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
-
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ilo, rb_ihi, rb_scale, rb_info, rb_a);
-}
-
-void
-init_lapack_sgebal(VALUE mLapack){
- rb_define_module_function(mLapack, "sgebal", rb_sgebal, -1);
-}
diff --git a/sgebd2.c b/sgebd2.c
deleted file mode 100644
index c1e8d52..0000000
--- a/sgebd2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgebd2_(integer *m, integer *n, real *a, integer *lda, real *d, real *e, real *tauq, real *taup, real *work, integer *info);
-
-static VALUE
-rb_sgebd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tauq;
- real *tauq;
- VALUE rb_taup;
- real *taup;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.sgebd2( m, a)\n or\n NumRu::Lapack.sgebd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEBD2 reduces a real general m by n matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) REAL array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* WORK (workspace) REAL array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (MAX(m,n)));
-
- sgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tauq, rb_taup, rb_info, rb_a);
-}
-
-void
-init_lapack_sgebd2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgebd2", rb_sgebd2, -1);
-}
diff --git a/sgebrd.c b/sgebrd.c
deleted file mode 100644
index 661e1eb..0000000
--- a/sgebrd.c
+++ /dev/null
@@ -1,102 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgebrd_(integer *m, integer *n, real *a, integer *lda, real *d, real *e, real *tauq, real *taup, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgebrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tauq;
- real *tauq;
- VALUE rb_taup;
- real *taup;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.sgebrd( m, a, lwork)\n or\n NumRu::Lapack.sgebrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEBRD reduces a general real M-by-N matrix A to upper or lower\n* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the orthogonal matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the orthogonal matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) REAL array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\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 length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, real*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgebrd(VALUE mLapack){
- rb_define_module_function(mLapack, "sgebrd", rb_sgebrd, -1);
-}
diff --git a/sgecon.c b/sgecon.c
deleted file mode 100644
index 36d0e9d..0000000
--- a/sgecon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgecon_(char *norm, integer *n, real *a, integer *lda, real *anorm, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgecon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- real *a;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.sgecon( norm, a, anorm)\n or\n NumRu::Lapack.sgecon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGECON estimates the reciprocal of the condition number of a general\n* real matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by SGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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/(norm(A) * norm(inv(A))).\n*\n* WORK (workspace) REAL array, dimension (4*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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- norm = StringValueCStr(rb_norm)[0];
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- sgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_sgecon(VALUE mLapack){
- rb_define_module_function(mLapack, "sgecon", rb_sgecon, -1);
-}
diff --git a/sgeequ.c b/sgeequ.c
deleted file mode 100644
index 6dd4b91..0000000
--- a/sgeequ.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeequ_(integer *m, integer *n, real *a, integer *lda, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_sgeequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequ( a)\n or\n NumRu::Lapack.sgeequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- sgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_sgeequ(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeequ", rb_sgeequ, -1);
-}
diff --git a/sgeequb.c b/sgeequb.c
deleted file mode 100644
index 0dda59b..0000000
--- a/sgeequb.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeequb_(integer *m, integer *n, real *a, integer *lda, real *r, real *c, real *rowcnd, real *colcnd, real *amax, integer *info);
-
-static VALUE
-rb_sgeequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequb( a)\n or\n NumRu::Lapack.sgeequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from SGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) REAL array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) REAL array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) REAL\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) REAL\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lda = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
-
- sgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_sgeequb(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeequb", rb_sgeequb, -1);
-}
diff --git a/sgees.c b/sgees.c
deleted file mode 100644
index 0b2d682..0000000
--- a/sgees.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(real *arg0, real *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID sgees_(char *jobvs, char *sort, L_fp *select, integer *n, real *a, integer *lda, integer *sdim, real *wr, real *wi, real *vs, integer *ldvs, real *work, integer *lwork, logical *bwork, integer *info);
-
-static VALUE
-rb_sgees(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_vs;
- real *vs;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, wr, wi, vs, work, info, a = NumRu::Lapack.sgees( jobvs, sort, a, lwork){|a,b| ... }\n or\n NumRu::Lapack.sgees # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEES computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n*\n* A matrix is in real Schur form if it is upper quasi-triangular with\n* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n* form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n* conjugate pair of eigenvalues is selected, then both complex\n* eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO is set to N+2 (see INFO below).\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues in the same order\n* that they appear on the diagonal of the output Schur form T.\n* Complex conjugate pairs of eigenvalues will appear\n* consecutively with the eigenvalue having the positive\n* imaginary part first.\n*\n* VS (output) REAL array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,3*N).\n* For good performance, LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the matrix which reduces A\n* to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- lwork = NUM2INT(rb_lwork);
- sort = StringValueCStr(rb_sort)[0];
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- sgees_(&jobvs, &sort, rb_select, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, work, &lwork, bwork, &info);
-
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_sdim, rb_wr, rb_wi, rb_vs, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgees(VALUE mLapack){
- rb_define_module_function(mLapack, "sgees", rb_sgees, -1);
-}
diff --git a/sgeesx.c b/sgeesx.c
deleted file mode 100644
index 6f8d8e3..0000000
--- a/sgeesx.c
+++ /dev/null
@@ -1,145 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(real *arg0, real *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID sgeesx_(char *jobvs, char *sort, L_fp *select, char *sense, integer *n, real *a, integer *lda, integer *sdim, real *wr, real *wi, real *vs, integer *ldvs, real *rconde, real *rcondv, real *work, integer *lwork, integer *iwork, integer *liwork, logical *bwork, integer *info);
-
-static VALUE
-rb_sgeesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_vs;
- real *vs;
- VALUE rb_rconde;
- real rconde;
- VALUE rb_rcondv;
- real rcondv;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.sgeesx( jobvs, sort, sense, a, lwork, liwork){|a,b| ... }\n or\n NumRu::Lapack.sgeesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEESX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues, the real Schur form T, and, optionally, the matrix of\n* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* real Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A real matrix is in real Schur form if it is upper quasi-triangular\n* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n* the form\n* [ a b ]\n* [ c a ]\n*\n* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n* SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n* complex conjugate pair of eigenvalues is selected, then both\n* are. Note that a selected complex eigenvalue may no longer\n* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned); in this\n* case INFO may be set to N+3 (see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the N-by-N matrix A.\n* On exit, A is overwritten by its real Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELECT is true. (Complex conjugate\n* pairs for which SELECT is true for either\n* eigenvalue count as 2.)\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts, respectively,\n* of the computed eigenvalues, in the same order that they\n* appear on the diagonal of the output Schur form T. Complex\n* conjugate pairs of eigenvalues appear consecutively with the\n* eigenvalue having the positive imaginary part first.\n*\n* VS (output) REAL array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) REAL\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\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 >= max(1,3*N).\n* Also, if SENSE = 'E' or 'V' or 'B',\n* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n* selected eigenvalues computed by this routine. Note that\n* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n* 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bounds on the optimal sizes of the\n* arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n* may not be large enough.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates upper bounds on the optimal sizes of\n* the arrays WORK and IWORK, returns these values as the first\n* entries of the WORK and IWORK arrays, and no error messages\n* related to LWORK or LIWORK are issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_sense = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
- rb_liwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- liwork = NUM2INT(rb_liwork);
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- sgeesx_(&jobvs, &sort, rb_select, &sense, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, &rconde, &rcondv, work, &lwork, iwork, &liwork, bwork, &info);
-
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_rconde = rb_float_new((double)rconde);
- rb_rcondv = rb_float_new((double)rcondv);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_sdim, rb_wr, rb_wi, rb_vs, rb_rconde, rb_rcondv, rb_work, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeesx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeesx", rb_sgeesx, -1);
-}
diff --git a/sgeev.c b/sgeev.c
deleted file mode 100644
index e901677..0000000
--- a/sgeev.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeev_(char *jobvl, char *jobvr, integer *n, real *a, integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgeev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, vl, vr, work, info, a = NumRu::Lapack.sgeev( jobvl, jobvr, a, lwork)\n or\n NumRu::Lapack.sgeev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEEV computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\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 >= max(1,3*N), and\n* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good\n* performance, LWORK must generally be larger.\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* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements i+1:N of WR and WI contain eigenvalues which\n* have converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, real*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_wr, rb_wi, rb_vl, rb_vr, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeev(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeev", rb_sgeev, -1);
-}
diff --git a/sgeevx.c b/sgeevx.c
deleted file mode 100644
index a567a8b..0000000
--- a/sgeevx.c
+++ /dev/null
@@ -1,156 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, real *a, integer *lda, real *wr, real *wi, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *ihi, real *scale, real *abnrm, real *rconde, real *rcondv, real *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_sgeevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- real *scale;
- VALUE rb_abnrm;
- real abnrm;
- VALUE rb_rconde;
- real *rconde;
- VALUE rb_rcondv;
- real *rcondv;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.sgeevx( balanc, jobvl, jobvr, sense, a, lwork)\n or\n NumRu::Lapack.sgeevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, i.e. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the real Schur form of the balanced\n* version of the input matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* WR and WI contain the real and imaginary parts,\n* respectively, of the computed eigenvalues. Complex\n* conjugate pairs of eigenvalues will appear consecutively\n* with the eigenvalue having the positive imaginary part\n* first.\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j),\n* the j-th column of VL.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* If the j-th eigenvalue is real, then v(j) = VR(:,j),\n* the j-th column of VR.\n* If the j-th and (j+1)-st eigenvalues form a complex\n* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n* v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and \n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) REAL array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) REAL array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n* For good performance, LWORK must generally be larger.\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 (2*N-2)\n* If SENSE = 'N' or 'E', not referenced.\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, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of WR\n* and WI contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- sense = StringValueCStr(rb_sense)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, real*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- iwork = ALLOC_N(integer, ((lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2));
-
- sgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(13, rb_wr, rb_wi, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_scale, rb_abnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeevx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeevx", rb_sgeevx, -1);
-}
diff --git a/sgegs.c b/sgegs.c
deleted file mode 100644
index ef1e875..0000000
--- a/sgegs.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgegs_(char *jobvsl, char *jobvsr, integer *n, real *a, integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgegs(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_vsl;
- real *vsl;
- VALUE rb_vsr;
- real *vsr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgegs( jobvsl, jobvsr, a, b, lwork)\n or\n NumRu::Lapack.sgegs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGGES.\n*\n* SGEGS computes the eigenvalues, real Schur form, and, optionally,\n* left and or/right Schur vectors of a real matrix pair (A,B).\n* Given two square matrices A and B, the generalized real Schur\n* factorization has the form\n* \n* A = Q*S*Z**T, B = Q*T*Z**T\n*\n* where Q and Z are orthogonal matrices, T is upper triangular, and S\n* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n* of eigenvalues of (A,B). The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n* \n* If only the eigenvalues of (A,B) are needed, the driver routine\n* SGEGV should be used instead. See SGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper quasi-triangular matrix S from the\n* generalized real Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* real Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) REAL array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and (j+1)-st\n* eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) REAL array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VSL (output) REAL array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) REAL array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\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 >= max(1,4*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:\n* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR\n* The optimal LWORK is 2*N + N*(NB+1).\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* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from SGGBAL\n* =N+2: error return from SGEQRF\n* =N+3: error return from SORMQR\n* =N+4: error return from SORGQR\n* =N+5: error return from SGGHRD\n* =N+6: error return from SHGEQZ (other than failed\n* iteration)\n* =N+7: error return from SGGBAK (computing VSL)\n* =N+8: error return from SGGBAK (computing VSR)\n* =N+9: error return from SLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, real*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sgegs(VALUE mLapack){
- rb_define_module_function(mLapack, "sgegs", rb_sgegs, -1);
-}
diff --git a/sgegv.c b/sgegv.c
deleted file mode 100644
index c46e3d8..0000000
--- a/sgegv.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgegv_(char *jobvl, char *jobvr, integer *n, real *a, integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgegv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sgegv( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.sgegv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGGEV.\n*\n* SGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a real matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n*\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n*\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n*\n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n*\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n*\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the real Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* blocks from the Schur form will be correct. See SGGHRD and\n* SHGEQZ for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only those elements of\n* B corresponding to the diagonal blocks from the Schur form of\n* A will be correct. See SGGHRD and SHGEQZ for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue of\n* GNEP.\n*\n* ALPHAI (output) REAL array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n* eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) REAL array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then u(j) = VL(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* u(j) = VL(:,j) + i*VL(:,j+1)\n* and\n* u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* If the j-th eigenvalue is real, then x(j) = VR(:,j).\n* If the j-th and (j+1)-st eigenvalues form a complex conjugate\n* pair, then\n* x(j) = VR(:,j) + i*VR(:,j+1)\n* and\n* x(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvalues\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:\n* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;\n* The optimal LWORK is:\n* 2*N + MAX( 6*N, N*(NB+1) ).\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from SGGBAL\n* =N+2: error return from SGEQRF\n* =N+3: error return from SORMQR\n* =N+4: error return from SORGQR\n* =N+5: error return from SGGHRD\n* =N+6: error return from SHGEQZ (other than failed\n* iteration)\n* =N+7: error return from STGEVC\n* =N+8: error return from SGGBAK (computing VL)\n* =N+9: error return from SGGBAK (computing VR)\n* =N+10: error return from SLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls SGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, SGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the real Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] See SHGEQZ, SGEGS, or read the book \"Matrix Computations\",\n* by Golub & van Loan, pub. by Johns Hopkins U. Press.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, real*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_vl, rb_vr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sgegv(VALUE mLapack){
- rb_define_module_function(mLapack, "sgegv", rb_sgegv, -1);
-}
diff --git a/sgehd2.c b/sgehd2.c
deleted file mode 100644
index 99e7d86..0000000
--- a/sgehd2.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgehd2_(integer *n, integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sgehd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgehd2( ilo, ihi, a)\n or\n NumRu::Lapack.sgehd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to SGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n));
-
- sgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_sgehd2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgehd2", rb_sgehd2, -1);
-}
diff --git a/sgehrd.c b/sgehrd.c
deleted file mode 100644
index 61636bd..0000000
--- a/sgehrd.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgehrd_(integer *n, integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgehrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgehrd( ilo, ihi, a, lwork)\n or\n NumRu::Lapack.sgehrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEHRD reduces a real general matrix A to upper Hessenberg form H by\n* an orthogonal similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to SGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the orthogonal matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ilo = NUM2INT(rb_ilo);
- lwork = NUM2INT(rb_lwork);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgehrd(VALUE mLapack){
- rb_define_module_function(mLapack, "sgehrd", rb_sgehrd, -1);
-}
diff --git a/sgejsv.c b/sgejsv.c
deleted file mode 100644
index 626b951..0000000
--- a/sgejsv.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgejsv_(char *joba, char *jobu, char *jobv, char *jobr, char *jobt, char *jobp, integer *m, integer *n, real *a, integer *lda, real *sva, real *u, integer *ldu, real *v, integer *ldv, real *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_sgejsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_joba;
- char joba;
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobr;
- char jobr;
- VALUE rb_jobt;
- char jobt;
- VALUE rb_jobp;
- char jobp;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_work;
- real *work;
- VALUE rb_sva;
- real *sva;
- VALUE rb_u;
- real *u;
- VALUE rb_v;
- real *v;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_work_out__;
- real *work_out__;
-
- integer lda;
- integer n;
- integer lwork;
- integer ldu;
- integer ldv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sva, u, v, iwork, info, work = NumRu::Lapack.sgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work)\n or\n NumRu::Lapack.sgejsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n* SGEJSV computes the singular value decomposition (SVD) of a real M-by-N\n* matrix [A], where M >= N. The SVD of [A] is written as\n*\n* [A] = [U] * [SIGMA] * [V]^t,\n*\n* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N\n* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and\n* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are\n* the singular values of [A]. The columns of [U] and [V] are the left and\n* the right singular vectors of [A], respectively. The matrices [U] and [V]\n* are computed and stored in the arrays U and V, respectively. The diagonal\n* of [SIGMA] is computed and stored in the array SVA.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER*1\n* Specifies the level of accuracy:\n* = 'C': This option works well (high relative accuracy) if A = B * D,\n* with well-conditioned B and arbitrary diagonal matrix D.\n* The accuracy cannot be spoiled by COLUMN scaling. The\n* accuracy of the computed output depends on the condition of\n* B, and the procedure aims at the best theoretical accuracy.\n* The relative error max_{i=1:N}|d sigma_i| / sigma_i is\n* bounded by f(M,N)*epsilon* cond(B), independent of D.\n* The input matrix is preprocessed with the QRF with column\n* pivoting. This initial preprocessing and preconditioning by\n* a rank revealing QR factorization is common for all values of\n* JOBA. Additional actions are specified as follows:\n* = 'E': Computation as with 'C' with an additional estimate of the\n* condition number of B. It provides a realistic error bound.\n* = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings\n* D1, D2, and well-conditioned matrix C, this option gives\n* higher accuracy than the 'C' option. If the structure of the\n* input matrix is not known, and relative accuracy is\n* desirable, then this option is advisable. The input matrix A\n* is preprocessed with QR factorization with FULL (row and\n* column) pivoting.\n* = 'G' Computation as with 'F' with an additional estimate of the\n* condition number of B, where A=D*B. If A has heavily weighted\n* rows, then using this condition number gives too pessimistic\n* error bound.\n* = 'A': Small singular values are the noise and the matrix is treated\n* as numerically rank defficient. The error in the computed\n* singular values is bounded by f(m,n)*epsilon*||A||.\n* The computed SVD A = U * S * V^t restores A up to\n* f(m,n)*epsilon*||A||.\n* This gives the procedure the licence to discard (set to zero)\n* all singular values below N*epsilon*||A||.\n* = 'R': Similar as in 'A'. Rank revealing property of the initial\n* QR factorization is used do reveal (using triangular factor)\n* a gap sigma_{r+1} < epsilon * sigma_r in which case the\n* numerical RANK is declared to be r. The SVD is computed with\n* absolute error bounds, but more accurately than with 'A'.\n* \n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the columns of U:\n* = 'U': N columns of U are returned in the array U.\n* = 'F': full set of M left sing. vectors is returned in the array U.\n* = 'W': U may be used as workspace of length M*N. See the description\n* of U.\n* = 'N': U is not computed.\n* \n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the matrix V:\n* = 'V': N columns of V are returned in the array V; Jacobi rotations\n* are not explicitly accumulated.\n* = 'J': N columns of V are returned in the array V, but they are\n* computed as the product of Jacobi rotations. This option is\n* allowed only if JOBU .NE. 'N', i.e. in computing the full SVD.\n* = 'W': V may be used as workspace of length N*N. See the description\n* of V.\n* = 'N': V is not computed.\n* \n* JOBR (input) CHARACTER*1\n* Specifies the RANGE for the singular values. Issues the licence to\n* set to zero small positive singular values if they are outside\n* specified range. If A .NE. 0 is scaled so that the largest singular\n* value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues\n* the licence to kill columns of A whose norm in c*A is less than\n* SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN,\n* where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E').\n* = 'N': Do not kill small columns of c*A. This option assumes that\n* BLAS and QR factorizations and triangular solvers are\n* implemented to work in that range. If the condition of A\n* is greater than BIG, use SGESVJ.\n* = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)]\n* (roughly, as described above). This option is recommended.\n* ===========================\n* For computing the singular values in the FULL range [SFMIN,BIG]\n* use SGESVJ.\n* \n* JOBT (input) CHARACTER*1\n* If the matrix is square then the procedure may determine to use\n* transposed A if A^t seems to be better with respect to convergence.\n* If the matrix is not square, JOBT is ignored. This is subject to\n* changes in the future.\n* The decision is based on two values of entropy over the adjoint\n* orbit of A^t * A. See the descriptions of WORK(6) and WORK(7).\n* = 'T': transpose if entropy test indicates possibly faster\n* convergence of Jacobi process if A^t is taken as input. If A is\n* replaced with A^t, then the row pivoting is included automatically.\n* = 'N': do not speculate.\n* This option can be used to compute only the singular values, or the\n* full SVD (U, SIGMA and V). For only one set of singular vectors\n* (U or V), the caller should provide both U and V, as one of the\n* matrices is used as workspace if the matrix A is transposed.\n* The implementer can easily remove this constraint and make the\n* code more complicated. See the descriptions of U and V.\n* \n* JOBP (input) CHARACTER*1\n* Issues the licence to introduce structured perturbations to drown\n* denormalized numbers. This licence should be active if the\n* denormals are poorly implemented, causing slow computation,\n* especially in cases of fast convergence (!). For details see [1,2].\n* For the sake of simplicity, this perturbations are included only\n* when the full SVD or only the singular values are requested. The\n* implementer/user can easily add the perturbation for the cases of\n* computing one set of singular vectors.\n* = 'P': introduce perturbation\n* = 'N': do not perturb\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. M >= N >= 0.\n*\n* A (input/workspace) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) REAL array, dimension (N)\n* On exit,\n* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the\n* computation SVA contains Euclidean column norms of the\n* iterated matrices in the array A.\n* - For WORK(1) .NE. WORK(2): The singular values of A are\n* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if\n* sigma_max(A) overflows or if small singular values have been\n* saved from underflow by scaling the input matrix A.\n* - If JOBR='R' then some of the singular values may be returned\n* as exact zeros obtained by \"set to zero\" because they are\n* below the numerical rank threshold or are denormalized numbers.\n*\n* U (workspace/output) REAL array, dimension ( LDU, N )\n* If JOBU = 'U', then U contains on exit the M-by-N matrix of\n* the left singular vectors.\n* If JOBU = 'F', then U contains on exit the M-by-M matrix of\n* the left singular vectors, including an ONB\n* of the orthogonal complement of the Range(A).\n* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N),\n* then U is used as workspace if the procedure\n* replaces A with A^t. In that case, [V] is computed\n* in U as left singular vectors of A^t and then\n* copied back to the V array. This 'W' option is just\n* a reminder to the caller that in this case U is\n* reserved as workspace of length N*N.\n* If JOBU = 'N' U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U, LDU >= 1.\n* IF JOBU = 'U' or 'F' or 'W', then LDU >= M.\n*\n* V (workspace/output) REAL array, dimension ( LDV, N )\n* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N),\n* then V is used as workspace if the pprocedure\n* replaces A with A^t. In that case, [U] is computed\n* in V as right singular vectors of A^t and then\n* copied back to the U array. This 'W' option is just\n* a reminder to the caller that in this case V is\n* reserved as workspace of length N*N.\n* If JOBV = 'N' V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV >= 1.\n* If JOBV = 'V' or 'J' or 'W', then LDV >= N.\n*\n* WORK (workspace/output) REAL array, dimension at least LWORK.\n* On exit,\n* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such\n* that SCALE*SVA(1:N) are the computed singular values\n* of A. (See the description of SVA().)\n* WORK(2) = See the description of WORK(1).\n* WORK(3) = SCONDA is an estimate for the condition number of\n* column equilibrated A. (If JOBA .EQ. 'E' or 'G')\n* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).\n* It is computed using SPOCON. It holds\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n* where R is the triangular factor from the QRF of A.\n* However, if R is truncated and the numerical rank is\n* determined to be strictly smaller than N, SCONDA is\n* returned as -1, thus indicating that the smallest\n* singular values might be lost.\n*\n* If full SVD is needed, the following two condition numbers are\n* useful for the analysis of the algorithm. They are provied for\n* a developer/implementer who is familiar with the details of\n* the method.\n*\n* WORK(4) = an estimate of the scaled condition number of the\n* triangular factor in the first QR factorization.\n* WORK(5) = an estimate of the scaled condition number of the\n* triangular factor in the second QR factorization.\n* The following two parameters are computed if JOBT .EQ. 'T'.\n* They are provided for a developer/implementer who is familiar\n* with the details of the method.\n*\n* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy\n* of diag(A^t*A) / Trace(A^t*A) taken as point in the\n* probability simplex.\n* WORK(7) = the entropy of A*A^t.\n*\n* LWORK (input) INTEGER\n* Length of WORK to confirm proper allocation of work space.\n* LWORK depends on the job:\n*\n* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and\n* -> .. no scaled condition estimate required ( JOBE.EQ.'N'):\n* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement.\n* For optimal performance (blocked code) the optimal value\n* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal\n* block size for xGEQP3/xGEQRF.\n* -> .. an estimate of the scaled condition number of A is\n* required (JOBA='E', 'G'). In this case, LWORK is the maximum\n* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7).\n*\n* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'),\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If SIGMA and the left singular vectors are needed\n* -> the minimal requirement is LWORK >= max(2*N+M,7).\n* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7),\n* where NB is the optimal block size.\n*\n* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and\n* -> .. the singular vectors are computed without explicit\n* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N\n* -> .. in the iterative part, the Jacobi rotations are\n* explicitly accumulated (option, see the description of JOBV),\n* then the minimal requirement is LWORK >= max(M+3*N+N*N,7).\n* For better performance, if NB is the optimal block size,\n* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7).\n*\n* IWORK (workspace/output) INTEGER array, dimension M+3*N.\n* On exit,\n* IWORK(1) = the numerical rank determined after the initial\n* QR factorization with pivoting. See the descriptions\n* of JOBA and JOBR.\n* IWORK(2) = the number of the computed nonzero singular values\n* IWORK(3) = if nonzero, a warning message:\n* If IWORK(3).EQ.1 then some of the column norms of A\n* were denormalized floats. The requested high accuracy\n* is not warranted by the data.\n*\n* INFO (output) INTEGER\n* < 0 : if INFO = -i, then the i-th argument had an illegal value.\n* = 0 : successfull exit;\n* > 0 : SGEJSV did not converge in the maximal allowed number\n* of sweeps. The computed values may be inaccurate.\n*\n\n* Further Details\n* ===============\n*\n* SGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3,\n* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an\n* additional row pivoting can be used as a preprocessor, which in some\n* cases results in much higher accuracy. An example is matrix A with the\n* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned\n* diagonal matrices and C is well-conditioned matrix. In that case, complete\n* pivoting in the first QR factorizations provides accuracy dependent on the\n* condition number of C, and independent of D1, D2. Such higher accuracy is\n* not completely understood theoretically, but it works well in practice.\n* Further, if A can be written as A = B*D, with well-conditioned B and some\n* diagonal D, then the high accuracy is guaranteed, both theoretically and\n* in software, independent of D. For more details see [1], [2].\n* The computational range for the singular values can be the full range\n* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS\n* & LAPACK routines called by SGEJSV are implemented to work in that range.\n* If that is not the case, then the restriction for safe computation with\n* the singular values in the range of normalized IEEE numbers is that the\n* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not\n* overflow. This code (SGEJSV) is best used in this restricted range,\n* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are\n* returned as zeros. See JOBR for details on this.\n* Further, this implementation is somewhat slower than the one described\n* in [1,2] due to replacement of some non-LAPACK components, and because\n* the choice of some tuning parameters in the iterative part (SGESVJ) is\n* left to the implementer on a particular machine.\n* The rank revealing QR factorization (in this code: SGEQP3) should be\n* implemented as in [3]. We have a new version of SGEQP3 under development\n* that is more robust than the current one in LAPACK, with a cleaner cut in\n* rank defficient cases. It will be available in the SIGMA library [4].\n* If M is much larger than N, it is obvious that the inital QRF with\n* column pivoting can be preprocessed by the QRF without pivoting. That\n* well known trick is not used in SGEJSV because in some cases heavy row\n* weighting can be treated with complete pivoting. The overhead in cases\n* M much larger than N is then only due to pivoting, but the benefits in\n* terms of accuracy have prevailed. The implementer/user can incorporate\n* this extra QRF step easily. The implementer can also improve data movement\n* (matrix transpose, matrix copy, matrix transposed copy) - this\n* implementation of SGEJSV uses only the simplest, naive data movement.\n*\n* Contributors\n*\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n*\n* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR\n* factorization software - a case study.\n* ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28.\n* LAPACK Working note 176.\n* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, examples and comments\n*\n* Please report all bugs and send interesting examples and/or comments to\n* drmac at math.hr. Thank you.\n*\n* ===========================================================================\n*\n* .. Local Parameters ..\n REAL ZERO, ONE\n PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )\n* ..\n* .. Local Scalars ..\n REAL AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK,\n & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM,\n & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC\n INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING\n LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC,\n & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN,\n & NOSCAL, ROWPIV, RSVEC, TRANSP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, ALOG, AMAX1, AMIN1, FLOAT,\n & MAX0, MIN0, NINT, SIGN, SQRT\n* ..\n* .. External Functions ..\n REAL SLAMCH, SNRM2\n INTEGER ISAMAX\n LOGICAL LSAME\n EXTERNAL ISAMAX, LSAME, SLAMCH, SNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SGELQF, SGEQP3, SGEQRF, SLACPY, SLASCL,\n & SLASET, SLASSQ, SLASWP, SORGQR, SORMLQ,\n & SORMQR, SPOCON, SSCAL, SSWAP, STRSM, XERBLA\n*\n EXTERNAL SGESVJ\n* ..\n*\n* Test the input arguments\n*\n LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' )\n JRACC = LSAME( JOBV, 'J' )\n RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC\n ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' )\n L2RANK = LSAME( JOBA, 'R' )\n L2ABER = LSAME( JOBA, 'A' )\n ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' )\n L2TRAN = LSAME( JOBT, 'T' )\n L2KILL = LSAME( JOBR, 'R' )\n DEFR = LSAME( JOBR, 'N' )\n L2PERT = LSAME( JOBP, 'P' )\n*\n IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR.\n & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN\n INFO = - 1\n ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR.\n & LSAME( JOBU, 'W' )) ) THEN\n INFO = - 2\n ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR.\n & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN\n INFO = - 3\n ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN\n INFO = - 4\n ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN\n INFO = - 5\n ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN\n INFO = - 6\n ELSE IF ( M .LT. 0 ) THEN\n INFO = - 7\n ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN\n INFO = - 8\n ELSE IF ( LDA .LT. M ) THEN\n INFO = - 10\n ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN\n INFO = - 13\n ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN\n INFO = - 14\n ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND.\n & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR.\n & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND.\n & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR.\n & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR.\n & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N))\n & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N)))\n & THEN\n INFO = - 17\n ELSE\n* #:)\n INFO = 0\n END IF\n*\n IF ( INFO .NE. 0 ) THEN\n* #:(\n CALL XERBLA( 'SGEJSV', - INFO )\n END IF\n*\n* Quick return for void matrix (Y3K safe)\n* #:)\n IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN\n*\n* Determine whether the matrix U should be M x N or M x M\n*\n IF ( LSVEC ) THEN\n N1 = N\n IF ( LSAME( JOBU, 'F' ) ) N1 = M\n END IF\n*\n* Set numerical parameters\n*\n*! NOTE: Make sure SLAMCH() does not fail on the target architecture.\n*\n EPSLN = SLAMCH('Epsilon')\n SFMIN = SLAMCH('SafeMinimum')\n SMALL = SFMIN / EPSLN\n BIG = SLAMCH('O')\n*\n* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N\n*\n*(!) If necessary, scale SVA() to protect the largest norm from\n* overflow. It is possible that this scaling pushes the smallest\n* column norm left from the underflow threshold (extreme case).\n*\n SCALEM = ONE / SQRT(FLOAT(M)*FLOAT(N))\n NOSCAL = .TRUE.\n GOSCAL = .TRUE.\n DO 1874 p = 1, N\n AAPP = ZERO\n AAQQ = ONE\n CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ )\n IF ( AAPP .GT. BIG ) THEN\n INFO = - 9\n CALL XERBLA( 'SGEJSV', -INFO )\n RETURN\n END IF\n AAQQ = SQRT(AAQQ)\n IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN\n SVA(p) = AAPP * AAQQ\n ELSE\n NOSCAL = .FALSE.\n SVA(p) = AAPP * ( AAQQ * SCALEM )\n IF ( GOSCAL ) THEN\n GOSCAL = .FALSE.\n CALL SSCAL( p-1, SCALEM, SVA, 1 )\n END IF\n END IF\n 1874 CONTINUE\n*\n IF ( NOSCAL ) SCALEM = ONE\n*\n AAPP = ZERO\n AAQQ = BIG\n DO 4781 p = 1, N\n AAPP = AMAX1( AAPP, SVA(p) )\n IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( AAQQ, SVA(p) )\n 4781 CONTINUE\n*\n* Quick return for zero M x N matrix\n* #:)\n IF ( AAPP .EQ. ZERO ) THEN\n IF ( LSVEC ) CALL SLASET( 'G', M, N1, ZERO, ONE, U, LDU )\n IF ( RSVEC ) CALL SLASET( 'G', N, N, ZERO, ONE, V, LDV )\n WORK(1) = ONE\n WORK(2) = ONE\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n IWORK(1) = 0\n IWORK(2) = 0\n RETURN\n END IF\n*\n* Issue warning if denormalized column norms detected. Override the\n* high relative accuracy request. Issue licence to kill columns\n* (set them to zero) whose norm is less than sigma_max / BIG (roughly).\n* #:(\n WARNING = 0\n IF ( AAQQ .LE. SFMIN ) THEN\n L2RANK = .TRUE.\n L2KILL = .TRUE.\n WARNING = 1\n END IF\n*\n* Quick return for one-column matrix\n* #:)\n IF ( N .EQ. 1 ) THEN\n*\n IF ( LSVEC ) THEN\n CALL SLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )\n CALL SLACPY( 'A', M, 1, A, LDA, U, LDU )\n* computing all M left singular vectors of the M x 1 matrix\n IF ( N1 .NE. N ) THEN\n CALL SGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )\n CALL SORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )\n CALL SCOPY( M, A(1,1), 1, U(1,1), 1 )\n END IF\n END IF\n IF ( RSVEC ) THEN\n V(1,1) = ONE\n END IF\n IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN\n SVA(1) = SVA(1) / SCALEM\n SCALEM = ONE\n END IF\n WORK(1) = ONE / SCALEM\n WORK(2) = ONE\n IF ( SVA(1) .NE. ZERO ) THEN\n IWORK(1) = 1\n IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN\n IWORK(2) = 1\n ELSE\n IWORK(2) = 0\n END IF\n ELSE\n IWORK(1) = 0\n IWORK(2) = 0\n END IF\n IF ( ERREST ) WORK(3) = ONE\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = ONE\n WORK(5) = ONE\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ZERO\n WORK(7) = ZERO\n END IF\n RETURN\n*\n END IF\n*\n TRANSP = .FALSE.\n L2TRAN = L2TRAN .AND. ( M .EQ. N )\n*\n AATMAX = -ONE\n AATMIN = BIG\n IF ( ROWPIV .OR. L2TRAN ) THEN\n*\n* Compute the row norms, needed to determine row pivoting sequence\n* (in the case of heavily row weighted A, row pivoting is strongly\n* advised) and to collect information needed to compare the\n* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.).\n*\n IF ( L2TRAN ) THEN\n DO 1950 p = 1, M\n XSC = ZERO\n TEMP1 = ONE\n CALL SLASSQ( N, A(p,1), LDA, XSC, TEMP1 )\n* SLASSQ gets both the ell_2 and the ell_infinity norm\n* in one pass through the vector\n WORK(M+N+p) = XSC * SCALEM\n WORK(N+p) = XSC * (SCALEM*SQRT(TEMP1))\n AATMAX = AMAX1( AATMAX, WORK(N+p) )\n IF (WORK(N+p) .NE. ZERO) AATMIN = AMIN1(AATMIN,WORK(N+p))\n 1950 CONTINUE\n ELSE\n DO 1904 p = 1, M\n WORK(M+N+p) = SCALEM*ABS( A(p,ISAMAX(N,A(p,1),LDA)) )\n AATMAX = AMAX1( AATMAX, WORK(M+N+p) )\n AATMIN = AMIN1( AATMIN, WORK(M+N+p) )\n 1904 CONTINUE\n END IF\n*\n END IF\n*\n* For square matrix A try to determine whether A^t would be better\n* input for the preconditioned Jacobi SVD, with faster convergence.\n* The decision is based on an O(N) function of the vector of column\n* and row norms of A, based on the Shannon entropy. This should give\n* the right choice in most cases when the difference actually matters.\n* It may fail and pick the slower converging side.\n*\n ENTRA = ZERO\n ENTRAT = ZERO\n IF ( L2TRAN ) THEN\n*\n XSC = ZERO\n TEMP1 = ONE\n CALL SLASSQ( N, SVA, 1, XSC, TEMP1 )\n TEMP1 = ONE / TEMP1\n*\n ENTRA = ZERO\n DO 1113 p = 1, N\n BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * ALOG(BIG1)\n 1113 CONTINUE\n ENTRA = - ENTRA / ALOG(FLOAT(N))\n*\n* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex.\n* It is derived from the diagonal of A^t * A. Do the same with the\n* diagonal of A * A^t, compute the entropy of the corresponding\n* probability distribution. Note that A * A^t and A^t * A have the\n* same trace.\n*\n ENTRAT = ZERO\n DO 1114 p = N+1, N+M\n BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1\n IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * ALOG(BIG1)\n 1114 CONTINUE\n ENTRAT = - ENTRAT / ALOG(FLOAT(M))\n*\n* Analyze the entropies and decide A or A^t. Smaller entropy\n* usually means better input for the algorithm.\n*\n TRANSP = ( ENTRAT .LT. ENTRA )\n*\n* If A^t is better than A, transpose A.\n*\n IF ( TRANSP ) THEN\n* In an optimal implementation, this trivial transpose\n* should be replaced with faster transpose.\n DO 1115 p = 1, N - 1\n DO 1116 q = p + 1, N\n TEMP1 = A(q,p)\n A(q,p) = A(p,q)\n A(p,q) = TEMP1\n 1116 CONTINUE\n 1115 CONTINUE\n DO 1117 p = 1, N\n WORK(M+N+p) = SVA(p)\n SVA(p) = WORK(N+p)\n 1117 CONTINUE\n TEMP1 = AAPP\n AAPP = AATMAX\n AATMAX = TEMP1\n TEMP1 = AAQQ\n AAQQ = AATMIN\n AATMIN = TEMP1\n KILL = LSVEC\n LSVEC = RSVEC\n RSVEC = KILL\n IF ( LSVEC ) N1 = N \n*\n ROWPIV = .TRUE.\n END IF\n*\n END IF\n* END IF L2TRAN\n*\n* Scale the matrix so that its maximal singular value remains less\n* than SQRT(BIG) -- the matrix is scaled so that its maximal column\n* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep\n* SQRT(BIG) instead of BIG is the fact that SGEJSV uses LAPACK and\n* BLAS routines that, in some implementations, are not capable of\n* working in the full interval [SFMIN,BIG] and that they may provoke\n* overflows in the intermediate results. If the singular values spread\n* from SFMIN to BIG, then SGESVJ will compute them. So, in that case,\n* one should use SGESVJ instead of SGEJSV.\n*\n BIG1 = SQRT( BIG )\n TEMP1 = SQRT( BIG / FLOAT(N) )\n*\n CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR )\n IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN\n AAQQ = ( AAQQ / AAPP ) * TEMP1\n ELSE\n AAQQ = ( AAQQ * TEMP1 ) / AAPP\n END IF\n TEMP1 = TEMP1 * SCALEM\n CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR )\n*\n* To undo scaling at the end of this procedure, multiply the\n* computed singular values with USCAL2 / USCAL1.\n*\n USCAL1 = TEMP1\n USCAL2 = AAPP\n*\n IF ( L2KILL ) THEN\n* L2KILL enforces computation of nonzero singular values in\n* the restricted range of condition number of the initial A,\n* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN).\n XSC = SQRT( SFMIN )\n ELSE\n XSC = SMALL\n*\n* Now, if the condition number of A is too big,\n* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN,\n* as a precaution measure, the full SVD is computed using SGESVJ\n* with accumulated Jacobi rotations. This provides numerically\n* more robust computation, at the cost of slightly increased run\n* time. Depending on the concrete implementation of BLAS and LAPACK\n* (i.e. how they behave in presence of extreme ill-conditioning) the\n* implementor may decide to remove this switch.\n IF ( ( AAQQ.LT.SQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN\n JRACC = .TRUE.\n END IF\n*\n END IF\n IF ( AAQQ .LT. XSC ) THEN\n DO 700 p = 1, N\n IF ( SVA(p) .LT. XSC ) THEN\n CALL SLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA )\n SVA(p) = ZERO\n END IF\n 700 CONTINUE\n END IF\n*\n* Preconditioning using QR factorization with pivoting\n*\n IF ( ROWPIV ) THEN\n* Optional row permutation (Bjoerck row pivoting):\n* A result by Cox and Higham shows that the Bjoerck's\n* row pivoting combined with standard column pivoting\n* has similar effect as Powell-Reid complete pivoting.\n* The ell-infinity norms of A are made nonincreasing.\n DO 1952 p = 1, M - 1\n q = ISAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1\n IWORK(2*N+p) = q\n IF ( p .NE. q ) THEN\n TEMP1 = WORK(M+N+p)\n WORK(M+N+p) = WORK(M+N+q)\n WORK(M+N+q) = TEMP1\n END IF\n 1952 CONTINUE\n CALL SLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 )\n END IF\n*\n* End of the preparation phase (scaling, optional sorting and\n* transposing, optional flushing of small columns).\n*\n* Preconditioning\n*\n* If the full SVD is needed, the right singular vectors are computed\n* from a matrix equation, and for that we need theoretical analysis\n* of the Businger-Golub pivoting. So we use SGEQP3 as the first RR QRF.\n* In all other cases the first RR QRF can be chosen by other criteria\n* (eg speed by replacing global with restricted window pivoting, such\n* as in SGEQPX from TOMS # 782). Good results will be obtained using\n* SGEQPX with properly (!) chosen numerical parameters.\n* Any improvement of SGEQP3 improves overal performance of SGEJSV.\n*\n* A * P1 = Q1 * [ R1^t 0]^t:\n DO 1963 p = 1, N\n* .. all columns are free columns\n IWORK(p) = 0\n 1963 CONTINUE\n CALL SGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR )\n*\n* The upper triangular matrix R1 from the first QRF is inspected for\n* rank deficiency and possibilities for deflation, or possible\n* ill-conditioning. Depending on the user specified flag L2RANK,\n* the procedure explores possibilities to reduce the numerical\n* rank by inspecting the computed upper triangular factor. If\n* L2RANK or L2ABER are up, then SGEJSV will compute the SVD of\n* A + dA, where ||dA|| <= f(M,N)*EPSLN.\n*\n NR = 1\n IF ( L2ABER ) THEN\n* Standard absolute error bound suffices. All sigma_i with\n* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an\n* agressive enforcement of lower numerical rank by introducing a\n* backward error of the order of N*EPSLN*||A||.\n TEMP1 = SQRT(FLOAT(N))*EPSLN\n DO 3001 p = 2, N\n IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN\n NR = NR + 1\n ELSE\n GO TO 3002\n END IF\n 3001 CONTINUE\n 3002 CONTINUE\n ELSE IF ( L2RANK ) THEN\n* .. similarly as above, only slightly more gentle (less agressive).\n* Sudden drop on the diagonal of R1 is used as the criterion for\n* close-to-rank-defficient.\n TEMP1 = SQRT(SFMIN)\n DO 3401 p = 2, N\n IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR.\n & ( ABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402\n NR = NR + 1\n 3401 CONTINUE\n 3402 CONTINUE\n*\n ELSE\n* The goal is high relative accuracy. However, if the matrix\n* has high scaled condition number the relative accuracy is in\n* general not feasible. Later on, a condition number estimator\n* will be deployed to estimate the scaled condition number.\n* Here we just remove the underflowed part of the triangular\n* factor. This prevents the situation in which the code is\n* working hard to get the accuracy not warranted by the data.\n TEMP1 = SQRT(SFMIN)\n DO 3301 p = 2, N\n IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302\n NR = NR + 1\n 3301 CONTINUE\n 3302 CONTINUE\n*\n END IF\n*\n ALMORT = .FALSE.\n IF ( NR .EQ. N ) THEN\n MAXPRJ = ONE\n DO 3051 p = 2, N\n TEMP1 = ABS(A(p,p)) / SVA(IWORK(p))\n MAXPRJ = AMIN1( MAXPRJ, TEMP1 )\n 3051 CONTINUE\n IF ( MAXPRJ**2 .GE. ONE - FLOAT(N)*EPSLN ) ALMORT = .TRUE.\n END IF\n*\n*\n SCONDA = - ONE\n CONDR1 = - ONE\n CONDR2 = - ONE\n*\n IF ( ERREST ) THEN\n IF ( N .EQ. NR ) THEN\n IF ( RSVEC ) THEN\n* .. V is available as workspace\n CALL SLACPY( 'U', N, N, A, LDA, V, LDV )\n DO 3053 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, V(1,p), 1 )\n 3053 CONTINUE\n CALL SPOCON( 'U', N, V, LDV, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE IF ( LSVEC ) THEN\n* .. U is available as workspace\n CALL SLACPY( 'U', N, N, A, LDA, U, LDU )\n DO 3054 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, U(1,p), 1 )\n 3054 CONTINUE\n CALL SPOCON( 'U', N, U, LDU, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE\n CALL SLACPY( 'U', N, N, A, LDA, WORK(N+1), N )\n DO 3052 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 )\n 3052 CONTINUE\n* .. the columns of R are scaled to have unit Euclidean lengths.\n CALL SPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1,\n & WORK(N+N*N+1), IWORK(2*N+M+1), IERR )\n END IF\n SCONDA = ONE / SQRT(TEMP1)\n* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1).\n* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA\n ELSE\n SCONDA = - ONE\n END IF\n END IF\n*\n L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) )\n* If there is no violent scaling, artificial perturbation is not needed.\n*\n* Phase 3:\n*\n IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN\n*\n* Singular Values only\n*\n* .. transpose A(1:NR,1:N)\n DO 1946 p = 1, MIN0( N-1, NR )\n CALL SCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1946 CONTINUE\n*\n* The following two DO-loops introduce small relative perturbation\n* into the strict upper triangle of the lower triangular matrix.\n* Small entries below the main diagonal are also changed.\n* This modification is useful if the computing environment does not\n* provide/allow FLUSH TO ZERO underflow, for it prevents many\n* annoying denormalized numbers in case of strongly scaled matrices.\n* The perturbation is structured so that it does not introduce any\n* new perturbation of the singular values, and it does not destroy\n* the job done by the preconditioner.\n* The licence for this perturbation is in the variable L2PERT, which\n* should be .FALSE. if FLUSH TO ZERO underflow is active.\n*\n IF ( .NOT. ALMORT ) THEN\n*\n IF ( L2PERT ) THEN\n* XSC = SQRT(SMALL)\n XSC = EPSLN / FLOAT(N)\n DO 4947 q = 1, NR\n TEMP1 = XSC*ABS(A(q,q))\n DO 4949 p = 1, N\n IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = SIGN( TEMP1, A(p,q) )\n 4949 CONTINUE\n 4947 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA )\n END IF\n*\n* .. second preconditioning using the QR factorization\n*\n CALL SGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR )\n*\n* .. and transpose upper to lower triangular\n DO 1948 p = 1, NR - 1\n CALL SCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 )\n 1948 CONTINUE\n*\n END IF\n*\n* Row-cyclic Jacobi SVD algorithm with column pivoting\n*\n* .. again some perturbation (a \"background noise\") is added\n* to drown denormals\n IF ( L2PERT ) THEN\n* XSC = SQRT(SMALL)\n XSC = EPSLN / FLOAT(N)\n DO 1947 q = 1, NR\n TEMP1 = XSC*ABS(A(q,q))\n DO 1949 p = 1, NR\n IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = SIGN( TEMP1, A(p,q) )\n 1949 CONTINUE\n 1947 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA )\n END IF\n*\n* .. and one-sided Jacobi rotations are started on a lower\n* triangular matrix (plus perturbation which is ignored in\n* the part which destroys triangular form (confusing?!))\n*\n CALL SGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,\n & N, V, LDV, WORK, LWORK, INFO )\n*\n SCALEM = WORK(1)\n NUMRANK = NINT(WORK(2))\n*\n*\n ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN\n*\n* -> Singular Values and Right Singular Vectors <-\n*\n IF ( ALMORT ) THEN\n*\n* .. in this case NR equals N\n DO 1998 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1998 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL SGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,\n & WORK, LWORK, INFO )\n SCALEM = WORK(1)\n NUMRANK = NINT(WORK(2))\n\n ELSE\n*\n* .. two more QR factorizations ( one QRF is not enough, two require\n* accumulated product of Jacobi rotations, three are perfect )\n*\n CALL SLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )\n CALL SGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)\n CALL SLACPY( 'Lower', NR, NR, A, LDA, V, LDV )\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n CALL SGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n DO 8998 p = 1, NR\n CALL SCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )\n 8998 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n CALL SGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,\n & LDU, WORK(N+1), LWORK, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = NINT(WORK(N+2))\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV )\n CALL SLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )\n END IF\n*\n CALL SORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK,\n & V, LDV, WORK(N+1), LWORK-N, IERR )\n*\n END IF\n*\n DO 8991 p = 1, N\n CALL SCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )\n 8991 CONTINUE\n CALL SLACPY( 'All', N, N, A, LDA, V, LDV )\n*\n IF ( TRANSP ) THEN\n CALL SLACPY( 'All', N, N, V, LDV, U, LDU )\n END IF\n*\n ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN\n*\n* .. Singular Values and Left Singular Vectors ..\n*\n* .. second preconditioning step to avoid need to accumulate\n* Jacobi rotations in the Jacobi iterations.\n DO 1965 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )\n 1965 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL SGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n DO 1967 p = 1, NR - 1\n CALL SCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )\n 1967 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n CALL SGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A,\n & LDA, WORK(N+1), LWORK-N, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = NINT(WORK(N+2))\n*\n IF ( NR .LT. M ) THEN\n CALL SLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )\n CALL SLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )\n END IF\n END IF\n*\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n DO 1974 p = 1, N1\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n CALL SSCAL( M, XSC, U(1,p), 1 )\n 1974 CONTINUE\n*\n IF ( TRANSP ) THEN\n CALL SLACPY( 'All', N, N, U, LDU, V, LDV )\n END IF\n*\n ELSE\n*\n* .. Full SVD ..\n*\n IF ( .NOT. JRACC ) THEN\n*\n IF ( .NOT. ALMORT ) THEN\n*\n* Second Preconditioning Step (QRF [with pivoting])\n* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is\n* equivalent to an LQF CALL. Since in many libraries the QRF\n* seems to be better optimized than the LQF, we do explicit\n* transpose and use the QRF. This is subject to changes in an\n* optimized implementation of SGEJSV.\n*\n DO 1968 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1968 CONTINUE\n*\n* .. the following two loops perturb small entries to avoid\n* denormals in the second QR factorization, where they are\n* as good as zeros. This is done to avoid painfully slow\n* computation with denormals. The relative size of the perturbation\n* is a parameter that can be changed by the implementer.\n* This perturbation device will be obsolete on machines with\n* properly implemented arithmetic.\n* To switch it off, set L2PERT=.FALSE. To remove it from the\n* code, remove the action under L2PERT=.TRUE., leave the ELSE part.\n* The following two loops should be blocked and fused with the\n* transposed copy above.\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 2969 q = 1, NR\n TEMP1 = XSC*ABS( V(q,q) )\n DO 2968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = SIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 2968 CONTINUE\n 2969 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n*\n* Estimate the row scaled condition number of R1\n* (If R1 is rectangular, N > NR, then the condition number\n* of the leading NR x NR submatrix is estimated.)\n*\n CALL SLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )\n DO 3950 p = 1, NR\n TEMP1 = SNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)\n CALL SSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)\n 3950 CONTINUE\n CALL SPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1,\n & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR)\n CONDR1 = ONE / SQRT(TEMP1)\n* .. here need a second oppinion on the condition number\n* .. then assume worst case scenario\n* R1 is OK for inverse <=> CONDR1 .LT. FLOAT(N)\n* more conservative <=> CONDR1 .LT. SQRT(FLOAT(N))\n*\n COND_OK = SQRT(FLOAT(NR))\n*[TP] COND_OK is a tuning parameter.\n\n IF ( CONDR1 .LT. COND_OK ) THEN\n* .. the second QRF without pivoting. Note: in an optimized\n* implementation, this QRF should be implemented as the QRF\n* of a lower triangular matrix.\n* R1^t = Q2 * R2\n CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)/EPSLN\n DO 3959 p = 2, NR\n DO 3958 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n IF ( ABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = SIGN( TEMP1, V(q,p) )\n 3958 CONTINUE\n 3959 CONTINUE\n END IF\n*\n IF ( NR .NE. N )\n* .. save ...\n & CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n* .. this transposed copy should be better than naive\n DO 1969 p = 1, NR - 1\n CALL SCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 )\n 1969 CONTINUE\n*\n CONDR2 = CONDR1\n*\n ELSE\n*\n* .. ill-conditioned case: second QRF with pivoting\n* Note that windowed pivoting would be equaly good\n* numerically, and more run-time efficient. So, in\n* an optimal implementation, the next call to SGEQP3\n* should be replaced with eg. CALL SGEQPX (ACM TOMS #782)\n* with properly (carefully) chosen parameters.\n*\n* R1^t * P2 = Q2 * R2\n DO 3003 p = 1, NR\n IWORK(N+p) = 0\n 3003 CONTINUE\n CALL SGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),\n & WORK(2*N+1), LWORK-2*N, IERR )\n** CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n** & LWORK-2*N, IERR )\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 3969 p = 2, NR\n DO 3968 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n IF ( ABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = SIGN( TEMP1, V(q,p) )\n 3968 CONTINUE\n 3969 CONTINUE\n END IF\n*\n CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 8970 p = 2, NR\n DO 8971 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n V(p,q) = - SIGN( TEMP1, V(q,p) )\n 8971 CONTINUE\n 8970 CONTINUE\n ELSE\n CALL SLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV )\n END IF\n* Now, compute R2 = L3 * Q3, the LQ factorization.\n CALL SGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1),\n & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR )\n* .. and estimate the condition number\n CALL SLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )\n DO 4950 p = 1, NR\n TEMP1 = SNRM2( p, WORK(2*N+N*NR+NR+p), NR )\n CALL SSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )\n 4950 CONTINUE\n CALL SPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1,\n & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR )\n CONDR2 = ONE / SQRT(TEMP1)\n*\n IF ( CONDR2 .GE. COND_OK ) THEN\n* .. save the Householder vectors used for Q3\n* (this overwrittes the copy of R2, as it will not be\n* needed in this branch, but it does not overwritte the\n* Huseholder vectors of Q2.).\n CALL SLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N )\n* .. and the rest of the information on Q3 is in\n* WORK(2*N+N*NR+1:2*N+N*NR+N)\n END IF\n*\n END IF\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 4968 q = 2, NR\n TEMP1 = XSC * V(q,q)\n DO 4969 p = 1, q - 1\n* V(p,q) = - SIGN( TEMP1, V(q,p) )\n V(p,q) = - SIGN( TEMP1, V(p,q) )\n 4969 CONTINUE\n 4968 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV )\n END IF\n*\n* Second preconditioning finished; continue with Jacobi SVD\n* The input matrix is lower trinagular.\n*\n* Recover the right singular vectors as solution of a well\n* conditioned triangular matrix equation.\n*\n IF ( CONDR1 .LT. COND_OK ) THEN\n*\n CALL SGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U,\n & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+NR+2))\n DO 3970 p = 1, NR\n CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL SSCAL( NR, SVA(p), V(1,p), 1 )\n 3970 CONTINUE\n\n* .. pick the right matrix equation and solve it\n*\n IF ( NR. EQ. N ) THEN\n* :)) .. best case, R1 is inverted. The solution of this matrix\n* equation is Q2*V2 = the product of the Jacobi rotations\n* used in SGESVJ, premultiplied with the orthogonal matrix\n* from the second QR factorization.\n CALL STRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV )\n ELSE\n* .. R1 is well conditioned, but non-square. Transpose(R2)\n* is inverted to get the product of the Jacobi rotations\n* used in SGESVJ. The Q-factor from the second QR\n* factorization is then built in explicitly.\n CALL STRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),\n & N,V,LDV)\n IF ( NR .LT. N ) THEN\n CALL SLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)\n CALL SLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)\n CALL SLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)\n END IF\n CALL SORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR)\n END IF\n*\n ELSE IF ( CONDR2 .LT. COND_OK ) THEN\n*\n* :) .. the input matrix A is very likely a relative of\n* the Kahan matrix :)\n* The matrix R2 is inverted. The solution of the matrix equation\n* is Q3^T*V3 = the product of the Jacobi rotations (appplied to\n* the lower triangular L3 from the LQ factorization of\n* R2=L3*Q3), pre-multiplied with the transposed Q3.\n CALL SGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+NR+2))\n DO 3870 p = 1, NR\n CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL SSCAL( NR, SVA(p), U(1,p), 1 )\n 3870 CONTINUE\n CALL STRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU)\n* .. apply the permutation from the second QR factorization\n DO 873 q = 1, NR\n DO 872 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 872 CONTINUE\n DO 874 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 874 CONTINUE\n 873 CONTINUE\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n ELSE\n* Last line of defense.\n* #:( This is a rather pathological case: no scaled condition\n* improvement after two pivoted QR factorizations. Other\n* possibility is that the rank revealing QR factorization\n* or the condition estimator has failed, or the COND_OK\n* is set very close to ONE (which is unnecessary). Normally,\n* this branch should never be executed, but in rare cases of\n* failure of the RRQR or condition estimator, the last line of\n* defense ensures that SGEJSV completes the task.\n* Compute the full SVD of L3 using SGESVJ with explicit\n* accumulation of Jacobi rotations.\n CALL SGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U,\n & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO )\n SCALEM = WORK(2*N+N*NR+NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+NR+2))\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n CALL SORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N,\n & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1),\n & LWORK-2*N-N*NR-NR, IERR )\n DO 773 q = 1, NR\n DO 772 p = 1, NR\n WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q)\n 772 CONTINUE\n DO 774 p = 1, NR\n U(p,q) = WORK(2*N+N*NR+NR+p)\n 774 CONTINUE\n 773 CONTINUE\n*\n END IF\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = SQRT(FLOAT(N)) * EPSLN\n DO 1972 q = 1, N\n DO 972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 972 CONTINUE\n DO 973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 973 CONTINUE\n XSC = ONE / SNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( N, XSC, V(1,q), 1 )\n 1972 CONTINUE\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n IF ( NR .LT. M ) THEN\n CALL SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)\n CALL SLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU)\n END IF\n END IF\n*\n* The Q matrix from the first QRF is built into the left singular\n* matrix U. This applies to all cases.\n*\n CALL SORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n\n* The columns of U are normalized. The cost is O(M*N) flops.\n TEMP1 = SQRT(FLOAT(M)) * EPSLN\n DO 1973 p = 1, NR\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( M, XSC, U(1,p), 1 )\n 1973 CONTINUE\n*\n* If the initial QRF is computed with row pivoting, the left\n* singular vectors must be adjusted.\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n ELSE\n*\n* .. the initial matrix A has almost orthogonal columns and\n* the second QRF is not needed\n*\n CALL SLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 5970 p = 2, N\n TEMP1 = XSC * WORK( N + (p-1)*N + p )\n DO 5971 q = 1, p - 1\n WORK(N+(q-1)*N+p)=-SIGN(TEMP1,WORK(N+(p-1)*N+q))\n 5971 CONTINUE\n 5970 CONTINUE\n ELSE\n CALL SLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )\n END IF\n*\n CALL SGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA,\n & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO )\n*\n SCALEM = WORK(N+N*N+1)\n NUMRANK = NINT(WORK(N+N*N+2))\n DO 6970 p = 1, N\n CALL SCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )\n CALL SSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )\n 6970 CONTINUE\n*\n CALL STRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,\n & ONE, A, LDA, WORK(N+1), N )\n DO 6972 p = 1, N\n CALL SCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )\n 6972 CONTINUE\n TEMP1 = SQRT(FLOAT(N))*EPSLN\n DO 6971 p = 1, N\n XSC = ONE / SNRM2( N, V(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( N, XSC, V(1,p), 1 )\n 6971 CONTINUE\n*\n* Assemble the left singular vector matrix U (M x N).\n*\n IF ( N .LT. M ) THEN\n CALL SLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU )\n IF ( N .LT. N1 ) THEN\n CALL SLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU )\n CALL SLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )\n END IF\n END IF\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n TEMP1 = SQRT(FLOAT(M))*EPSLN\n DO 6973 p = 1, N1\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( M, XSC, U(1,p), 1 )\n 6973 CONTINUE\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n END IF\n*\n* end of the >> almost orthogonal case << in the full SVD\n*\n ELSE\n*\n* This branch deploys a preconditioned Jacobi SVD with explicitly\n* accumulated rotations. It is included as optional, mainly for\n* experimental purposes. It does perfom well, and can also be used.\n* In this implementation, this branch will be automatically activated\n* if the condition number sigma_max(A) / sigma_min(A) is predicted\n* to be greater than the overflow threshold. This is because the\n* a posteriori computation of the singular vectors assumes robust\n* implementation of BLAS and some LAPACK procedures, capable of working\n* in presence of extreme values. Since that is not always the case, ...\n*\n DO 7968 p = 1, NR\n CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 7968 CONTINUE\n*\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL/EPSLN)\n DO 5969 q = 1, NR\n TEMP1 = XSC*ABS( V(q,q) )\n DO 5968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = SIGN( TEMP1, V(p,q) )\n IF ( p. LT. q ) V(p,q) = - V(p,q)\n 5968 CONTINUE\n 5969 CONTINUE\n ELSE\n CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n\n CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n CALL SLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )\n*\n DO 7969 p = 1, NR\n CALL SCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )\n 7969 CONTINUE\n\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL/EPSLN)\n DO 9970 q = 2, NR\n DO 9971 p = 1, q - 1\n TEMP1 = XSC * AMIN1(ABS(U(p,p)),ABS(U(q,q)))\n U(p,q) = - SIGN( TEMP1, U(q,p) )\n 9971 CONTINUE\n 9970 CONTINUE\n ELSE\n CALL SLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n END IF\n\n CALL SGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA,\n & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO )\n SCALEM = WORK(2*N+N*NR+1)\n NUMRANK = NINT(WORK(2*N+N*NR+2))\n\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n\n CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1),\n & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR )\n*\n* Permute the rows of V using the (column) permutation from the\n* first QRF. Also, scale the columns to make them unit in\n* Euclidean norm. This applies to all cases.\n*\n TEMP1 = SQRT(FLOAT(N)) * EPSLN\n DO 7972 q = 1, N\n DO 8972 p = 1, N\n WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q)\n 8972 CONTINUE\n DO 8973 p = 1, N\n V(p,q) = WORK(2*N+N*NR+NR+p)\n 8973 CONTINUE\n XSC = ONE / SNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( N, XSC, V(1,q), 1 )\n 7972 CONTINUE\n*\n* At this moment, V contains the right singular vectors of A.\n* Next, assemble the left singular vector matrix U (M x N).\n*\n IF ( NR .LT. M ) THEN\n CALL SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU )\n CALL SLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )\n END IF\n END IF\n*\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n*\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n*\n END IF\n IF ( TRANSP ) THEN\n* .. swap U and V because the procedure worked on A^t\n DO 6974 p = 1, N\n CALL SSWAP( N, U(1,p), 1, V(1,p), 1 )\n 6974 CONTINUE\n END IF\n*\n END IF\n* end of the full SVD\n*\n* Undo scaling, if necessary (and possible)\n*\n IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN\n CALL SLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR )\n USCAL1 = ONE\n USCAL2 = ONE\n END IF\n*\n IF ( NR .LT. N ) THEN\n DO 3004 p = NR+1, N\n SVA(p) = ZERO\n 3004 CONTINUE\n END IF\n*\n WORK(1) = USCAL2 * SCALEM\n WORK(2) = USCAL1\n IF ( ERREST ) WORK(3) = SCONDA\n IF ( LSVEC .AND. RSVEC ) THEN\n WORK(4) = CONDR1\n WORK(5) = CONDR2\n END IF\n IF ( L2TRAN ) THEN\n WORK(6) = ENTRA\n WORK(7) = ENTRAT\n END IF\n*\n IWORK(1) = NR\n IWORK(2) = NUMRANK\n IWORK(3) = WARNING\n*\n RETURN\n* ..\n* .. END OF SGEJSV\n* ..\n END\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_joba = argv[0];
- rb_jobu = argv[1];
- rb_jobv = argv[2];
- rb_jobr = argv[3];
- rb_jobt = argv[4];
- rb_jobp = argv[5];
- rb_m = argv[6];
- rb_a = argv[7];
- rb_work = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (8th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobr = StringValueCStr(rb_jobr)[0];
- m = NUM2INT(rb_m);
- jobt = StringValueCStr(rb_jobt)[0];
- jobu = StringValueCStr(rb_jobu)[0];
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (9th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
- lwork = NA_SHAPE0(rb_work);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
- joba = StringValueCStr(rb_joba)[0];
- jobp = StringValueCStr(rb_jobp)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldv = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? n : 1;
- ldu = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? m : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sva = NA_PTR_TYPE(rb_sva, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[1];
- shape[0] = m+3*n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = lwork;
- rb_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work_out__ = NA_PTR_TYPE(rb_work_out__, real*);
- MEMCPY(work_out__, work, real, NA_TOTAL(rb_work));
- rb_work = rb_work_out__;
- work = work_out__;
-
- sgejsv_(&joba, &jobu, &jobv, &jobr, &jobt, &jobp, &m, &n, a, &lda, sva, u, &ldu, v, &ldv, work, &lwork, iwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_sva, rb_u, rb_v, rb_iwork, rb_info, rb_work);
-}
-
-void
-init_lapack_sgejsv(VALUE mLapack){
- rb_define_module_function(mLapack, "sgejsv", rb_sgejsv, -1);
-}
diff --git a/sgelq2.c b/sgelq2.c
deleted file mode 100644
index 51a6824..0000000
--- a/sgelq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgelq2_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sgelq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgelq2( a)\n or\n NumRu::Lapack.sgelq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELQ2 computes an LQ factorization of a real m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (m));
-
- sgelq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_sgelq2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgelq2", rb_sgelq2, -1);
-}
diff --git a/sgelqf.c b/sgelqf.c
deleted file mode 100644
index 4bb0417..0000000
--- a/sgelqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgelqf_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgelqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgelqf( m, a, lwork)\n or\n NumRu::Lapack.sgelqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELQF computes an LQ factorization of a real M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGELQ2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgelqf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgelqf", rb_sgelqf, -1);
-}
diff --git a/sgels.c b/sgels.c
deleted file mode 100644
index f4f24c5..0000000
--- a/sgels.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgels_(char *trans, integer *m, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgels(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.sgels( trans, m, a, b, lwork)\n or\n NumRu::Lapack.sgels # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELS solves overdetermined or underdetermined real linear systems\n* involving an M-by-N matrix A, or its transpose, using a QR or LQ\n* factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided: \n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of\n* an undetermined system A**T * X = B.\n*\n* 4. If TRANS = 'T' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**T * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be \n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution \n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'T': the linear system involves A**T. \n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >=0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by SGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by SGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'T'. \n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of\n* elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'T' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sgels(VALUE mLapack){
- rb_define_module_function(mLapack, "sgels", rb_sgels, -1);
-}
diff --git a/sgelsd.c b/sgelsd.c
deleted file mode 100644
index 1379d26..0000000
--- a/sgelsd.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgelsd_(integer *m, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *rank, real *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_sgelsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer c__9;
- integer c__0;
- integer liwork;
- integer smlsiz;
- integer nlvl;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, b = NumRu::Lapack.sgelsd( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.sgelsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder transformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of 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* A (input) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n* if M is greater than or equal to N or\n* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the array WORK and the\n* minimum size of the array IWORK, and returns these values as\n* the first entries of the WORK and IWORK arrays, and no error\n* message related to LWORK is issued by XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- c__9 = 9;
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- c__0 = 0;
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- smlsiz = ilaenv_(&c__9,"SGELSD"," ",&c__0,&c__0,&c__0,&c__0);
- nlvl = MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1));
- liwork = 3*(MIN(m,n))*nlvl+11*(MIN(m,n));
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
-
- sgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_s, rb_rank, rb_work, rb_info, rb_b);
-}
-
-void
-init_lapack_sgelsd(VALUE mLapack){
- rb_define_module_function(mLapack, "sgelsd", rb_sgelsd, -1);
-}
diff --git a/sgelss.c b/sgelss.c
deleted file mode 100644
index bc982d3..0000000
--- a/sgelss.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgelss_(integer *m, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *s, real *rcond, integer *rank, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgelss(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.sgelss( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.sgelss # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELSS computes the minimum norm solution to a real linear least\n* squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution\n* matrix X. If m >= n and RANK = n, the residual\n* sum-of-squares for the solution in the i-th column is given\n* by the sum of squares of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(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, and also:\n* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n* For good performance, LWORK should generally be larger.\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* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, &info);
-
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_rank, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sgelss(VALUE mLapack){
- rb_define_module_function(mLapack, "sgelss", rb_sgelss, -1);
-}
diff --git a/sgelsx.c b/sgelsx.c
deleted file mode 100644
index d8f2ce4..0000000
--- a/sgelsx.c
+++ /dev/null
@@ -1,117 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgelsx_(integer *m, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, integer *rank, real *work, integer *info);
-
-static VALUE
-rb_sgelsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, a, b, jpvt = NumRu::Lapack.sgelsx( m, a, b, jpvt, rcond)\n or\n NumRu::Lapack.sgelsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGELSY.\n*\n* SGELSX computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be \n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) REAL array, dimension\n* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(real, (MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)));
-
- sgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_sgelsx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgelsx", rb_sgelsx, -1);
-}
diff --git a/sgelsy.c b/sgelsy.c
deleted file mode 100644
index a3e5ac8..0000000
--- a/sgelsy.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgelsy_(integer *m, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *jpvt, real *rcond, integer *rank, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgelsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.sgelsy( m, a, b, jpvt, rcond, lwork)\n or\n NumRu::Lapack.sgelsy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGELSY computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by orthogonal transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of AP\n* was the k-th column of A.\n*\n* RCOND (input) REAL\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\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.\n* The unblocked strategy requires that:\n* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n* where MN = min( M, N ).\n* The block algorithm requires that:\n* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,\n* and SORMRZ.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
- rb_lwork = argv[5];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
-
- sgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, &info);
-
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_rank, rb_work, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_sgelsy(VALUE mLapack){
- rb_define_module_function(mLapack, "sgelsy", rb_sgelsy, -1);
-}
diff --git a/sgeql2.c b/sgeql2.c
deleted file mode 100644
index 31895cc..0000000
--- a/sgeql2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeql2_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sgeql2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgeql2( m, a)\n or\n NumRu::Lapack.sgeql2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQL2 computes a QL factorization of a real m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n));
-
- sgeql2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeql2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeql2", rb_sgeql2, -1);
-}
diff --git a/sgeqlf.c b/sgeqlf.c
deleted file mode 100644
index 2672b78..0000000
--- a/sgeqlf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeqlf_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgeqlf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgeqlf( m, a, lwork)\n or\n NumRu::Lapack.sgeqlf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQLF computes a QL factorization of a real M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQL2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeqlf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeqlf", rb_sgeqlf, -1);
-}
diff --git a/sgeqp3.c b/sgeqp3.c
deleted file mode 100644
index 888512b..0000000
--- a/sgeqp3.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeqp3_(integer *m, integer *n, real *a, integer *lda, integer *jpvt, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgeqp3(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.sgeqp3( m, a, jpvt, lwork)\n or\n NumRu::Lapack.sgeqp3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* orthogonal matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\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 >= 3*N+1.\n* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n* is the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
-
- sgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_tau, rb_work, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_sgeqp3(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeqp3", rb_sgeqp3, -1);
-}
diff --git a/sgeqpf.c b/sgeqpf.c
deleted file mode 100644
index 6463ada..0000000
--- a/sgeqpf.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeqpf_(integer *m, integer *n, real *a, integer *lda, integer *jpvt, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sgeqpf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.sgeqpf( m, a, jpvt)\n or\n NumRu::Lapack.sgeqpf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SGEQP3.\n*\n* SGEQPF computes a QR factorization with column pivoting of a\n* real M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the orthogonal matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) REAL array, dimension (3*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(real, (3*n));
-
- sgeqpf_(&m, &n, a, &lda, jpvt, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_sgeqpf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeqpf", rb_sgeqpf, -1);
-}
diff --git a/sgeqr2.c b/sgeqr2.c
deleted file mode 100644
index 9ed85d4..0000000
--- a/sgeqr2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeqr2_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sgeqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgeqr2( m, a)\n or\n NumRu::Lapack.sgeqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQR2 computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n));
-
- sgeqr2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeqr2", rb_sgeqr2, -1);
-}
diff --git a/sgeqr2p.c b/sgeqr2p.c
deleted file mode 100644
index 2666a2f..0000000
--- a/sgeqr2p.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeqr2p_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sgeqr2p(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgeqr2p( m, a)\n or\n NumRu::Lapack.sgeqr2p # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQR2P computes a QR factorization of a real m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n));
-
- sgeqr2p_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeqr2p(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeqr2p", rb_sgeqr2p, -1);
-}
diff --git a/sgeqrf.c b/sgeqrf.c
deleted file mode 100644
index c1e037a..0000000
--- a/sgeqrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeqrf_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgeqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgeqrf( m, a, lwork)\n or\n NumRu::Lapack.sgeqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQRF computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is \n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQR2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeqrf", rb_sgeqrf, -1);
-}
diff --git a/sgeqrfp.c b/sgeqrfp.c
deleted file mode 100644
index 22c33a7..0000000
--- a/sgeqrfp.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgeqrfp_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgeqrfp(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgeqrfp( m, a, lwork)\n or\n NumRu::Lapack.sgeqrfp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGEQRFP computes a QR factorization of a real M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is \n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQR2P, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgeqrfp(VALUE mLapack){
- rb_define_module_function(mLapack, "sgeqrfp", rb_sgeqrfp, -1);
-}
diff --git a/sgerfs.c b/sgerfs.c
deleted file mode 100644
index 3f644eb..0000000
--- a/sgerfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgerfs_(char *trans, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgerfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.sgerfs( trans, a, af, ipiv, b, x)\n or\n NumRu::Lapack.sgerfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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 matrices B and X. NRHS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\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 SGETRS.\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_sgerfs(VALUE mLapack){
- rb_define_module_function(mLapack, "sgerfs", rb_sgerfs, -1);
-}
diff --git a/sgerfsx.c b/sgerfsx.c
deleted file mode 100644
index 1fd35eb..0000000
--- a/sgerfsx.c
+++ /dev/null
@@ -1,200 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgerfsx_(char *trans, char *equed, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgerfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.sgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.sgerfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) REAL array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. \n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_r = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_x = argv[8];
- rb_params = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (9th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (6th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- sgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_x, rb_params);
-}
-
-void
-init_lapack_sgerfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgerfsx", rb_sgerfsx, -1);
-}
diff --git a/sgerq2.c b/sgerq2.c
deleted file mode 100644
index a4ef0d8..0000000
--- a/sgerq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgerq2_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sgerq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.sgerq2( a)\n or\n NumRu::Lapack.sgerq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERQ2 computes an RQ factorization of a real m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the orthogonal matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) REAL array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (m));
-
- sgerq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_sgerq2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgerq2", rb_sgerq2, -1);
-}
diff --git a/sgerqf.c b/sgerqf.c
deleted file mode 100644
index 86eb420..0000000
--- a/sgerqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgerqf_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgerqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.sgerqf( m, a, lwork)\n or\n NumRu::Lapack.sgerqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGERQF computes an RQ factorization of a real M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* orthogonal matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL SGERQ2, SLARFB, SLARFT, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgerqf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgerqf", rb_sgerqf, -1);
-}
diff --git a/sgesc2.c b/sgesc2.c
deleted file mode 100644
index ad285b3..0000000
--- a/sgesc2.c
+++ /dev/null
@@ -1,89 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgesc2_(integer *n, real *a, integer *lda, real *rhs, integer *ipiv, integer *jpiv, real *scale);
-
-static VALUE
-rb_sgesc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_rhs;
- real *rhs;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_scale;
- real scale;
- VALUE rb_rhs_out__;
- real *rhs_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.sgesc2( a, rhs, ipiv, jpiv)\n or\n NumRu::Lapack.sgesc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* SGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by SGETC2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by SGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) REAL array, dimension (N).\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) REAL\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_rhs = argv[1];
- rb_ipiv = argv[2];
- rb_jpiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_SFLOAT)
- rb_rhs = na_change_type(rb_rhs, NA_SFLOAT);
- rhs = NA_PTR_TYPE(rb_rhs, real*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, real*);
- MEMCPY(rhs_out__, rhs, real, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- sgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
-
- rb_scale = rb_float_new((double)scale);
- return rb_ary_new3(2, rb_scale, rb_rhs);
-}
-
-void
-init_lapack_sgesc2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgesc2", rb_sgesc2, -1);
-}
diff --git a/sgesdd.c b/sgesdd.c
deleted file mode 100644
index 5c60e84..0000000
--- a/sgesdd.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgesdd_(char *jobz, integer *m, integer *n, real *a, integer *lda, real *s, real *u, integer *ldu, real *vt, integer *ldvt, real *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_sgesdd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldu;
- integer ucol;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.sgesdd( jobz, m, a, lwork)\n or\n NumRu::Lapack.sgesdd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESDD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and right singular\n* vectors. If singular vectors are desired, it uses a\n* divide-and-conquer algorithm.\n*\n* The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**T, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**T are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**T are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* on the array A and all rows of V**T are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**T are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**T are computed.\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 >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**T (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) REAL array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* orthogonal matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) REAL array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N orthogonal matrix V**T;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\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 JOBZ = 'N',\n* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).\n* If JOBZ = 'O',\n* LWORK >= 3*min(M,N) + \n* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n* If JOBZ = 'S' or 'A'\n* LWORK >= 3*min(M,N) +\n* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n* For good performance, LWORK should generally be larger.\n* If LWORK = -1 but other input arguments are legal, WORK(1)\n* returns the optimal LWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: SBDSDC did not converge, updating process failed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- jobz = StringValueCStr(rb_jobz)[0];
- ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
- ldu = ((lsame_(&jobz,"S")) || ((('a') || (((lsame_(&jobz,"O")) && (m < n)))))) ? m : 1;
- ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m == n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = ucol;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- iwork = ALLOC_N(integer, (8*MIN(m,n)));
-
- sgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgesdd(VALUE mLapack){
- rb_define_module_function(mLapack, "sgesdd", rb_sgesdd, -1);
-}
diff --git a/sgesv.c b/sgesv.c
deleted file mode 100644
index e9d017a..0000000
--- a/sgesv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgesv_(integer *n, integer *nrhs, real *a, integer *lda, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sgesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.sgesv( a, b)\n or\n NumRu::Lapack.sgesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGESV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL SGETRF, SGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sgesv(VALUE mLapack){
- rb_define_module_function(mLapack, "sgesv", rb_sgesv, -1);
-}
diff --git a/sgesvd.c b/sgesvd.c
deleted file mode 100644
index 8f79771..0000000
--- a/sgesvd.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgesvd_(char *jobu, char *jobvt, integer *m, integer *n, real *a, integer *lda, real *s, real *u, integer *ldu, real *vt, integer *ldvt, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgesvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobvt;
- char jobvt;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer ldu;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.sgesvd( jobu, jobvt, m, a, lwork)\n or\n NumRu::Lapack.sgesvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVD computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**T, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**T:\n* = 'A': all N rows of V**T are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**T (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**T (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**T (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**T (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) REAL array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) REAL array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) REAL array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n* V**T;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**T (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;\n* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n* superdiagonal elements of an upper bidiagonal matrix B\n* whose diagonal is in S (not necessarily sorted). B\n* satisfies A = U * B * VT, so it has the same singular values\n* as A, and singular vectors related by U and VT.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n* For good performance, LWORK should generally be larger.\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* > 0: if SBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of WORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobvt = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- jobvt = StringValueCStr(rb_jobvt)[0];
- lwork = NUM2INT(rb_lwork);
- jobu = StringValueCStr(rb_jobu)[0];
- ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
- ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgesvd(VALUE mLapack){
- rb_define_module_function(mLapack, "sgesvd", rb_sgesvd, -1);
-}
diff --git a/sgesvj.c b/sgesvj.c
deleted file mode 100644
index 40ffa27..0000000
--- a/sgesvj.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgesvj_(char *joba, char *jobu, char *jobv, integer *m, integer *n, real *a, integer *lda, real *sva, integer *mv, real *v, integer *ldv, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgesvj(int argc, VALUE *argv, VALUE self){
- VALUE rb_joba;
- char joba;
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_mv;
- integer mv;
- VALUE rb_v;
- real *v;
- VALUE rb_work;
- real *work;
- VALUE rb_sva;
- real *sva;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_v_out__;
- real *v_out__;
- VALUE rb_work_out__;
- real *work_out__;
-
- integer lda;
- integer n;
- integer ldv;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sva, info, a, v, work = NumRu::Lapack.sgesvj( joba, jobu, jobv, m, a, mv, v, work)\n or\n NumRu::Lapack.sgesvj # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVJ computes the singular value decomposition (SVD) of a real\n* M-by-N matrix A, where M >= N. The SVD of A is written as\n* [++] [xx] [x0] [xx]\n* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]\n* [++] [xx]\n* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n* of SIGMA are the singular values of A. The columns of U and V are the\n* left and the right singular vectors of A, respectively.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n* rotations. The rotations are implemented as fast scaled rotations of\n* Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n* column interchanges of de Rijk [2]. The relative accuracy of the computed\n* singular values and the accuracy of the computed singular vectors (in\n* angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n* The condition number that determines the accuracy in the full rank case\n* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n* spectral condition number. The best performance of this Jacobi SVD\n* procedure is achieved if used in an accelerated version of Drmac and\n* Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n* Some tunning parameters (marked with [TP]) are available for the\n* implementer.\n* The computational range for the nonzero singular values is the machine\n* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n* denormalized singular values can be computed with the corresponding\n* gradual loss of accurate digits.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* References\n* ~~~~~~~~~~\n* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n* singular value decomposition on a vector computer.\n* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n* value computation in floating point arithmetic.\n* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342.\n* LAPACK Working note 169.\n* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II.\n* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362.\n* LAPACK Working note 170.\n* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV,\n* QSVD, (H,K)-SVD computations.\n* Department of Mathematics, University of Zagreb, 2008.\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\n*\n\n* Arguments\n* =========\n*\n* JOBA (input) CHARACTER* 1\n* Specifies the structure of A.\n* = 'L': The input matrix A is lower triangular;\n* = 'U': The input matrix A is upper triangular;\n* = 'G': The input matrix A is general M-by-N matrix, M >= N.\n*\n* JOBU (input) CHARACTER*1\n* Specifies whether to compute the left singular vectors\n* (columns of U):\n* = 'U': The left singular vectors corresponding to the nonzero\n* singular values are computed and returned in the leading\n* columns of A. See more details in the description of A.\n* The default numerical orthogonality threshold is set to\n* approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E').\n* = 'C': Analogous to JOBU='U', except that user can control the\n* level of numerical orthogonality of the computed left\n* singular vectors. TOL can be set to TOL = CTOL*EPS, where\n* CTOL is given on input in the array WORK.\n* No CTOL smaller than ONE is allowed. CTOL greater\n* than 1 / EPS is meaningless. The option 'C'\n* can be used if M*EPS is satisfactory orthogonality\n* of the computed left singular vectors, so CTOL=M could\n* save few sweeps of Jacobi rotations.\n* See the descriptions of A and WORK(1).\n* = 'N': The matrix U is not computed. However, see the\n* description of A.\n*\n* JOBV (input) CHARACTER*1\n* Specifies whether to compute the right singular vectors, that\n* is, the matrix V:\n* = 'V' : the matrix V is computed and returned in the array V\n* = 'A' : the Jacobi rotations are applied to the MV-by-N\n* array V. In other words, the right singular vector\n* matrix V is not computed explicitly; instead it is\n* applied to an MV-by-N matrix initially stored in the\n* first MV rows of V.\n* = 'N' : the matrix V is not computed and the array V is not\n* referenced\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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':\n* If INFO .EQ. 0 :\n* RANKA orthonormal columns of U are returned in the\n* leading RANKA columns of the array A. Here RANKA <= N\n* is the number of computed singular values of A that are\n* above the underflow threshold SLAMCH('S'). The singular\n* vectors corresponding to underflowed or zero singular\n* values are not computed. The value of RANKA is returned\n* in the array WORK as RANKA=NINT(WORK(2)). Also see the\n* descriptions of SVA and WORK. The computed columns of U\n* are mutually numerically orthogonal up to approximately\n* TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n* see the description of JOBU.\n* If INFO .GT. 0,\n* the procedure SGESVJ did not converge in the given number\n* of iterations (sweeps). In that case, the computed\n* columns of U may not be orthogonal up to TOL. The output\n* U (stored in A), SIGMA (given by the computed singular\n* values in SVA(1:N)) and V is still a decomposition of the\n* input matrix A in the sense that the residual\n* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n* If JOBU .EQ. 'N':\n* If INFO .EQ. 0 :\n* Note that the left singular vectors are 'for free' in the\n* one-sided Jacobi SVD algorithm. However, if only the\n* singular values are needed, the level of numerical\n* orthogonality of U is not an issue and iterations are\n* stopped when the columns of the iterated matrix are\n* numerically orthogonal up to approximately M*EPS. Thus,\n* on exit, A contains the columns of U scaled with the\n* corresponding singular values.\n* If INFO .GT. 0 :\n* the procedure SGESVJ did not converge in the given number\n* of iterations (sweeps).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SVA (workspace/output) REAL array, dimension (N)\n* On exit,\n* If INFO .EQ. 0 :\n* depending on the value SCALE = WORK(1), we have:\n* If SCALE .EQ. ONE:\n* SVA(1:N) contains the computed singular values of A.\n* During the computation SVA contains the Euclidean column\n* norms of the iterated matrices in the array A.\n* If SCALE .NE. ONE:\n* The singular values of A are SCALE*SVA(1:N), and this\n* factored representation is due to the fact that some of the\n* singular values of A might underflow or overflow.\n*\n* If INFO .GT. 0 :\n* the procedure SGESVJ did not converge in the given number of\n* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n*\n* MV (input) INTEGER\n* If JOBV .EQ. 'A', then the product of Jacobi rotations in SGESVJ\n* is applied to the first MV rows of V. See the description of JOBV.\n*\n* V (input/output) REAL array, dimension (LDV,N)\n* If JOBV = 'V', then V contains on exit the N-by-N matrix of\n* the right singular vectors;\n* If JOBV = 'A', then V contains the product of the computed right\n* singular vector matrix and the initial matrix in\n* the array V.\n* If JOBV = 'N', then V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V, LDV .GE. 1.\n* If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n*\n* WORK (input/workspace/output) REAL array, dimension max(4,M+N).\n* On entry,\n* If JOBU .EQ. 'C' :\n* WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n* The process stops if all columns of A are mutually\n* orthogonal up to CTOL*EPS, EPS=SLAMCH('E').\n* It is required that CTOL >= ONE, i.e. it is not\n* allowed to force the routine to obtain orthogonality\n* below EPSILON.\n* On exit,\n* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n* are the computed singular vcalues of A.\n* (See description of SVA().)\n* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n* singular values.\n* WORK(3) = NINT(WORK(3)) is the number of the computed singular\n* values that are larger than the underflow threshold.\n* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n* rotations needed for numerical convergence.\n* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n* This is useful information in cases when SGESVJ did\n* not converge, as it can be used to estimate whether\n* the output is stil useful and for post festum analysis.\n* WORK(6) = the largest absolute value over all sines of the\n* Jacobi rotation angles in the last sweep. It can be\n* useful for a post festum analysis.\n*\n* LWORK length of WORK, WORK >= MAX(6,M+N)\n*\n* INFO (output) INTEGER\n* = 0 : successful exit.\n* < 0 : if INFO = -i, then the i-th argument had an illegal value\n* > 0 : SGESVJ did not converge in the maximal allowed number (30)\n* of sweeps. The output may still be useful. See the\n* description of WORK.\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 INTEGER NSWEEP\n PARAMETER ( NSWEEP = 30 )\n* ..\n* .. Local Scalars ..\n REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n + THSIGN, TOL\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n + SWBAND\n LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n + RSVEC, UCTOL, UPPER\n* ..\n* .. Local Arrays ..\n REAL FASTR( 5 )\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT\n* ..\n* .. External Functions ..\n* from BLAS\n REAL SDOT, SNRM2\n EXTERNAL SDOT, SNRM2\n INTEGER ISAMAX\n EXTERNAL ISAMAX\n* from LAPACK\n REAL SLAMCH\n EXTERNAL SLAMCH\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n* from BLAS\n EXTERNAL SAXPY, SCOPY, SROTM, SSCAL, SSWAP\n* from LAPACK\n EXTERNAL SLASCL, SLASET, SLASSQ, XERBLA\n*\n EXTERNAL SGSVJ0, SGSVJ1\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_joba = argv[0];
- rb_jobu = argv[1];
- rb_jobv = argv[2];
- rb_m = argv[3];
- rb_a = argv[4];
- rb_mv = argv[5];
- rb_v = argv[6];
- rb_work = argv[7];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of v");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- jobu = StringValueCStr(rb_jobu)[0];
- mv = NUM2INT(rb_mv);
- jobv = StringValueCStr(rb_jobv)[0];
- joba = StringValueCStr(rb_joba)[0];
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (8th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
- lwork = NA_SHAPE0(rb_work);
- if (lwork != (MAX(6,m+n)))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", MAX(6,m+n));
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
- lwork = MAX(6,m+n);
- {
- int shape[1];
- shape[0] = n;
- rb_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sva = NA_PTR_TYPE(rb_sva, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- {
- int shape[1];
- shape[0] = lwork;
- rb_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work_out__ = NA_PTR_TYPE(rb_work_out__, real*);
- MEMCPY(work_out__, work, real, NA_TOTAL(rb_work));
- rb_work = rb_work_out__;
- work = work_out__;
-
- sgesvj_(&joba, &jobu, &jobv, &m, &n, a, &lda, sva, &mv, v, &ldv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_sva, rb_info, rb_a, rb_v, rb_work);
-}
-
-void
-init_lapack_sgesvj(VALUE mLapack){
- rb_define_module_function(mLapack, "sgesvj", rb_sgesvj, -1);
-}
diff --git a/sgesvx.c b/sgesvx.c
deleted file mode 100644
index 03a0322..0000000
--- a/sgesvx.c
+++ /dev/null
@@ -1,229 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgesvx_(char *fact, char *trans, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, char *equed, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgesvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_af_out__;
- real *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- real *b_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.sgesvx( fact, trans, a, af, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.sgesvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVX uses the LU factorization to compute the solution to a real\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 (Transpose)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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/output) REAL array, dimension (4*N)\n* On exit, WORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If WORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* WORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = 4*n;
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, real*);
- MEMCPY(af_out__, af, real, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
-
- sgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_sgesvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgesvx", rb_sgesvx, -1);
-}
diff --git a/sgesvxx.c b/sgesvxx.c
deleted file mode 100644
index 90c0583..0000000
--- a/sgesvxx.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgesvxx_(char *fact, char *trans, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, char *equed, real *r, real *c, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgesvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_af_out__;
- real *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- real *r_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.sgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.sgesvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGESVXX uses the LU factorization to compute the solution to a\n* real system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) REAL array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In SGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
- rb_params = argv[9];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, real*);
- MEMCPY(af_out__, af, real, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, real*);
- MEMCPY(r_out__, r, real, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- sgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_sgesvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgesvxx", rb_sgesvxx, -1);
-}
diff --git a/sgetc2.c b/sgetc2.c
deleted file mode 100644
index 840e811..0000000
--- a/sgetc2.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgetc2_(integer *n, real *a, integer *lda, integer *ipiv, integer *jpiv, integer *info);
-
-static VALUE
-rb_sgetc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.sgetc2( a)\n or\n NumRu::Lapack.sgetc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGETC2 computes an LU factorization with complete pivoting of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is the Level 2 BLAS algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the n-by-n matrix A to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, i.e., giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension(N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n* we try to solve for x in Ax = b. So U is perturbed to\n* avoid the overflow.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgetc2_(&n, a, &lda, ipiv, jpiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_jpiv, rb_info, rb_a);
-}
-
-void
-init_lapack_sgetc2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgetc2", rb_sgetc2, -1);
-}
diff --git a/sgetf2.c b/sgetf2.c
deleted file mode 100644
index 0ddf4df..0000000
--- a/sgetf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgetf2_(integer *m, integer *n, real *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_sgetf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.sgetf2( m, a)\n or\n NumRu::Lapack.sgetf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgetf2_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_sgetf2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgetf2", rb_sgetf2, -1);
-}
diff --git a/sgetrf.c b/sgetrf.c
deleted file mode 100644
index 3dec6c0..0000000
--- a/sgetrf.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgetrf_(integer *m, integer *n, real *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_sgetrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.sgetrf( m, a)\n or\n NumRu::Lapack.sgetrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgetrf_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_sgetrf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgetrf", rb_sgetrf, -1);
-}
diff --git a/sgetri.c b/sgetri.c
deleted file mode 100644
index 7d24454..0000000
--- a/sgetri.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgetri_(integer *n, real *a, integer *lda, integer *ipiv, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgetri(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sgetri( a, ipiv, lwork)\n or\n NumRu::Lapack.sgetri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGETRI computes the inverse of a matrix using the LU factorization\n* computed by SGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_ipiv = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sgetri(VALUE mLapack){
- rb_define_module_function(mLapack, "sgetri", rb_sgetri, -1);
-}
diff --git a/sgetrs.c b/sgetrs.c
deleted file mode 100644
index cef643b..0000000
--- a/sgetrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgetrs_(char *trans, integer *n, integer *nrhs, real *a, integer *lda, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sgetrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.sgetrs( trans, a, ipiv, b)\n or\n NumRu::Lapack.sgetrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGETRS solves a system of linear equations\n* A * X = B or A' * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by SGETRF.\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'* X = B (Transpose)\n* = 'C': A'* 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* A (input) REAL array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by SGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from SGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_sgetrs(VALUE mLapack){
- rb_define_module_function(mLapack, "sgetrs", rb_sgetrs, -1);
-}
diff --git a/sggbak.c b/sggbak.c
deleted file mode 100644
index 3d48092..0000000
--- a/sggbak.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggbak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, real *lscale, real *rscale, integer *m, real *v, integer *ldv, integer *info);
-
-static VALUE
-rb_sggbak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- real *lscale;
- VALUE rb_rscale;
- real *rscale;
- VALUE rb_v;
- real *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- real *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.sggbak( job, side, ilo, ihi, lscale, rscale, v)\n or\n NumRu::Lapack.sggbak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* SGGBAK forms the right or left eigenvectors of a real generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* SGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to SGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by SGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by SGGBAL.\n*\n* RSCALE (input) REAL array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by SGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) REAL array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by STGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSCAL, SSWAP, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_lscale = argv[4];
- rb_rscale = argv[5];
- rb_v = argv[6];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_rscale))
- rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
- if (NA_RANK(rb_rscale) != 1)
- rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_rscale);
- if (NA_TYPE(rb_rscale) != NA_SFLOAT)
- rb_rscale = na_change_type(rb_rscale, NA_SFLOAT);
- rscale = NA_PTR_TYPE(rb_rscale, real*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_lscale))
- rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
- if (NA_RANK(rb_lscale) != 1)
- rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lscale) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of lscale must be the same as shape 0 of rscale");
- if (NA_TYPE(rb_lscale) != NA_SFLOAT)
- rb_lscale = na_change_type(rb_lscale, NA_SFLOAT);
- lscale = NA_PTR_TYPE(rb_lscale, real*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- sggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_sggbak(VALUE mLapack){
- rb_define_module_function(mLapack, "sggbak", rb_sggbak, -1);
-}
diff --git a/sggbal.c b/sggbal.c
deleted file mode 100644
index 560a39b..0000000
--- a/sggbal.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggbal_(char *job, integer *n, real *a, integer *lda, real *b, integer *ldb, integer *ilo, integer *ihi, real *lscale, real *rscale, real *work, integer *info);
-
-static VALUE
-rb_sggbal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- real *lscale;
- VALUE rb_rscale;
- real *rscale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.sggbal( job, a, b)\n or\n NumRu::Lapack.sggbal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGBAL balances a pair of general real matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i = 1,...,N.\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j)\n* is the scaling factor applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j)\n* is the scaling factor applied to column j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) REAL array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
-
- sggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
-
- free(work);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggbal(VALUE mLapack){
- rb_define_module_function(mLapack, "sggbal", rb_sggbal, -1);
-}
diff --git a/sgges.c b/sgges.c
deleted file mode 100644
index 82ace94..0000000
--- a/sgges.c
+++ /dev/null
@@ -1,173 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(real *arg0, real *arg1, real *arg2){
- VALUE rb_arg0, rb_arg1, rb_arg2;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
- rb_arg2 = rb_float_new((double)(*arg2));
-
- rb_ret = rb_yield_values(3, rb_arg0, rb_arg1, rb_arg2);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID sgges_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, integer *n, real *a, integer *lda, real *b, integer *ldb, integer *sdim, real *alphar, real *alphai, real *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *work, integer *lwork, logical *bwork, integer *info);
-
-static VALUE
-rb_sgges(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_vsl;
- real *vsl;
- VALUE rb_vsr;
- real *vsr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b,c| ... }\n or\n NumRu::Lapack.sgges # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n* the generalized eigenvalues, the generalized real Schur form (S,T),\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T.The\n* leading columns of VSL and VSR then form an orthonormal basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* SGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG);\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n*\n* Note that in the ill-conditioned case, a selected complex\n* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n* in this case.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) REAL array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) REAL array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\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.\n* If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).\n* For good performance , LWORK must generally be larger.\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* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ.\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in STGSEN.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, real*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- sgges_(&jobvsl, &jobvsr, &sort, rb_selctg, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, bwork, &info);
-
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_sdim, rb_alphar, rb_alphai, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sgges(VALUE mLapack){
- rb_define_module_function(mLapack, "sgges", rb_sgges, -1);
-}
diff --git a/sggesx.c b/sggesx.c
deleted file mode 100644
index 4b2cb0d..0000000
--- a/sggesx.c
+++ /dev/null
@@ -1,200 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(real *arg0, real *arg1, real *arg2){
- VALUE rb_arg0, rb_arg1, rb_arg2;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_float_new((double)(*arg0));
- rb_arg1 = rb_float_new((double)(*arg1));
- rb_arg2 = rb_float_new((double)(*arg2));
-
- rb_ret = rb_yield_values(3, rb_arg0, rb_arg1, rb_arg2);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID sggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, char *sense, integer *n, real *a, integer *lda, real *b, integer *ldb, integer *sdim, real *alphar, real *alphai, real *beta, real *vsl, integer *ldvsl, real *vsr, integer *ldvsr, real *rconde, real *rcondv, real *work, integer *lwork, integer *iwork, integer *liwork, logical *bwork, integer *info);
-
-static VALUE
-rb_sggesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_vsl;
- real *vsl;
- VALUE rb_vsr;
- real *vsr;
- VALUE rb_rconde;
- real *rconde;
- VALUE rb_rcondv;
- real *rcondv;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- integer *iwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b,c| ... }\n or\n NumRu::Lapack.sggesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGESX computes for a pair of N-by-N real nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n* optionally, the left and/or right matrices of Schur vectors (VSL and\n* VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* quasi-triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized real Schur form if T is\n* upper triangular with non-negative diagonal and S is block upper\n* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n* to real generalized eigenvalues, while 2-by-2 blocks of S will be\n* \"standardized\" by making the corresponding elements of T have the\n* form:\n* [ a 0 ]\n* [ 0 b ]\n*\n* and the pair of corresponding 2-by-2 blocks in S and T will have a\n* complex conjugate pair of generalized eigenvalues.\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n* one of a complex conjugate pair of eigenvalues is selected,\n* then both complex eigenvalues are selected.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n* since ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true. (Complex conjugate pairs for which\n* SELCTG is true for either eigenvalue count as 2.)\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real Schur form of (A,B) were further reduced to\n* triangular form using 2-by-2 complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio.\n* However, ALPHAR and ALPHAI will be always less than and\n* usually comparable with norm(A) in magnitude, and BETA always\n* less than and usually comparable with norm(B).\n*\n* VSL (output) REAL array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) REAL array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) REAL array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) REAL array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition numbers for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n* LWORK >= max( 8*N, 6*N+16 ).\n* Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n* this may not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+6.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n* be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in STGSEN.\n*\n\n* Further Details\n* ===============\n*\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / RCONDE( 1 ).\n*\n* An approximate (asymptotic) bound on the maximum angular error in\n* the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / RCONDV( 2 ).\n*\n* See LAPACK User's Guide, section 4.11 for more information.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
- rb_liwork = argv[7];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- liwork = NUM2INT(rb_liwork);
- sense = StringValueCStr(rb_sense)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, real*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- sggesx_(&jobvsl, &jobvsr, &sort, rb_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, iwork, &liwork, bwork, &info);
-
- free(iwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_sdim, rb_alphar, rb_alphai, rb_beta, rb_vsl, rb_vsr, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggesx(VALUE mLapack){
- rb_define_module_function(mLapack, "sggesx", rb_sggesx, -1);
-}
diff --git a/sggev.c b/sggev.c
deleted file mode 100644
index 93865f2..0000000
--- a/sggev.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggev_(char *jobvl, char *jobvr, integer *n, real *a, integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sggev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sggev( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.sggev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B .\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* alpha/beta. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector is scaled so the largest component has\n* abs(real part)+abs(imag. part)=1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\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 >= max(1,8*N).\n* For good performance, LWORK must generally be larger.\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* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ.\n* =N+2: error return from STGEVC.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, real*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_vl, rb_vr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggev(VALUE mLapack){
- rb_define_module_function(mLapack, "sggev", rb_sggev, -1);
-}
diff --git a/sggevx.c b/sggevx.c
deleted file mode 100644
index 26782e9..0000000
--- a/sggevx.c
+++ /dev/null
@@ -1,204 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, real *a, integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real *beta, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *ilo, integer *ihi, real *lscale, real *rscale, real *abnrm, real *bbnrm, real *rconde, real *rcondv, real *work, integer *lwork, integer *iwork, logical *bwork, integer *info);
-
-static VALUE
-rb_sggevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- real *lscale;
- VALUE rb_rscale;
- real *rscale;
- VALUE rb_abnrm;
- real abnrm;
- VALUE rb_bbnrm;
- real bbnrm;
- VALUE rb_rconde;
- real *rconde;
- VALUE rb_rcondv;
- real *rcondv;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- integer *iwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggevx( balanc, jobvl, jobvr, sense, a, b, lwork)\n or\n NumRu::Lapack.sggevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n* the generalized eigenvalues, and optionally, the left and/or right\n* generalized eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j) .\n*\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed.\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the real Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. If ALPHAI(j) is zero, then\n* the j-th eigenvalue is real; if positive, then the j-th and\n* (j+1)-st eigenvalues are a complex conjugate pair, with\n* ALPHAI(j+1) negative.\n*\n* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n* may easily over- or underflow, and BETA(j) may even be zero.\n* Thus, the user should avoid naively computing the ratio\n* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n* than and usually comparable with norm(A) in magnitude, and\n* BETA always less than and usually comparable with norm(B).\n*\n* VL (output) REAL array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* u(j) = VL(:,j), the j-th column of VL. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) REAL array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order as\n* their eigenvalues. If the j-th eigenvalue is real, then\n* v(j) = VR(:,j), the j-th column of VR. If the j-th and\n* (j+1)-th eigenvalues form a complex conjugate pair, then\n* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n* Each eigenvector will be scaled so the largest component have\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) REAL array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) REAL\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) REAL\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) REAL array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* For a complex conjugate pair of eigenvalues two consecutive\n* elements of RCONDE are set to the same value. Thus RCONDE(j),\n* RCONDV(j), and the j-th columns of VL and VR all correspond\n* to the j-th eigenpair.\n* If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) REAL array, dimension (N)\n* If SENSE = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. For a complex eigenvector two consecutive\n* elements of RCONDV are set to the same value. If the\n* eigenvalues cannot be reordered to compute RCONDV(j),\n* RCONDV(j) is set to 0; this can only occur when the true\n* value would be very small anyway.\n* If SENSE = 'N' or 'E', RCONDV is not referenced.\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 >= max(1,2*N).\n* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n* LWORK >= max(1,6*N).\n* If SENSE = 'E', LWORK >= max(1,10*N).\n* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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 (N+6)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n* should be correct for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in SHGEQZ.\n* =N+2: error return from STGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, real*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+6));
- bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
-
- sggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, iwork, bwork, &info);
-
- free(iwork);
- free(bwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_bbnrm = rb_float_new((double)bbnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(17, rb_alphar, rb_alphai, rb_beta, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_abnrm, rb_bbnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggevx(VALUE mLapack){
- rb_define_module_function(mLapack, "sggevx", rb_sggevx, -1);
-}
diff --git a/sggglm.c b/sggglm.c
deleted file mode 100644
index a5e4eaf..0000000
--- a/sggglm.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggglm_(integer *n, integer *m, integer *p, real *a, integer *lda, real *b, integer *ldb, real *d, real *x, real *y, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sggglm(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_d;
- real *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- real *x;
- VALUE rb_y;
- real *y;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_d_out__;
- real *d_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.sggglm( a, b, d, lwork)\n or\n NumRu::Lapack.sggglm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) REAL array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) REAL array, dimension (M)\n* Y (output) REAL array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* SGEQRF, SGERQF, SORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_d = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = m;
- rb_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = p;
- rb_y = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- sggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_y, rb_work, rb_info, rb_a, rb_b, rb_d);
-}
-
-void
-init_lapack_sggglm(VALUE mLapack){
- rb_define_module_function(mLapack, "sggglm", rb_sggglm, -1);
-}
diff --git a/sgghrd.c b/sgghrd.c
deleted file mode 100644
index 4ce3105..0000000
--- a/sgghrd.c
+++ /dev/null
@@ -1,148 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgghrd_(char *compq, char *compz, integer *n, integer *ilo, integer *ihi, real *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *z, integer *ldz, integer *info);
-
-static VALUE
-rb_sgghrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_q;
- real *q;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.sgghrd( compq, compz, ilo, ihi, a, b, q, z)\n or\n NumRu::Lapack.sgghrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* SGGHRD reduces a pair of real matrices (A,B) to generalized upper\n* Hessenberg form using orthogonal transformations, where A is a\n* general matrix and B is upper triangular. The form of the\n* generalized eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the orthogonal matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**T*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**T*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**T*x.\n*\n* The orthogonal matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n*\n* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n*\n* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n*\n* If Q1 is the orthogonal matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then SGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Z;\n* = 'I': Z is initialized to the unit matrix, and the\n* orthogonal matrix Z is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry,\n* and the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to SGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**T B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n* typically from the QR factorization of B.\n* On exit, if COMPQ='I', the orthogonal matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n* On exit, if COMPZ='I', the orthogonal matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and Van Loan (Johns Hopkins Press.)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_compq = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ilo = NUM2INT(rb_ilo);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- compq = StringValueCStr(rb_compq)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- sgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_sgghrd(VALUE mLapack){
- rb_define_module_function(mLapack, "sgghrd", rb_sgghrd, -1);
-}
diff --git a/sgglse.c b/sgglse.c
deleted file mode 100644
index 0ae5e1e..0000000
--- a/sgglse.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgglse_(integer *m, integer *n, integer *p, real *a, integer *lda, real *b, integer *ldb, real *c, real *d, real *x, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sgglse(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_c;
- real *c;
- VALUE rb_d;
- real *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- real *x;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_d_out__;
- real *d_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer m;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.sgglse( a, b, c, d, lwork)\n or\n NumRu::Lapack.sgglse # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( (A) ) = N.\n* ( (B) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) REAL array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) REAL array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) REAL array, dimension (N)\n* On exit, X is the solution of the LSE problem.\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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* SGEQRF, SGERQF, SORMQR and SORMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- p = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = n;
- rb_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[1];
- shape[0] = p;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- sgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_work, rb_info, rb_a, rb_b, rb_c, rb_d);
-}
-
-void
-init_lapack_sgglse(VALUE mLapack){
- rb_define_module_function(mLapack, "sgglse", rb_sgglse, -1);
-}
diff --git a/sggqrf.c b/sggqrf.c
deleted file mode 100644
index d476d05..0000000
--- a/sggqrf.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggqrf_(integer *n, integer *m, integer *p, real *a, integer *lda, real *taua, real *b, integer *ldb, real *taub, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sggqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- real *taua;
- VALUE rb_taub;
- real *taub;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.sggqrf( n, a, b, lwork)\n or\n NumRu::Lapack.sggqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the orthogonal matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) REAL array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) REAL array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the orthogonal\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) REAL array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of SORMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine SORGQR.\n* To use Q to update another matrix, use LAPACK subroutine SORMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine SORGRQ.\n* To use Z to update another matrix, use LAPACK subroutine SORMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQRF, SGERQF, SORMQR, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV \n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- n = NUM2INT(rb_n);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(n,m);
- rb_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, real*);
- {
- int shape[1];
- shape[0] = MIN(n,p);
- rb_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "sggqrf", rb_sggqrf, -1);
-}
diff --git a/sggrqf.c b/sggrqf.c
deleted file mode 100644
index a7680b3..0000000
--- a/sggrqf.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggrqf_(integer *m, integer *p, integer *n, real *a, integer *lda, real *taua, real *b, integer *ldb, real *taub, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sggrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_p;
- integer p;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- real *taua;
- VALUE rb_taub;
- real *taub;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.sggrqf( m, p, a, b, lwork)\n or\n NumRu::Lapack.sggrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the orthogonal\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q (see Further Details).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the orthogonal matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) REAL array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Z (see Further Details).\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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of SORMRQ.\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 INF0= -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a real scalar, and v is a real vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine SORGRQ.\n* To use Q to update another matrix, use LAPACK subroutine SORMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a real scalar, and v is a real vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine SORGQR.\n* To use Z to update another matrix, use LAPACK subroutine SORMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL SGEQRF, SGERQF, SORMRQ, XERBLA\n* ..\n* .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV \n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_p = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- p = NUM2INT(rb_p);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, real*);
- {
- int shape[1];
- shape[0] = MIN(p,n);
- rb_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "sggrqf", rb_sggrqf, -1);
-}
diff --git a/sggsvd.c b/sggsvd.c
deleted file mode 100644
index ad0b5c3..0000000
--- a/sggsvd.c
+++ /dev/null
@@ -1,168 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, real *a, integer *lda, real *b, integer *ldb, real *alpha, real *beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *ldq, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sggsvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_alpha;
- real *alpha;
- VALUE rb_beta;
- real *beta;
- VALUE rb_u;
- real *u;
- VALUE rb_v;
- real *v;
- VALUE rb_q;
- real *q;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.sggsvd( jobu, jobv, jobq, a, b)\n or\n NumRu::Lapack.sggsvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N real matrix A and P-by-N real matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are orthogonal matrices, and Z' is the transpose\n* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',\n* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n* D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n* following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the orthogonal\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n* also equal to the CS decomposition of A and B. Furthermore, the GSVD\n* can be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) ).\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in the Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix R if M-K-L < 0.\n* See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n* BETA(K+1:M) =S, BETA(M+1:K+L) =1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) REAL array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) REAL array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) REAL array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) REAL array,\n* dimension (max(3*N,M,P)+N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine STGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA REAL\n* TOLB REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n REAL SLAMCH, SLANGE\n EXTERNAL LSAME, SLAMCH, SLANGE\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SGGSVP, STGSJA, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- lda = m;
- ldb = p;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (MAX(3*n,m)*(p)+n));
-
- sggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, iwork, &info);
-
- free(work);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_k, rb_l, rb_alpha, rb_beta, rb_u, rb_v, rb_q, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggsvd(VALUE mLapack){
- rb_define_module_function(mLapack, "sggsvd", rb_sggsvd, -1);
-}
diff --git a/sggsvp.c b/sggsvp.c
deleted file mode 100644
index 04ab58e..0000000
--- a/sggsvp.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, real *a, integer *lda, real *b, integer *ldb, real *tola, real *tolb, integer *k, integer *l, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *ldq, integer *iwork, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sggsvp(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_tola;
- real tola;
- VALUE rb_tolb;
- real tolb;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_u;
- real *u;
- VALUE rb_v;
- real *v;
- VALUE rb_q;
- real *q;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- integer *iwork;
- real *tau;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.sggsvp( jobu, jobv, jobq, a, b, tola, tolb)\n or\n NumRu::Lapack.sggsvp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SGGSVP computes orthogonal matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* SGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Orthogonal matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Orthogonal matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Orthogonal matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MACHEPS,\n* TOLB = MAX(P,N)*norm(B)*MACHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) REAL array, dimension (LDU,M)\n* If JOBU = 'U', U contains the orthogonal matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) REAL array, dimension (LDV,P)\n* If JOBV = 'V', V contains the orthogonal matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) REAL array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* TAU (workspace) REAL array, dimension (N)\n*\n* WORK (workspace) REAL array, dimension (max(3*N,M,P))\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* Further Details\n* ===============\n*\n* The subroutine uses LAPACK subroutine SGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_tola = argv[5];
- rb_tolb = argv[6];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- tolb = (real)NUM2DBL(rb_tolb);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- tola = (real)NUM2DBL(rb_tola);
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- lda = m;
- ldb = p;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
- tau = ALLOC_N(real, (n));
- work = ALLOC_N(real, (MAX(MAX(3*n,m),p)));
-
- sggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, tau, work, &info);
-
- free(iwork);
- free(tau);
- free(work);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_k, rb_l, rb_u, rb_v, rb_q, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sggsvp(VALUE mLapack){
- rb_define_module_function(mLapack, "sggsvp", rb_sggsvp, -1);
-}
diff --git a/sgsvj0.c b/sgsvj0.c
deleted file mode 100644
index 81294a2..0000000
--- a/sgsvj0.c
+++ /dev/null
@@ -1,159 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgsvj0_(char *jobv, integer *m, integer *n, 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
-rb_sgsvj0(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobv;
- char jobv;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_d;
- real *d;
- VALUE rb_sva;
- real *sva;
- VALUE rb_mv;
- integer mv;
- VALUE rb_v;
- real *v;
- VALUE rb_eps;
- integer eps;
- VALUE rb_sfmin;
- integer sfmin;
- VALUE rb_tol;
- real tol;
- VALUE rb_nsweep;
- integer nsweep;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_sva_out__;
- real *sva_out__;
- VALUE rb_v_out__;
- real *v_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldv;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, d, sva, v = NumRu::Lapack.sgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep)\n or\n NumRu::Lapack.sgsvj0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGSVJ0 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 does not check convergence (stopping criterion). Few tuning\n* parameters (marked by [TP]) are available for the implementer.\n*\n* Further Details\n* ~~~~~~~~~~~~~~~\n* SGSVJ0 is used just to enable SGESVJ to call a simplified version of\n* itself to work on a submatrix of the original matrix.\n*\n* Contributors\n* ~~~~~~~~~~~~\n* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n* Bugs, Examples and Comments\n* ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n* Please report all bugs and send interesting test examples and comments to\n* drmac at math.hr. Thank you.\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* 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 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 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, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n + THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n + NOTROT, 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, AMIN1, 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 (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobv = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_d = argv[3];
- rb_sva = argv[4];
- rb_mv = argv[5];
- rb_v = argv[6];
- rb_eps = argv[7];
- rb_sfmin = argv[8];
- rb_tol = argv[9];
- rb_nsweep = argv[10];
-
- sfmin = NUM2INT(rb_sfmin);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- nsweep = NUM2INT(rb_nsweep);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of v");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of v");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_sva))
- rb_raise(rb_eArgError, "sva (5th argument) must be NArray");
- if (NA_RANK(rb_sva) != 1)
- rb_raise(rb_eArgError, "rank of sva (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sva) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 1 of v");
- if (NA_TYPE(rb_sva) != NA_SFLOAT)
- rb_sva = na_change_type(rb_sva, NA_SFLOAT);
- sva = NA_PTR_TYPE(rb_sva, real*);
- jobv = StringValueCStr(rb_jobv)[0];
- tol = (real)NUM2DBL(rb_tol);
- eps = NUM2INT(rb_eps);
- mv = NUM2INT(rb_mv);
- lwork = m;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_sva_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sva_out__ = NA_PTR_TYPE(rb_sva_out__, real*);
- MEMCPY(sva_out__, sva, real, NA_TOTAL(rb_sva));
- rb_sva = rb_sva_out__;
- sva = sva_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- work = ALLOC_N(real, (lwork));
-
- sgsvj0_(&jobv, &m, &n, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_d, rb_sva, rb_v);
-}
-
-void
-init_lapack_sgsvj0(VALUE mLapack){
- rb_define_module_function(mLapack, "sgsvj0", rb_sgsvj0, -1);
-}
diff --git a/sgsvj1.c b/sgsvj1.c
deleted file mode 100644
index f39d59a..0000000
--- a/sgsvj1.c
+++ /dev/null
@@ -1,163 +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
-rb_sgsvj1(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobv;
- char jobv;
- VALUE rb_m;
- integer m;
- VALUE rb_n1;
- integer n1;
- VALUE rb_a;
- real *a;
- VALUE rb_d;
- real *d;
- VALUE rb_sva;
- real *sva;
- VALUE rb_mv;
- integer mv;
- VALUE rb_v;
- real *v;
- VALUE rb_eps;
- integer eps;
- VALUE rb_sfmin;
- integer sfmin;
- VALUE rb_tol;
- real tol;
- VALUE rb_nsweep;
- integer nsweep;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_sva_out__;
- real *sva_out__;
- VALUE rb_v_out__;
- real *v_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldv;
- integer lwork;
-
- if (argc == 0) {
- 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)\n or\n NumRu::Lapack.sgsvj1 # print 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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobv = argv[0];
- rb_m = argv[1];
- rb_n1 = argv[2];
- rb_a = argv[3];
- rb_d = argv[4];
- rb_sva = argv[5];
- rb_mv = argv[6];
- rb_v = argv[7];
- rb_eps = argv[8];
- rb_sfmin = argv[9];
- rb_tol = argv[10];
- rb_nsweep = argv[11];
-
- sfmin = NUM2INT(rb_sfmin);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (8th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- nsweep = NUM2INT(rb_nsweep);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of v");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- n1 = NUM2INT(rb_n1);
- if (!NA_IsNArray(rb_sva))
- rb_raise(rb_eArgError, "sva (6th argument) must be NArray");
- if (NA_RANK(rb_sva) != 1)
- rb_raise(rb_eArgError, "rank of sva (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sva) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 1 of v");
- if (NA_TYPE(rb_sva) != NA_SFLOAT)
- rb_sva = na_change_type(rb_sva, NA_SFLOAT);
- sva = NA_PTR_TYPE(rb_sva, real*);
- mv = NUM2INT(rb_mv);
- jobv = StringValueCStr(rb_jobv)[0];
- tol = (real)NUM2DBL(rb_tol);
- eps = NUM2INT(rb_eps);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of v");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = m;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_sva_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sva_out__ = NA_PTR_TYPE(rb_sva_out__, real*);
- MEMCPY(sva_out__, sva, real, NA_TOTAL(rb_sva));
- rb_sva = rb_sva_out__;
- sva = sva_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = n;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_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);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_d, rb_sva, rb_v);
-}
-
-void
-init_lapack_sgsvj1(VALUE mLapack){
- rb_define_module_function(mLapack, "sgsvj1", rb_sgsvj1, -1);
-}
diff --git a/sgtcon.c b/sgtcon.c
deleted file mode 100644
index 1d44f03..0000000
--- a/sgtcon.c
+++ /dev/null
@@ -1,105 +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
-rb_sgtcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_du2;
- real *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.sgtcon( norm, dl, d, du, du2, ipiv, anorm)\n or\n NumRu::Lapack.sgtcon # print 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_anorm = argv[6];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_SFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- 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);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_sgtcon(VALUE mLapack){
- rb_define_module_function(mLapack, "sgtcon", rb_sgtcon, -1);
-}
diff --git a/sgtrfs.c b/sgtrfs.c
deleted file mode 100644
index b7d2f14..0000000
--- a/sgtrfs.c
+++ /dev/null
@@ -1,190 +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
-rb_sgtrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_dlf;
- real *dlf;
- VALUE rb_df;
- real *df;
- VALUE rb_duf;
- real *duf;
- VALUE rb_du2;
- real *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.sgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)\n or\n NumRu::Lapack.sgtrfs # print 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 (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_dlf = argv[4];
- rb_df = argv[5];
- rb_duf = argv[6];
- rb_du2 = argv[7];
- rb_ipiv = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (6th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_SFLOAT)
- rb_df = na_change_type(rb_df, NA_SFLOAT);
- df = NA_PTR_TYPE(rb_df, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_SFLOAT)
- rb_dlf = na_change_type(rb_dlf, NA_SFLOAT);
- dlf = NA_PTR_TYPE(rb_dlf, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_SFLOAT)
- rb_duf = na_change_type(rb_duf, NA_SFLOAT);
- duf = NA_PTR_TYPE(rb_duf, real*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_SFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_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);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_sgtrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "sgtrfs", rb_sgtrfs, -1);
-}
diff --git a/sgtsv.c b/sgtsv.c
deleted file mode 100644
index 5449f58..0000000
--- a/sgtsv.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgtsv_(integer *n, integer *nrhs, real *dl, real *d, real *du, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sgtsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- real *dl_out__;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_du_out__;
- real *du_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.sgtsv( dl, d, du, b)\n or\n NumRu::Lapack.sgtsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an n by n tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) REAL array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-2) elements of the\n* second super-diagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) REAL array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N by NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, real*);
- MEMCPY(dl_out__, dl, real, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, real*);
- MEMCPY(du_out__, du, real, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_dl, rb_d, rb_du, rb_b);
-}
-
-void
-init_lapack_sgtsv(VALUE mLapack){
- rb_define_module_function(mLapack, "sgtsv", rb_sgtsv, -1);
-}
diff --git a/sgtsvx.c b/sgtsvx.c
deleted file mode 100644
index 662170c..0000000
--- a/sgtsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgtsvx_(char *fact, 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 *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sgtsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_dlf;
- real *dlf;
- VALUE rb_df;
- real *df;
- VALUE rb_duf;
- real *duf;
- VALUE rb_du2;
- real *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_dlf_out__;
- real *dlf_out__;
- VALUE rb_df_out__;
- real *df_out__;
- VALUE rb_duf_out__;
- real *duf_out__;
- VALUE rb_du2_out__;
- real *du2_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.sgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)\n or\n NumRu::Lapack.sgtsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SGTSVX uses the LU factorization to compute the solution to a real\n* system of linear equations A * X = B or A**T * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored\n* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n* will not be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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 n 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 or output) REAL array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by SGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) REAL array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) REAL array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) REAL array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by SGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_dlf = argv[5];
- rb_df = argv[6];
- rb_duf = argv[7];
- rb_du2 = argv[8];
- rb_ipiv = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (7th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_SFLOAT)
- rb_df = na_change_type(rb_df, NA_SFLOAT);
- df = NA_PTR_TYPE(rb_df, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_SFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_SFLOAT)
- rb_dlf = na_change_type(rb_dlf, NA_SFLOAT);
- dlf = NA_PTR_TYPE(rb_dlf, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_SFLOAT)
- rb_duf = na_change_type(rb_duf, NA_SFLOAT);
- duf = NA_PTR_TYPE(rb_duf, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dlf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dlf_out__ = NA_PTR_TYPE(rb_dlf_out__, real*);
- MEMCPY(dlf_out__, dlf, real, NA_TOTAL(rb_dlf));
- rb_dlf = rb_dlf_out__;
- dlf = dlf_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, real*);
- MEMCPY(df_out__, df, real, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_duf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- duf_out__ = NA_PTR_TYPE(rb_duf_out__, real*);
- MEMCPY(duf_out__, duf, real, NA_TOTAL(rb_duf));
- rb_duf = rb_duf_out__;
- duf = duf_out__;
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- du2_out__ = NA_PTR_TYPE(rb_du2_out__, real*);
- MEMCPY(du2_out__, du2, real, NA_TOTAL(rb_du2));
- rb_du2 = rb_du2_out__;
- du2 = du2_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_dlf, rb_df, rb_duf, rb_du2, rb_ipiv);
-}
-
-void
-init_lapack_sgtsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sgtsvx", rb_sgtsvx, -1);
-}
diff --git a/sgttrf.c b/sgttrf.c
deleted file mode 100644
index 4561f35..0000000
--- a/sgttrf.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgttrf_(integer *n, real *dl, real *d, real *du, real *du2, integer *ipiv, integer *info);
-
-static VALUE
-rb_sgttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_du2;
- real *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- real *dl_out__;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_du_out__;
- real *du_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.sgttrf( dl, d, du)\n or\n NumRu::Lapack.sgttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SGTTRF computes an LU factorization of a real tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) REAL array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) REAL array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) REAL array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- du2 = NA_PTR_TYPE(rb_du2, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, real*);
- MEMCPY(dl_out__, dl, real, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, real*);
- MEMCPY(du_out__, du, real, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
-
- sgttrf_(&n, dl, d, du, du2, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_du2, rb_ipiv, rb_info, rb_dl, rb_d, rb_du);
-}
-
-void
-init_lapack_sgttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "sgttrf", rb_sgttrf, -1);
-}
diff --git a/sgttrs.c b/sgttrs.c
deleted file mode 100644
index a2bf8bd..0000000
--- a/sgttrs.c
+++ /dev/null
@@ -1,118 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgttrs_(char *trans, integer *n, integer *nrhs, real *dl, real *d, real *du, real *du2, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sgttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_du2;
- real *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.sgttrs( trans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.sgttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SGTTRS solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by SGTTRF.\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'* X = B (Transpose)\n* = 'C': A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) multipliers that define the matrix L from the\n* LU factorization of A.\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 super-diagonal of U.\n*\n* DU2 (input) REAL array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) REAL array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SGTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_SFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_sgttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "sgttrs", rb_sgttrs, -1);
-}
diff --git a/sgtts2.c b/sgtts2.c
deleted file mode 100644
index 620b7aa..0000000
--- a/sgtts2.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sgtts2_(integer *itrans, integer *n, integer *nrhs, real *dl, real *d, real *du, real *du2, integer *ipiv, real *b, integer *ldb);
-
-static VALUE
-rb_sgtts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itrans;
- integer itrans;
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_du2;
- real *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.sgtts2( itrans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.sgtts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* SGTTS2 solves one of the systems of equations\n* A*X = B or A'*X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by SGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A'* X = B (Transpose)\n* = 2: A'* X = B (Conjugate transpose = Transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) multipliers that define the matrix L from the\n* LU factorization of A.\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 super-diagonal of U.\n*\n* DU2 (input) REAL array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) REAL array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IP, J\n REAL TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itrans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- itrans = NUM2INT(rb_itrans);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_SFLOAT)
- rb_du2 = na_change_type(rb_du2, NA_SFLOAT);
- du2 = NA_PTR_TYPE(rb_du2, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_sgtts2(VALUE mLapack){
- rb_define_module_function(mLapack, "sgtts2", rb_sgtts2, -1);
-}
diff --git a/shgeqz.c b/shgeqz.c
deleted file mode 100644
index 13a42a2..0000000
--- a/shgeqz.c
+++ /dev/null
@@ -1,188 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID shgeqz_(char *job, char *compq, char *compz, integer *n, integer *ilo, integer *ihi, real *h, integer *ldh, real *t, integer *ldt, real *alphar, real *alphai, real *beta, real *q, integer *ldq, real *z, integer *ldz, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_shgeqz(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- real *h;
- VALUE rb_t;
- real *t;
- VALUE rb_q;
- real *q;
- VALUE rb_z;
- real *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_t_out__;
- real *t_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer ldh;
- integer n;
- integer ldt;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.shgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)\n or\n NumRu::Lapack.shgeqz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the double-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a real matrix pair (A,B):\n*\n* A = Q1*H*Z1**T, B = Q1*T*Z1**T,\n*\n* as computed by SGGHRD.\n*\n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**T, T = Q*P*Z**T,\n* \n* where Q and Z are orthogonal matrices, P is an upper triangular\n* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n* diagonal blocks.\n*\n* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n* eigenvalues.\n*\n* Additionally, the 2-by-2 upper triangular diagonal blocks of P\n* corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n* P(j,j) > 0, and P(j+1,j+1) > 0.\n*\n* Optionally, the orthogonal matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced\n* the matrix pair (A,B) to generalized upper Hessenberg form, then the\n* output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n* generalized Schur factorization of (A,B):\n*\n* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n* complex and beta real.\n* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n* generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* Real eigenvalues can be read directly from the generalized Schur\n* form: \n* alpha = S(i,i), beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Compute eigenvalues and the Schur form. \n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain an orthogonal matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain an orthogonal matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) REAL array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper quasi-triangular\n* matrix S from the generalized Schur factorization;\n* 2-by-2 diagonal blocks (corresponding to complex conjugate\n* pairs of eigenvalues) are returned in standard form, with\n* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n* If JOB = 'E', the diagonal blocks of H match those of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) REAL array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization;\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n* are reduced to positive diagonal form, i.e., if H(j+1,j) is\n* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n* T(j+1,j+1) > 0.\n* If JOB = 'E', the diagonal blocks of T match those of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* The real parts of each scalar alpha defining an eigenvalue\n* of GNEP.\n*\n* ALPHAI (output) REAL array, dimension (N)\n* The imaginary parts of each scalar alpha defining an\n* eigenvalue of GNEP.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n*\n* BETA (output) REAL array, dimension (N)\n* The scalars beta that define the eigenvalues of GNEP.\n* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n* beta = BETA(j) represent the j-th eigenvalue of the matrix\n* pair (A,B), in one of the forms lambda = alpha/beta or\n* mu = beta/alpha. Since either lambda or mu may overflow,\n* they should not, in general, be computed.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n* of left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n* the reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the orthogonal matrix of\n* right Schur vectors of (H,T), and if COMPZ = 'V', the\n* orthogonal matrix of right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\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 >= max(1,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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHAR(i), ALPHAI(i), and\n* BETA(i), i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* Iteration counters:\n*\n* JITER -- counts iterations.\n* IITER -- counts iterations run since ILAST was last\n* changed. This is therefore reset only when a 1-by-1 or\n* 2-by-2 block deflates off the bottom.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_compz = argv[2];
- rb_ilo = argv[3];
- rb_ihi = argv[4];
- rb_h = argv[5];
- rb_t = argv[6];
- rb_q = argv[7];
- rb_z = argv[8];
- rb_lwork = argv[9];
-
- ilo = NUM2INT(rb_ilo);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (8th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of z");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of z");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, real*);
- MEMCPY(t_out__, t, real, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- shgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alphar, alphai, beta, q, &ldq, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_work, rb_info, rb_h, rb_t, rb_q, rb_z);
-}
-
-void
-init_lapack_shgeqz(VALUE mLapack){
- rb_define_module_function(mLapack, "shgeqz", rb_shgeqz, -1);
-}
diff --git a/shsein.c b/shsein.c
deleted file mode 100644
index bf4f29f..0000000
--- a/shsein.c
+++ /dev/null
@@ -1,186 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID shsein_(char *side, char *eigsrc, char *initv, logical *select, integer *n, real *h, integer *ldh, real *wr, real *wi, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real *work, integer *ifaill, integer *ifailr, integer *info);
-
-static VALUE
-rb_shsein(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_eigsrc;
- char eigsrc;
- VALUE rb_initv;
- char initv;
- VALUE rb_select;
- logical *select;
- VALUE rb_h;
- real *h;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_ifaill;
- integer *ifaill;
- VALUE rb_ifailr;
- integer *ifailr;
- VALUE rb_info;
- integer info;
- VALUE rb_select_out__;
- logical *select_out__;
- VALUE rb_wr_out__;
- real *wr_out__;
- VALUE rb_vl_out__;
- real *vl_out__;
- VALUE rb_vr_out__;
- real *vr_out__;
- real *work;
-
- integer n;
- integer ldh;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.shsein( side, eigsrc, initv, select, h, wr, wi, vl, vr)\n or\n NumRu::Lapack.shsein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* SHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a real upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in (WR,WI):\n* = 'Q': the eigenvalues were found using SHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows SHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, SHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* real eigenvector corresponding to a real eigenvalue WR(j),\n* SELECT(j) must be set to .TRUE.. To select the complex\n* eigenvector corresponding to a complex eigenvalue\n* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n* .FALSE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) REAL array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input/output) REAL array, dimension (N)\n* WI (input) REAL array, dimension (N)\n* On entry, the real and imaginary parts of the eigenvalues of\n* H; a complex conjugate pair of eigenvalues must be stored in\n* consecutive elements of WR and WI.\n* On exit, WR may have been altered since close eigenvalues\n* are perturbed slightly in searching for independent\n* eigenvectors.\n*\n* VL (input/output) REAL array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) REAL array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column(s) in which the eigenvector will\n* be stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues. A\n* complex eigenvector corresponding to a complex eigenvalue is\n* stored in two consecutive columns, the first holding the real\n* part and the second the imaginary part.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors; each selected real eigenvector\n* occupies one column and each selected complex eigenvector\n* occupies two columns.\n*\n* WORK (workspace) REAL array, dimension ((N+2)*N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VL hold a complex eigenvector, then IFAILL(i) and\n* IFAILL(i+1) are set to the same value.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily. If the i-th and (i+1)th\n* columns of VR hold a complex eigenvector, then IFAILR(i) and\n* IFAILR(i+1) are set to the same value.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_side = argv[0];
- rb_eigsrc = argv[1];
- rb_initv = argv[2];
- rb_select = argv[3];
- rb_h = argv[4];
- rb_wr = argv[5];
- rb_wi = argv[6];
- rb_vl = argv[7];
- rb_vr = argv[8];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (8th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (8th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- side = StringValueCStr(rb_side)[0];
- eigsrc = StringValueCStr(rb_eigsrc)[0];
- if (!NA_IsNArray(rb_wr))
- rb_raise(rb_eArgError, "wr (6th argument) must be NArray");
- if (NA_RANK(rb_wr) != 1)
- rb_raise(rb_eArgError, "rank of wr (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_wr);
- if (NA_TYPE(rb_wr) != NA_SFLOAT)
- rb_wr = na_change_type(rb_wr, NA_SFLOAT);
- wr = NA_PTR_TYPE(rb_wr, real*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (9th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SFLOAT)
- rb_vr = na_change_type(rb_vr, NA_SFLOAT);
- vr = NA_PTR_TYPE(rb_vr, real*);
- initv = StringValueCStr(rb_initv)[0];
- if (!NA_IsNArray(rb_wi))
- rb_raise(rb_eArgError, "wi (7th argument) must be NArray");
- if (NA_RANK(rb_wi) != 1)
- rb_raise(rb_eArgError, "rank of wi (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wi) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of wi must be the same as shape 0 of wr");
- if (NA_TYPE(rb_wi) != NA_SFLOAT)
- rb_wi = na_change_type(rb_wi, NA_SFLOAT);
- wi = NA_PTR_TYPE(rb_wi, real*);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of wr");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 0 of wr");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifaill = NA_PTR_TYPE(rb_ifaill, integer*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifailr = NA_PTR_TYPE(rb_ifailr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- select_out__ = NA_PTR_TYPE(rb_select_out__, logical*);
- MEMCPY(select_out__, select, logical, NA_TOTAL(rb_select));
- rb_select = rb_select_out__;
- select = select_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_wr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr_out__ = NA_PTR_TYPE(rb_wr_out__, real*);
- MEMCPY(wr_out__, wr, real, NA_TOTAL(rb_wr));
- rb_wr = rb_wr_out__;
- wr = wr_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, real*);
- MEMCPY(vl_out__, vl, real, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, real*);
- MEMCPY(vr_out__, vr, real, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(real, ((n+2)*n));
-
- shsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, wr, wi, vl, &ldvl, vr, &ldvr, &mm, &m, work, ifaill, ifailr, &info);
-
- free(work);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_ifaill, rb_ifailr, rb_info, rb_select, rb_wr, rb_vl, rb_vr);
-}
-
-void
-init_lapack_shsein(VALUE mLapack){
- rb_define_module_function(mLapack, "shsein", rb_shsein, -1);
-}
diff --git a/shseqr.c b/shseqr.c
deleted file mode 100644
index 157e7fc..0000000
--- a/shseqr.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID shseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, real *h, integer *ldh, real *wr, real *wi, real *z, integer *ldz, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_shseqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- real *h;
- VALUE rb_z;
- real *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.shseqr( job, compz, ilo, ihi, h, z, ldz, lwork)\n or\n NumRu::Lapack.shseqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an orthogonal matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to SGEBAL, and then passed to SGEHRD\n* when the matrix output by SGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', then H contains the\n* upper quasi-triangular matrix T from the Schur decomposition\n* (the Schur form); 2-by-2 diagonal blocks (corresponding to\n* complex conjugate pairs of eigenvalues) are returned in\n* standard form, with H(i,i) = H(i+1,i+1) and\n* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n* contents of H are unspecified on exit. (The output value of\n* H when INFO.GT.0 is given under the description of INFO\n* below.)\n*\n* Unlike earlier versions of SHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues. If two eigenvalues are computed as a complex\n* conjugate pair, they are stored in consecutive elements of\n* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n* the same order as on the diagonal of the Schur form returned\n* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the orthogonal matrix generated by SORGHR\n* after the call to SGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then SHSEQR does a workspace query.\n* In this case, SHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, SHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The SLAHQR vs SLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* SLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_z = argv[5];
- rb_ldz = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- ldz = NUM2INT(rb_ldz);
- compz = StringValueCStr(rb_compz)[0];
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (lsame_(&compz,"N") ? 0 : n))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
- if (NA_SHAPE0(rb_z) != (lsame_(&compz,"N") ? 0 : ldz))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = lsame_(&compz,"N") ? 0 : ldz;
- shape[1] = lsame_(&compz,"N") ? 0 : n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- shseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_wr, rb_wi, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_shseqr(VALUE mLapack){
- rb_define_module_function(mLapack, "shseqr", rb_shseqr, -1);
-}
diff --git a/sisnan.c b/sisnan.c
deleted file mode 100644
index 0c739ae..0000000
--- a/sisnan.c
+++ /dev/null
@@ -1,32 +0,0 @@
-#include "rb_lapack.h"
-
-extern logical sisnan_(real *sin);
-
-static VALUE
-rb_sisnan(int argc, VALUE *argv, VALUE self){
- VALUE rb_sin;
- real sin;
- VALUE rb___out__;
- logical __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sisnan( sin)\n or\n NumRu::Lapack.sisnan # print help\n\n\nFORTRAN MANUAL\n LOGICAL FUNCTION SISNAN( SIN )\n\n* Purpose\n* =======\n*\n* SISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n* otherwise. To be replaced by the Fortran 2003 intrinsic in the\n* future.\n*\n\n* Arguments\n* =========\n*\n* SIN (input) REAL\n* Input to test for NaN.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL SLAISNAN\n EXTERNAL SLAISNAN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_sin = argv[0];
-
- sin = (real)NUM2DBL(rb_sin);
-
- __out__ = sisnan_(&sin);
-
- rb___out__ = __out__ ? Qtrue : Qfalse;
- return rb___out__;
-}
-
-void
-init_lapack_sisnan(VALUE mLapack){
- rb_define_module_function(mLapack, "sisnan", rb_sisnan, -1);
-}
diff --git a/sla_gbamv.c b/sla_gbamv.c
deleted file mode 100644
index e3b1497..0000000
--- a/sla_gbamv.c
+++ /dev/null
@@ -1,110 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_gbamv_(integer *trans, integer *m, integer *n, integer *kl, integer *ku, real *alpha, real *ab, integer *ldab, real *x, integer *incx, real *beta, real *y, integer *incy);
-
-static VALUE
-rb_sla_gbamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb_m;
- integer m;
- VALUE rb_n;
- integer n;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_ab;
- real *ab;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- real beta;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer ldab;
- integer lda;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.sla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy)\n or\n NumRu::Lapack.sla_gbamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - REAL array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_n = argv[2];
- rb_kl = argv[3];
- rb_ku = argv[4];
- rb_alpha = argv[5];
- rb_ab = argv[6];
- rb_x = argv[7];
- rb_incx = argv[8];
- rb_beta = argv[9];
- rb_y = argv[10];
- rb_incy = argv[11];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (7th argument) must be NArray");
- if (NA_RANK(rb_ab) != 1)
- rb_raise(rb_eArgError, "rank of ab (7th argument) must be %d", 1);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- trans = NUM2INT(rb_trans);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- n = NUM2INT(rb_n);
- alpha = (real)NUM2DBL(rb_alpha);
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- beta = (real)NUM2DBL(rb_beta);
- lda = MAX(1,m);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (11th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- sla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_sla_gbamv(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_gbamv", rb_sla_gbamv, -1);
-}
diff --git a/sla_gbrcond.c b/sla_gbrcond.c
deleted file mode 100644
index e951c5a..0000000
--- a/sla_gbrcond.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_gbrcond_(char *trans, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, integer *cmode, real *c, integer *info, real *work, integer *iwork);
-
-static VALUE
-rb_sla_gbrcond(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- real *c;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork)\n or\n NumRu::Lapack.sla_gbrcond # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (5*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J, KD, KE\n REAL AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_cmode = argv[6];
- rb_c = argv[7];
- rb_work = argv[8];
- rb_iwork = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (10th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- ku = NUM2INT(rb_ku);
- cmode = NUM2INT(rb_cmode);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (9th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (5*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 5*n);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
-
- __out__ = sla_gbrcond_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_sla_gbrcond(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_gbrcond", rb_sla_gbrcond, -1);
-}
diff --git a/sla_gbrfsx_extended.c b/sla_gbrfsx_extended.c
deleted file mode 100644
index 338b296..0000000
--- a/sla_gbrfsx_extended.c
+++ /dev/null
@@ -1,276 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_gbrfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, integer *ipiv, logical *colequ, real *c, real *b, integer *ldb, real *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, real *res, real *ayb, real *dy, real *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_sla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_ldafb;
- integer ldafb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_y;
- real *y;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- real *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- real *dy;
- VALUE rb_y_tail;
- real *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- real *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_norms;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ldafb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.sla_gbrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* SLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGBTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension \n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 23)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 23)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ldafb = argv[6];
- rb_ipiv = argv[7];
- rb_colequ = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
- rb_y = argv[11];
- rb_err_bnds_norm = argv[12];
- rb_err_bnds_comp = argv[13];
- rb_res = argv[14];
- rb_ayb = argv[15];
- rb_dy = argv[16];
- rb_y_tail = argv[17];
- rb_rcond = argv[18];
- rb_ithresh = argv[19];
- rb_rthresh = argv[20];
- rb_dz_ub = argv[21];
- rb_ignore_cwise = argv[22];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (15th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (15th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SFLOAT)
- rb_res = na_change_type(rb_res, NA_SFLOAT);
- res = NA_PTR_TYPE(rb_res, real*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (8th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of res");
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (n))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", n);
- n = ldab;
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (12th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be n");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (18th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be n");
- if (NA_TYPE(rb_y_tail) != NA_SFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_SFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, real*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (16th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be n");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (13th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (13th argument) must be %d", 2);
- n_norms = NA_SHAPE1(rb_err_bnds_norm);
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (14th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_comp) != n_norms)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be n");
- if (NA_SHAPE0(rb_afb) != ldab)
- rb_raise(rb_eRuntimeError, "shape 0 of afb must be the same as shape 0 of ab");
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (17th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (17th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be n");
- if (NA_TYPE(rb_dy) != NA_SFLOAT)
- rb_dy = na_change_type(rb_dy, NA_SFLOAT);
- dy = NA_PTR_TYPE(rb_dy, real*);
- prec_type = NUM2INT(rb_prec_type);
- ldab = n;
- ldafb = n;
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- sla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_sla_gbrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_gbrfsx_extended", rb_sla_gbrfsx_extended, -1);
-}
diff --git a/sla_gbrpvgrw.c b/sla_gbrpvgrw.c
deleted file mode 100644
index aebf496..0000000
--- a/sla_gbrpvgrw.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_gbrpvgrw_(integer *n, integer *kl, integer *ku, integer *ncols, real *ab, integer *ldab, real *afb, integer *ldafb);
-
-static VALUE
-rb_sla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb___out__;
- real __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_gbrpvgrw( kl, ku, ncols, ab, afb)\n or\n NumRu::Lapack.sla_gbrpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* SLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by SGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n REAL AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ncols = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- ku = NUM2INT(rb_ku);
-
- __out__ = sla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_sla_gbrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_gbrpvgrw", rb_sla_gbrpvgrw, -1);
-}
diff --git a/sla_geamv.c b/sla_geamv.c
deleted file mode 100644
index 307674b..0000000
--- a/sla_geamv.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_geamv_(char *trans, integer *m, integer *n, real *alpha, real *a, integer *lda, real *x, integer *incx, real *beta, real *y, integer *incy);
-
-static VALUE
-rb_sla_geamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- real *a;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- real beta;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.sla_geamv( trans, m, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.sla_geamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - REAL array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y - REAL\n* Array of DIMENSION at least\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_a = argv[3];
- rb_x = argv[4];
- rb_incx = argv[5];
- rb_beta = argv[6];
- rb_y = argv[7];
- rb_incy = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1, m)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, m));
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- trans = StringValueCStr(rb_trans)[0];
- m = NUM2INT(rb_m);
- alpha = (real)NUM2DBL(rb_alpha);
- beta = (real)NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1, m);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (lsame_(&trans,"N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", lsame_(&trans,"N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy));
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (lsame_(&trans,"N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", lsame_(&trans,"N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx));
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = lsame_(&trans,"N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy);
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- sla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_sla_geamv(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_geamv", rb_sla_geamv, -1);
-}
diff --git a/sla_gercond.c b/sla_gercond.c
deleted file mode 100644
index 4e608a9..0000000
--- a/sla_gercond.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_gercond_(char *trans, integer *n, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, integer *cmode, real *c, integer *info, real *work, integer *iwork);
-
-static VALUE
-rb_sla_gercond(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- real *c;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_gercond( trans, a, af, ipiv, cmode, c, work, iwork)\n or\n NumRu::Lapack.sla_gercond # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.2\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, TMP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_cmode = argv[4];
- rb_c = argv[5];
- rb_work = argv[6];
- rb_iwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- trans = StringValueCStr(rb_trans)[0];
- cmode = NUM2INT(rb_cmode);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (3*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
-
- __out__ = sla_gercond_(&trans, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_sla_gercond(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_gercond", rb_sla_gercond, -1);
-}
diff --git a/sla_gerfsx_extended.c b/sla_gerfsx_extended.c
deleted file mode 100644
index c817c01..0000000
--- a/sla_gerfsx_extended.c
+++ /dev/null
@@ -1,264 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_gerfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, logical *colequ, real *c, real *b, integer *ldb, real *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, real *res, real *ayb, real *dy, real *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_sla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_y;
- real *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- real *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- real *dy;
- VALUE rb_y_tail;
- real *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- real *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.sla_gerfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* SLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by SGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_n_norms = argv[9];
- rb_err_bnds_norm = argv[10];
- rb_err_bnds_comp = argv[11];
- rb_res = argv[12];
- rb_ayb = argv[13];
- rb_dy = argv[14];
- rb_y_tail = argv[15];
- rb_rcond = argv[16];
- rb_ithresh = argv[17];
- rb_rthresh = argv[18];
- rb_dz_ub = argv[19];
- rb_ignore_cwise = argv[20];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (13th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SFLOAT)
- rb_res = na_change_type(rb_res, NA_SFLOAT);
- res = NA_PTR_TYPE(rb_res, real*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_SFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SFLOAT)
- rb_dy = na_change_type(rb_dy, NA_SFLOAT);
- dy = NA_PTR_TYPE(rb_dy, real*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- n_norms = NUM2INT(rb_n_norms);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- sla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_sla_gerfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_gerfsx_extended", rb_sla_gerfsx_extended, -1);
-}
diff --git a/sla_lin_berr.c b/sla_lin_berr.c
deleted file mode 100644
index 1f7cc40..0000000
--- a/sla_lin_berr.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_lin_berr_(integer *n, integer *nz, integer *nrhs, real *res, real *ayb, real *berr);
-
-static VALUE
-rb_sla_lin_berr(int argc, VALUE *argv, VALUE self){
- VALUE rb_nz;
- integer nz;
- VALUE rb_res;
- real *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_berr;
- real *berr;
-
- integer n;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr = NumRu::Lapack.sla_lin_berr( nz, res, ayb)\n or\n NumRu::Lapack.sla_lin_berr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* SLA_LIN_BERR computes componentwise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z.\n*\n\n* Arguments\n* ==========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) REAL array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) REAL array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see sla_gerfsx_extended.f).\n* \n* BERR (output) REAL array, dimension (NRHS)\n* The componentwise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL TMP\n INTEGER I, J\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. External Functions ..\n EXTERNAL SLAMCH\n REAL SLAMCH\n REAL SAFE1\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_nz = argv[0];
- rb_res = argv[1];
- rb_ayb = argv[2];
-
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (2th argument) must be NArray");
- if (NA_RANK(rb_res) != 2)
- rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_res);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SFLOAT)
- rb_res = na_change_type(rb_res, NA_SFLOAT);
- res = NA_PTR_TYPE(rb_res, real*);
- nz = NUM2INT(rb_nz);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 2)
- rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ayb) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of ayb must be the same as shape 1 of res");
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
-
- sla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
-
- return rb_berr;
-}
-
-void
-init_lapack_sla_lin_berr(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_lin_berr", rb_sla_lin_berr, -1);
-}
diff --git a/sla_porcond.c b/sla_porcond.c
deleted file mode 100644
index 60b94b6..0000000
--- a/sla_porcond.c
+++ /dev/null
@@ -1,103 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_porcond_(char *uplo, integer *n, real *a, integer *lda, real *af, integer *ldaf, integer *cmode, real *c, integer *info, real *work, integer *iwork);
-
-static VALUE
-rb_sla_porcond(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- real *c;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_porcond( uplo, a, af, cmode, c, work, iwork)\n or\n NumRu::Lapack.sla_porcond # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, TMP\n LOGICAL UP\n* ..\n* .. Array Arguments ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ISAMAX\n EXTERNAL LSAME, ISAMAX\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_cmode = argv[3];
- rb_c = argv[4];
- rb_work = argv[5];
- rb_iwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- cmode = NUM2INT(rb_cmode);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (7th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of a");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (3*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
-
- __out__ = sla_porcond_(&uplo, &n, a, &lda, af, &ldaf, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_sla_porcond(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_porcond", rb_sla_porcond, -1);
-}
diff --git a/sla_porfsx_extended.c b/sla_porfsx_extended.c
deleted file mode 100644
index 50588f0..0000000
--- a/sla_porfsx_extended.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_porfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, logical *colequ, real *c, real *b, integer *ldb, real *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, real *res, real *ayb, real *dy, real *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_sla_porfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_y;
- real *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- real *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- real *dy;
- VALUE rb_y_tail;
- real *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- real *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.sla_porfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* SLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 20)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_colequ = argv[4];
- rb_c = argv[5];
- rb_b = argv[6];
- rb_y = argv[7];
- rb_n_norms = argv[8];
- rb_err_bnds_norm = argv[9];
- rb_err_bnds_comp = argv[10];
- rb_res = argv[11];
- rb_ayb = argv[12];
- rb_dy = argv[13];
- rb_y_tail = argv[14];
- rb_rcond = argv[15];
- rb_ithresh = argv[16];
- rb_rthresh = argv[17];
- rb_dz_ub = argv[18];
- rb_ignore_cwise = argv[19];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (12th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SFLOAT)
- rb_res = na_change_type(rb_res, NA_SFLOAT);
- res = NA_PTR_TYPE(rb_res, real*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_SFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SFLOAT)
- rb_dy = na_change_type(rb_dy, NA_SFLOAT);
- dy = NA_PTR_TYPE(rb_dy, real*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- sla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_sla_porfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_porfsx_extended", rb_sla_porfsx_extended, -1);
-}
diff --git a/sla_porpvgrw.c b/sla_porpvgrw.c
deleted file mode 100644
index 1ac5961..0000000
--- a/sla_porpvgrw.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_porpvgrw_(char *uplo, integer *ncols, real *a, integer *lda, real *af, integer *ldaf, real *work);
-
-static VALUE
-rb_sla_porpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_work;
- real *work;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_porpvgrw( uplo, ncols, a, af, work)\n or\n NumRu::Lapack.sla_porpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* SLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) REAL array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, SLASET\n LOGICAL LSAME\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ncols = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_work = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ncols = NUM2INT(rb_ncols);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (5th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
-
- __out__ = sla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_sla_porpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_porpvgrw", rb_sla_porpvgrw, -1);
-}
diff --git a/sla_rpvgrw.c b/sla_rpvgrw.c
deleted file mode 100644
index 6f63310..0000000
--- a/sla_rpvgrw.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_rpvgrw_(integer *n, integer *ncols, real *a, integer *lda, real *af, integer *ldaf);
-
-static VALUE
-rb_sla_rpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_rpvgrw( ncols, a, af)\n or\n NumRu::Lapack.sla_rpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n*\n* SLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by SGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ncols = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
-
- __out__ = sla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_sla_rpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_rpvgrw", rb_sla_rpvgrw, -1);
-}
diff --git a/sla_syamv.c b/sla_syamv.c
deleted file mode 100644
index 43485ff..0000000
--- a/sla_syamv.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_syamv_(integer *uplo, integer *n, real *alpha, real *a, integer *lda, real *x, integer *incx, real *beta, real *y, integer *incy);
-
-static VALUE
-rb_sla_syamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- integer uplo;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- real *a;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- real beta;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.sla_syamv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.sla_syamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* SLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - REAL array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X (input) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) REAL .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) REAL array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1, n)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = NUM2INT(rb_uplo);
- alpha = (real)NUM2DBL(rb_alpha);
- beta = (real)NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1, n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- sla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_sla_syamv(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_syamv", rb_sla_syamv, -1);
-}
diff --git a/sla_syrcond.c b/sla_syrcond.c
deleted file mode 100644
index 4f7d396..0000000
--- a/sla_syrcond.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_syrcond_(char *uplo, integer *n, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, integer *cmode, real *c, integer *info, real *work, integer *iwork);
-
-static VALUE
-rb_sla_syrcond(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_cmode;
- integer cmode;
- VALUE rb_c;
- real *c;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.sla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork)\n or\n NumRu::Lapack.sla_syrcond # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n* Purpose\n* =======\n*\n* SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)\n* where op2 is determined by CMODE as follows\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n* The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n* is computed by computing scaling factors R such that\n* diag(R)*A*op2(C) is row equilibrated and computing the standard\n* infinity-norm condition number.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* CMODE (input) INTEGER\n* Determines op2(C) in the formula op(A) * op2(C) as follows:\n* CMODE = 1 op2(C) = C\n* CMODE = 0 op2(C) = I\n* CMODE = -1 op2(C) = inv(C)\n*\n* C (input) REAL array, dimension (N)\n* The vector C in the formula op(A) * op2(C).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) REAL array, dimension (3*N).\n* Workspace.\n*\n* IWORK (input) INTEGER array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER NORMIN\n INTEGER KASE, I, J\n REAL AINVNM, SMLNUM, TMP\n LOGICAL UP\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ISAMAX\n REAL SLAMCH\n EXTERNAL LSAME, ISAMAX, SLAMCH\n* ..\n* .. External Subroutines ..\n EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA, SSYTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_cmode = argv[4];
- rb_c = argv[5];
- rb_work = argv[6];
- rb_iwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- cmode = NUM2INT(rb_cmode);
- if (!NA_IsNArray(rb_iwork))
- rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
- if (NA_RANK(rb_iwork) != 1)
- rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_iwork) != NA_LINT)
- rb_iwork = na_change_type(rb_iwork, NA_LINT);
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (3*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
-
- __out__ = sla_syrcond_(&uplo, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_sla_syrcond(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_syrcond", rb_sla_syrcond, -1);
-}
diff --git a/sla_syrfsx_extended.c b/sla_syrfsx_extended.c
deleted file mode 100644
index f9b2af9..0000000
--- a/sla_syrfsx_extended.c
+++ /dev/null
@@ -1,264 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_syrfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, logical *colequ, real *c, real *b, integer *ldb, real *y, integer *ldy, real *berr_out, integer *n_norms, real *err_bnds_norm, real *err_bnds_comp, real *res, real *ayb, real *dy, real *y_tail, real *rcond, integer *ithresh, real *rthresh, real *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_sla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- real *c;
- VALUE rb_b;
- real *b;
- VALUE rb_y;
- real *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_res;
- real *res;
- VALUE rb_ayb;
- real *ayb;
- VALUE rb_dy;
- real *dy;
- VALUE rb_y_tail;
- real *y_tail;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- real rthresh;
- VALUE rb_dz_ub;
- real dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- real *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- real *y_out__;
- VALUE rb_err_bnds_norm_out__;
- real *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- real *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.sla_syrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n* \n* SLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by SSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\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* Y (input/output) REAL array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by SSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) REAL array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by SLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) REAL array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) REAL array, dimension (N)\n* Workspace. This can be the same workspace passed for Y_TAIL.\n*\n* DY (input) REAL array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) REAL array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) REAL\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) REAL\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to SSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n* ..\n\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_n_norms = argv[9];
- rb_err_bnds_norm = argv[10];
- rb_err_bnds_comp = argv[11];
- rb_res = argv[12];
- rb_ayb = argv[13];
- rb_dy = argv[14];
- rb_y_tail = argv[15];
- rb_rcond = argv[16];
- rb_ithresh = argv[17];
- rb_rthresh = argv[18];
- rb_dz_ub = argv[19];
- rb_ignore_cwise = argv[20];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (13th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_SFLOAT)
- rb_res = na_change_type(rb_res, NA_SFLOAT);
- res = NA_PTR_TYPE(rb_res, real*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- dz_ub = (real)NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_SFLOAT)
- rb_y_tail = na_change_type(rb_y_tail, NA_SFLOAT);
- y_tail = NA_PTR_TYPE(rb_y_tail, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = (real)NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_SFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_SFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_SFLOAT)
- rb_dy = na_change_type(rb_dy, NA_SFLOAT);
- dy = NA_PTR_TYPE(rb_dy, real*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_SFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_SFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, real*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_SFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_SFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, real*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, real*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- sla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_sla_syrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_syrfsx_extended", rb_sla_syrfsx_extended, -1);
-}
diff --git a/sla_syrpvgrw.c b/sla_syrpvgrw.c
deleted file mode 100644
index 00e95e2..0000000
--- a/sla_syrpvgrw.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern real sla_syrpvgrw_(char *uplo, integer *n, integer *info, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *work);
-
-static VALUE
-rb_sla_syrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_info;
- integer info;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- real *work;
- VALUE rb___out__;
- real __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.sla_syrpvgrw( uplo, info, a, af, ipiv, work)\n or\n NumRu::Lapack.sla_syrpvgrw # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* SLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from SSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* WORK (input) REAL array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, SLASET\n LOGICAL LSAME\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_info = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_work = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- info = NUM2INT(rb_info);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
-
- __out__ = sla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_sla_syrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_syrpvgrw", rb_sla_syrpvgrw, -1);
-}
diff --git a/sla_wwaddw.c b/sla_wwaddw.c
deleted file mode 100644
index a9de63f..0000000
--- a/sla_wwaddw.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sla_wwaddw_(integer *n, real *x, real *y, real *w);
-
-static VALUE
-rb_sla_wwaddw(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- real *x;
- VALUE rb_y;
- real *y;
- VALUE rb_w;
- real *w;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.sla_wwaddw( x, y, w)\n or\n NumRu::Lapack.sla_wwaddw # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* SLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) REAL array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) REAL array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) REAL array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL S\n INTEGER I\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_w = argv[2];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (2th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of w");
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- sla_wwaddw_(&n, x, y, w);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_sla_wwaddw(VALUE mLapack){
- rb_define_module_function(mLapack, "sla_wwaddw", rb_sla_wwaddw, -1);
-}
diff --git a/slabad.c b/slabad.c
deleted file mode 100644
index a4fd793..0000000
--- a/slabad.c
+++ /dev/null
@@ -1,35 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slabad_(real *small, real *large);
-
-static VALUE
-rb_slabad(int argc, VALUE *argv, VALUE self){
- VALUE rb_small;
- real small;
- VALUE rb_large;
- real large;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n small, large = NumRu::Lapack.slabad( small, large)\n or\n NumRu::Lapack.slabad # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLABAD( SMALL, LARGE )\n\n* Purpose\n* =======\n*\n* SLABAD takes as input the values computed by SLAMCH for underflow and\n* overflow, and returns the square root of each of these values if the\n* log of LARGE is sufficiently large. This subroutine is intended to\n* identify machines with a large exponent range, such as the Crays, and\n* redefine the underflow and overflow limits to be the square roots of\n* the values computed by SLAMCH. This subroutine is needed because\n* SLAMCH does not compensate for poor arithmetic in the upper half of\n* the exponent range, as is found on a Cray.\n*\n\n* Arguments\n* =========\n*\n* SMALL (input/output) REAL\n* On entry, the underflow threshold as computed by SLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of SMALL, otherwise unchanged.\n*\n* LARGE (input/output) REAL\n* On entry, the overflow threshold as computed by SLAMCH.\n* On exit, if LOG10(LARGE) is sufficiently large, the square\n* root of LARGE, otherwise unchanged.\n*\n\n* =====================================================================\n*\n* .. Intrinsic Functions ..\n INTRINSIC LOG10, SQRT\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_small = argv[0];
- rb_large = argv[1];
-
- large = (real)NUM2DBL(rb_large);
- small = (real)NUM2DBL(rb_small);
-
- slabad_(&small, &large);
-
- rb_small = rb_float_new((double)small);
- rb_large = rb_float_new((double)large);
- return rb_ary_new3(2, rb_small, rb_large);
-}
-
-void
-init_lapack_slabad(VALUE mLapack){
- rb_define_module_function(mLapack, "slabad", rb_slabad, -1);
-}
diff --git a/slabrd.c b/slabrd.c
deleted file mode 100644
index 8306f4b..0000000
--- a/slabrd.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slabrd_(integer *m, integer *n, integer *nb, real *a, integer *lda, real *d, real *e, real *tauq, real *taup, real *x, integer *ldx, real *y, integer *ldy);
-
-static VALUE
-rb_slabrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- real *a;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tauq;
- real *tauq;
- VALUE rb_taup;
- real *taup;
- VALUE rb_x;
- real *x;
- VALUE rb_y;
- real *y;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer ldx;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.slabrd( m, nb, a)\n or\n NumRu::Lapack.slabrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* SLABRD reduces the first NB rows and columns of a real general\n* m by n matrix A to upper or lower bidiagonal form by an orthogonal\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by SGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the orthogonal matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the orthogonal\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the orthogonal matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) REAL array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) REAL array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix Q. See Further Details.\n*\n* TAUP (output) REAL array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the orthogonal matrix P. See Further Details.\n*\n* X (output) REAL array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= M.\n*\n* Y (output) REAL array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are real scalars, and v and u are real vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- nb = NUM2INT(rb_nb);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ldy = n;
- ldx = m;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, real*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = MAX(1,nb);
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
-
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_x, rb_y, rb_a);
-}
-
-void
-init_lapack_slabrd(VALUE mLapack){
- rb_define_module_function(mLapack, "slabrd", rb_slabrd, -1);
-}
diff --git a/slacn2.c b/slacn2.c
deleted file mode 100644
index 6ae561d..0000000
--- a/slacn2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slacn2_(integer *n, real *v, real *x, integer *isgn, real *est, integer *kase, integer *isave);
-
-static VALUE
-rb_slacn2(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- real *x;
- VALUE rb_est;
- real est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_isave;
- integer *isave;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_isave_out__;
- integer *isave_out__;
- real *v;
- integer *isgn;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.slacn2( x, est, kase, isave)\n or\n NumRu::Lapack.slacn2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* SLACN2 estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) REAL array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) REAL array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and SLACN2 must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to SLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to SLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from SLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to SLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* This is a thread safe version of SLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* SLACON SLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
- rb_isave = argv[3];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- est = (real)NUM2DBL(rb_est);
- if (!NA_IsNArray(rb_isave))
- rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
- if (NA_RANK(rb_isave) != 1)
- rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isave) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
- if (NA_TYPE(rb_isave) != NA_LINT)
- rb_isave = na_change_type(rb_isave, NA_LINT);
- isave = NA_PTR_TYPE(rb_isave, integer*);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 3;
- rb_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isave_out__ = NA_PTR_TYPE(rb_isave_out__, integer*);
- MEMCPY(isave_out__, isave, integer, NA_TOTAL(rb_isave));
- rb_isave = rb_isave_out__;
- isave = isave_out__;
- v = ALLOC_N(real, (n));
- isgn = ALLOC_N(integer, (n));
-
- slacn2_(&n, v, x, isgn, &est, &kase, isave);
-
- free(v);
- free(isgn);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(4, rb_x, rb_est, rb_kase, rb_isave);
-}
-
-void
-init_lapack_slacn2(VALUE mLapack){
- rb_define_module_function(mLapack, "slacn2", rb_slacn2, -1);
-}
diff --git a/slacon.c b/slacon.c
deleted file mode 100644
index 8827de5..0000000
--- a/slacon.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slacon_(integer *n, real *v, real *x, integer *isgn, real *est, integer *kase);
-
-static VALUE
-rb_slacon(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- real *x;
- VALUE rb_est;
- real est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_x_out__;
- real *x_out__;
- real *v;
- integer *isgn;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.slacon( x, est, kase)\n or\n NumRu::Lapack.slacon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE )\n\n* Purpose\n* =======\n*\n* SLACON estimates the 1-norm of a square, real matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) REAL array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) REAL array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* and SLACON must be re-called with all the other parameters\n* unchanged.\n*\n* ISGN (workspace) INTEGER array, dimension (N)\n*\n* EST (input/output) REAL\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to SLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to SLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from SLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named SONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- est = (real)NUM2DBL(rb_est);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- v = ALLOC_N(real, (n));
- isgn = ALLOC_N(integer, (n));
-
- slacon_(&n, v, x, isgn, &est, &kase);
-
- free(v);
- free(isgn);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(3, rb_x, rb_est, rb_kase);
-}
-
-void
-init_lapack_slacon(VALUE mLapack){
- rb_define_module_function(mLapack, "slacon", rb_slacon, -1);
-}
diff --git a/slacpy.c b/slacpy.c
deleted file mode 100644
index 2c761bd..0000000
--- a/slacpy.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slacpy_(char *uplo, integer *m, integer *n, real *a, integer *lda, real *b, integer *ldb);
-
-static VALUE
-rb_slacpy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.slacpy( uplo, m, a)\n or\n NumRu::Lapack.slacpy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* SLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper triangle\n* or trapezoid is accessed; if UPLO = 'L', only the lower\n* triangle or trapezoid is accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) REAL array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- ldb = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b = NA_PTR_TYPE(rb_b, real*);
-
- slacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_slacpy(VALUE mLapack){
- rb_define_module_function(mLapack, "slacpy", rb_slacpy, -1);
-}
diff --git a/sladiv.c b/sladiv.c
deleted file mode 100644
index 0950b40..0000000
--- a/sladiv.c
+++ /dev/null
@@ -1,47 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sladiv_(real *a, real *b, real *c, real *d, real *p, real *q);
-
-static VALUE
-rb_sladiv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real a;
- VALUE rb_b;
- real b;
- VALUE rb_c;
- real c;
- VALUE rb_d;
- real d;
- VALUE rb_p;
- real p;
- VALUE rb_q;
- real q;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n p, q = NumRu::Lapack.sladiv( a, b, c, d)\n or\n NumRu::Lapack.sladiv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLADIV( A, B, C, D, P, Q )\n\n* Purpose\n* =======\n*\n* SLADIV performs complex division in real arithmetic\n*\n* a + i*b\n* p + i*q = ---------\n* c + i*d\n*\n* The algorithm is due to Robert L. Smith and can be found\n* in D. Knuth, The art of Computer Programming, Vol.2, p.195\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL\n* B (input) REAL\n* C (input) REAL\n* D (input) REAL\n* The scalars a, b, c, and d in the above expression.\n*\n* P (output) REAL\n* Q (output) REAL\n* The scalars p and q in the above expression.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n REAL E, F\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
-
- a = (real)NUM2DBL(rb_a);
- b = (real)NUM2DBL(rb_b);
- c = (real)NUM2DBL(rb_c);
- d = (real)NUM2DBL(rb_d);
-
- sladiv_(&a, &b, &c, &d, &p, &q);
-
- rb_p = rb_float_new((double)p);
- rb_q = rb_float_new((double)q);
- return rb_ary_new3(2, rb_p, rb_q);
-}
-
-void
-init_lapack_sladiv(VALUE mLapack){
- rb_define_module_function(mLapack, "sladiv", rb_sladiv, -1);
-}
diff --git a/slae2.c b/slae2.c
deleted file mode 100644
index be02161..0000000
--- a/slae2.c
+++ /dev/null
@@ -1,43 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slae2_(real *a, real *b, real *c, real *rt1, real *rt2);
-
-static VALUE
-rb_slae2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real a;
- VALUE rb_b;
- real b;
- VALUE rb_c;
- real c;
- VALUE rb_rt1;
- real rt1;
- VALUE rb_rt2;
- real rt2;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2 = NumRu::Lapack.slae2( a, b, c)\n or\n NumRu::Lapack.slae2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAE2( A, B, C, RT1, RT2 )\n\n* Purpose\n* =======\n*\n* SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, and RT2\n* is the eigenvalue of smaller absolute value.\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) REAL\n* The (1,2) and (2,1) elements of the 2-by-2 matrix.\n*\n* C (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) REAL\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) REAL\n* The eigenvalue of smaller absolute value.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a = (real)NUM2DBL(rb_a);
- b = (real)NUM2DBL(rb_b);
- c = (real)NUM2DBL(rb_c);
-
- slae2_(&a, &b, &c, &rt1, &rt2);
-
- rb_rt1 = rb_float_new((double)rt1);
- rb_rt2 = rb_float_new((double)rt2);
- return rb_ary_new3(2, rb_rt1, rb_rt2);
-}
-
-void
-init_lapack_slae2(VALUE mLapack){
- rb_define_module_function(mLapack, "slae2", rb_slae2, -1);
-}
diff --git a/slaebz.c b/slaebz.c
deleted file mode 100644
index da3d3b5..0000000
--- a/slaebz.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaebz_(integer *ijob, integer *nitmax, integer *n, integer *mmax, integer *minp, integer *nbmin, real *abstol, real *reltol, real *pivmin, real *d, real *e, real *e2, integer *nval, real *ab, real *c, integer *mout, integer *nab, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slaebz(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_nitmax;
- integer nitmax;
- VALUE rb_minp;
- integer minp;
- VALUE rb_nbmin;
- integer nbmin;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_reltol;
- real reltol;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_e2;
- real *e2;
- VALUE rb_nval;
- integer *nval;
- VALUE rb_ab;
- real *ab;
- VALUE rb_c;
- real *c;
- VALUE rb_nab;
- integer *nab;
- VALUE rb_mout;
- integer mout;
- VALUE rb_info;
- integer info;
- VALUE rb_nval_out__;
- integer *nval_out__;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_nab_out__;
- integer *nab_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer mmax;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n mout, info, nval, ab, c, nab = NumRu::Lapack.slaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab)\n or\n NumRu::Lapack.slaebz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAEBZ contains the iteration loops which compute and use the\n* function N(w), which is the count of eigenvalues of a symmetric\n* tridiagonal matrix T less than or equal to its argument w. It\n* performs a choice of two types of loops:\n*\n* IJOB=1, followed by\n* IJOB=2: It takes as input a list of intervals and returns a list of\n* sufficiently small intervals whose union contains the same\n* eigenvalues as the union of the original intervals.\n* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n* The output interval (AB(j,1),AB(j,2)] will contain\n* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n*\n* IJOB=3: It performs a binary search in each input interval\n* (AB(j,1),AB(j,2)] for a point w(j) such that\n* N(w(j))=NVAL(j), and uses C(j) as the starting point of\n* the search. If such a w(j) is found, then on output\n* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output\n* (AB(j,1),AB(j,2)] will be a small interval containing the\n* point where N(w) jumps through NVAL(j), unless that point\n* lies outside the initial interval.\n*\n* Note that the intervals are in all cases half-open intervals,\n* i.e., of the form (a,b] , which includes b but not a .\n*\n* To avoid underflow, the matrix should be scaled so that its largest\n* element is no greater than overflow**(1/2) * underflow**(1/4)\n* in absolute value. To assure the most accurate computation\n* of small eigenvalues, the matrix should be scaled to be\n* not much smaller than that, either.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966\n*\n* Note: the arguments are, in general, *not* checked for unreasonable\n* values.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies what is to be done:\n* = 1: Compute NAB for the initial intervals.\n* = 2: Perform bisection iteration to find eigenvalues of T.\n* = 3: Perform bisection iteration to invert N(w), i.e.,\n* to find a point which has a specified number of\n* eigenvalues of T to its left.\n* Other values will cause SLAEBZ to return with INFO=-1.\n*\n* NITMAX (input) INTEGER\n* The maximum number of \"levels\" of bisection to be\n* performed, i.e., an interval of width W will not be made\n* smaller than 2^(-NITMAX) * W. If not all intervals\n* have converged after NITMAX iterations, then INFO is set\n* to the number of non-converged intervals.\n*\n* N (input) INTEGER\n* The dimension n of the tridiagonal matrix T. It must be at\n* least 1.\n*\n* MMAX (input) INTEGER\n* The maximum number of intervals. If more than MMAX intervals\n* are generated, then SLAEBZ will quit with INFO=MMAX+1.\n*\n* MINP (input) INTEGER\n* The initial number of intervals. It may not be greater than\n* MMAX.\n*\n* NBMIN (input) INTEGER\n* The smallest number of intervals that should be processed\n* using a vector loop. If zero, then only the scalar loop\n* will be used.\n*\n* ABSTOL (input) REAL\n* The minimum (absolute) width of an interval. When an\n* interval is narrower than ABSTOL, or than RELTOL times the\n* larger (in magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. This must be at least\n* zero.\n*\n* RELTOL (input) REAL\n* The minimum relative width of an interval. When an interval\n* is narrower than ABSTOL, or than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* PIVMIN (input) REAL\n* The minimum absolute value of a \"pivot\" in the Sturm\n* sequence loop. This *must* be at least max |e(j)**2| *\n* safe_min and at least safe_min, where safe_min is at least\n* the smallest number that can divide one without overflow.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N)\n* The offdiagonal elements of the tridiagonal matrix T in\n* positions 1 through N-1. E(N) is arbitrary.\n*\n* E2 (input) REAL array, dimension (N)\n* The squares of the offdiagonal elements of the tridiagonal\n* matrix T. E2(N) is ignored.\n*\n* NVAL (input/output) INTEGER array, dimension (MINP)\n* If IJOB=1 or 2, not referenced.\n* If IJOB=3, the desired values of N(w). The elements of NVAL\n* will be reordered to correspond with the intervals in AB.\n* Thus, NVAL(j) on output will not, in general be the same as\n* NVAL(j) on input, but it will correspond with the interval\n* (AB(j,1),AB(j,2)] on output.\n*\n* AB (input/output) REAL array, dimension (MMAX,2)\n* The endpoints of the intervals. AB(j,1) is a(j), the left\n* endpoint of the j-th interval, and AB(j,2) is b(j), the\n* right endpoint of the j-th interval. The input intervals\n* will, in general, be modified, split, and reordered by the\n* calculation.\n*\n* C (input/output) REAL array, dimension (MMAX)\n* If IJOB=1, ignored.\n* If IJOB=2, workspace.\n* If IJOB=3, then on input C(j) should be initialized to the\n* first search point in the binary search.\n*\n* MOUT (output) INTEGER\n* If IJOB=1, the number of eigenvalues in the intervals.\n* If IJOB=2 or 3, the number of intervals output.\n* If IJOB=3, MOUT will equal MINP.\n*\n* NAB (input/output) INTEGER array, dimension (MMAX,2)\n* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n* If IJOB=2, then on input, NAB(i,j) should be set. It must\n* satisfy the condition:\n* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n* which means that in interval i only eigenvalues\n* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,\n* NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with\n* IJOB=1.\n* On output, NAB(i,j) will contain\n* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n* the input interval that the output interval\n* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n* the input values of NAB(k,1) and NAB(k,2).\n* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n* unless N(w) > NVAL(i) for all search points w , in which\n* case NAB(i,1) will not be modified, i.e., the output\n* value will be the same as the input value (modulo\n* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n* for all search points w , in which case NAB(i,2) will\n* not be modified. Normally, NAB should be set to some\n* distinctive value(s) before SLAEBZ is called.\n*\n* WORK (workspace) REAL array, dimension (MMAX)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (MMAX)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: All intervals converged.\n* = 1--MMAX: The last INFO intervals did not converge.\n* = MMAX+1: More than MMAX intervals were generated.\n*\n\n* Further Details\n* ===============\n*\n* This routine is intended to be called only by other LAPACK\n* routines, thus the interface is less user-friendly. It is intended\n* for two purposes:\n*\n* (a) finding eigenvalues. In this case, SLAEBZ should have one or\n* more initial intervals set up in AB, and SLAEBZ should be called\n* with IJOB=1. This sets up NAB, and also counts the eigenvalues.\n* Intervals with no eigenvalues would usually be thrown out at\n* this point. Also, if not all the eigenvalues in an interval i\n* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n* eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX\n* no smaller than the value of MOUT returned by the call with\n* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n* tolerance specified by ABSTOL and RELTOL.\n*\n* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n* In this case, start with a Gershgorin interval (a,b). Set up\n* AB to contain 2 search intervals, both initially (a,b). One\n* NVAL element should contain f-1 and the other should contain l\n* , while C should contain a and b, resp. NAB(i,1) should be -1\n* and NAB(i,2) should be N+1, to flag an error if the desired\n* interval does not lie in (a,b). SLAEBZ is then called with\n* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --\n* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and\n* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and\n* w(l-r)=...=w(l+k) are handled similarly.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_ijob = argv[0];
- rb_nitmax = argv[1];
- rb_minp = argv[2];
- rb_nbmin = argv[3];
- rb_abstol = argv[4];
- rb_reltol = argv[5];
- rb_pivmin = argv[6];
- rb_d = argv[7];
- rb_e = argv[8];
- rb_e2 = argv[9];
- rb_nval = argv[10];
- rb_ab = argv[11];
- rb_c = argv[12];
- rb_nab = argv[13];
-
- abstol = (real)NUM2DBL(rb_abstol);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (12th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be %d", 2);
- mmax = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (10th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e2);
- if (NA_TYPE(rb_e2) != NA_SFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_SFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, real*);
- nitmax = NUM2INT(rb_nitmax);
- pivmin = (real)NUM2DBL(rb_pivmin);
- if (!NA_IsNArray(rb_nab))
- rb_raise(rb_eArgError, "nab (14th argument) must be NArray");
- if (NA_RANK(rb_nab) != 2)
- rb_raise(rb_eArgError, "rank of nab (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_nab) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of nab must be %d", 2);
- if (NA_SHAPE0(rb_nab) != mmax)
- rb_raise(rb_eRuntimeError, "shape 0 of nab must be the same as shape 0 of ab");
- if (NA_TYPE(rb_nab) != NA_LINT)
- rb_nab = na_change_type(rb_nab, NA_LINT);
- nab = NA_PTR_TYPE(rb_nab, integer*);
- nbmin = NUM2INT(rb_nbmin);
- reltol = (real)NUM2DBL(rb_reltol);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (9th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of e2");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- minp = NUM2INT(rb_minp);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (8th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e2");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_nval))
- rb_raise(rb_eArgError, "nval (11th argument) must be NArray");
- if (NA_RANK(rb_nval) != 1)
- rb_raise(rb_eArgError, "rank of nval (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_nval) != ((ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of nval must be %d", (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0);
- if (NA_TYPE(rb_nval) != NA_LINT)
- rb_nval = na_change_type(rb_nval, NA_LINT);
- nval = NA_PTR_TYPE(rb_nval, integer*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (13th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- {
- int shape[1];
- shape[0] = (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0;
- rb_nval_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- nval_out__ = NA_PTR_TYPE(rb_nval_out__, integer*);
- MEMCPY(nval_out__, nval, integer, NA_TOTAL(rb_nval));
- rb_nval = rb_nval_out__;
- nval = nval_out__;
- {
- int shape[2];
- shape[0] = mmax;
- shape[1] = 2;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[1];
- shape[0] = ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = mmax;
- shape[1] = 2;
- rb_nab_out__ = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- nab_out__ = NA_PTR_TYPE(rb_nab_out__, integer*);
- MEMCPY(nab_out__, nab, integer, NA_TOTAL(rb_nab));
- rb_nab = rb_nab_out__;
- nab = nab_out__;
- work = ALLOC_N(real, (mmax));
- iwork = ALLOC_N(integer, (mmax));
-
- slaebz_(&ijob, &nitmax, &n, &mmax, &minp, &nbmin, &abstol, &reltol, &pivmin, d, e, e2, nval, ab, c, &mout, nab, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_mout = INT2NUM(mout);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_mout, rb_info, rb_nval, rb_ab, rb_c, rb_nab);
-}
-
-void
-init_lapack_slaebz(VALUE mLapack){
- rb_define_module_function(mLapack, "slaebz", rb_slaebz, -1);
-}
diff --git a/slaed0.c b/slaed0.c
deleted file mode 100644
index 3ae2307..0000000
--- a/slaed0.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed0_(integer *icompq, integer *qsiz, integer *n, real *d, real *e, real *q, integer *ldq, real *qstore, integer *ldqs, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slaed0(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_q;
- real *q;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_q_out__;
- real *q_out__;
- real *qstore;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldq;
- integer ldqs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, q = NumRu::Lapack.slaed0( icompq, qsiz, d, e, q)\n or\n NumRu::Lapack.slaed0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAED0 computes all eigenvalues and corresponding eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n* = 2: Compute eigenvalues and eigenvectors of tridiagonal\n* matrix.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the main diagonal of the tridiagonal matrix.\n* On exit, its eigenvalues.\n*\n* E (input) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, Q must contain an N-by-N orthogonal matrix.\n* If ICOMPQ = 0 Q is not referenced.\n* If ICOMPQ = 1 On entry, Q is a subset of the columns of the\n* orthogonal matrix used to reduce the full\n* matrix to tridiagonal form corresponding to\n* the subset of the full matrix which is being\n* decomposed at this time.\n* If ICOMPQ = 2 On entry, Q will be the identity matrix.\n* On exit, Q contains the eigenvectors of the\n* tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If eigenvectors are\n* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.\n*\n* QSTORE (workspace) REAL array, dimension (LDQS, N)\n* Referenced only when ICOMPQ = 1. Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE. If ICOMPQ = 1,\n* then LDQS >= max(1,N). In any case, LDQS >= 1.\n*\n* WORK (workspace) REAL array,\n* If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n* 1 + 3*N + 2*N*lg N + 2*N**2\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of WORK must be at least\n* 4*N + N**2.\n*\n* IWORK (workspace) INTEGER array,\n* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n* If ICOMPQ = 2, the dimension of IWORK must be at least\n* 3 + 5*N.\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_icompq = argv[0];
- rb_qsiz = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_q = argv[4];
-
- qsiz = NUM2INT(rb_qsiz);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- ldqs = icompq == 1 ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- qstore = ALLOC_N(real, (ldqs)*(n));
- work = ALLOC_N(real, (((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0));
- iwork = ALLOC_N(integer, (((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0));
-
- slaed0_(&icompq, &qsiz, &n, d, e, q, &ldq, qstore, &ldqs, work, iwork, &info);
-
- free(qstore);
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_q);
-}
-
-void
-init_lapack_slaed0(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed0", rb_slaed0, -1);
-}
diff --git a/slaed1.c b/slaed1.c
deleted file mode 100644
index 0d63767..0000000
--- a/slaed1.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed1_(integer *n, real *d, real *q, integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slaed1(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_q;
- real *q;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_rho;
- real rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_indxq_out__;
- integer *indxq_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, q, indxq = NumRu::Lapack.slaed1( d, q, indxq, rho, cutpnt)\n or\n NumRu::Lapack.slaed1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAED1 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles\n* the case in which eigenvalues only or eigenvalues and eigenvectors\n* of a full symmetric matrix (which was reduced to tridiagonal form)\n* are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine SLAED4 (as called by SLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* On entry, the permutation which separately sorts the two\n* subproblems in D into ascending order.\n* On exit, the permutation which will reintegrate the\n* subproblems back into sorted order,\n* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* RHO (input) REAL\n* The subdiagonal entry used to create the rank-1 modification.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= CUTPNT <= N/2.\n*\n* WORK (workspace) REAL array, dimension (4*N + N**2)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,\n $ IQ2, IS, IW, IZ, K, N1, N2\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_q = argv[1];
- rb_indxq = argv[2];
- rb_rho = argv[3];
- rb_cutpnt = argv[4];
-
- cutpnt = NUM2INT(rb_cutpnt);
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (3th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (2th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of indxq");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq_out__ = NA_PTR_TYPE(rb_indxq_out__, integer*);
- MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rb_indxq));
- rb_indxq = rb_indxq_out__;
- indxq = indxq_out__;
- work = ALLOC_N(real, (4*n + pow(n,2)));
- iwork = ALLOC_N(integer, (4*n));
-
- slaed1_(&n, d, q, &ldq, indxq, &rho, &cutpnt, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_q, rb_indxq);
-}
-
-void
-init_lapack_slaed1(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed1", rb_slaed1, -1);
-}
diff --git a/slaed2.c b/slaed2.c
deleted file mode 100644
index 02b5520..0000000
--- a/slaed2.c
+++ /dev/null
@@ -1,170 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed2_(integer *k, integer *n, integer *n1, real *d, real *q, integer *ldq, integer *indxq, real *rho, real *z, real *dlamda, real *w, real *q2, integer *indx, integer *indxc, integer *indxp, integer *coltyp, integer *info);
-
-static VALUE
-rb_slaed2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n1;
- integer n1;
- VALUE rb_d;
- real *d;
- VALUE rb_q;
- real *q;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_rho;
- real rho;
- VALUE rb_z;
- real *z;
- VALUE rb_k;
- integer k;
- VALUE rb_dlamda;
- real *dlamda;
- VALUE rb_w;
- real *w;
- VALUE rb_q2;
- real *q2;
- VALUE rb_indxc;
- integer *indxc;
- VALUE rb_coltyp;
- integer *coltyp;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_indxq_out__;
- integer *indxq_out__;
- integer *indx;
- integer *indxp;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.slaed2( n1, d, q, indxq, rho, z)\n or\n NumRu::Lapack.slaed2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* SLAED2 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation. 0 <= K <=N.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading sub-matrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined.\n* On exit, D contains the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, Q contains the eigenvectors of two submatrices in\n* the two square blocks with corners at (1,1), (N1,N1)\n* and (N1+1, N1+1), (N,N).\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input/output) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have N1 added to their\n* values. Destroyed on exit.\n*\n* RHO (input/output) REAL\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* SLAED3.\n*\n* Z (input) REAL array, dimension (N)\n* On entry, Z contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n* On exit, the contents of Z have been destroyed by the updating\n* process.\n*\n* DLAMDA (output) REAL array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* SLAED3 to form the secular equation.\n*\n* W (output) REAL array, dimension (N)\n* The first k values of the final deflation-altered z-vector\n* which will be passed to SLAED3.\n*\n* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2)\n* A copy of the first K eigenvectors which will be used by\n* SLAED3 in a matrix multiply (SGEMM) to solve for the new\n* eigenvectors.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of DLAMDA into\n* ascending order.\n*\n* INDXC (output) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups: the first group contains non-zero\n* elements only at and above N1, the second contains\n* non-zero elements only below N1, and the third is dense.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* COLTYP (workspace/output) INTEGER array, dimension (N)\n* During execution, a label which will indicate which of the\n* following types a column in the Q2 matrix is:\n* 1 : non-zero in the upper half only;\n* 2 : dense;\n* 3 : non-zero in the lower half only;\n* 4 : deflated.\n* On exit, COLTYP(i) is the number of columns of type i,\n* for i=1 to 4 only.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_n1 = argv[0];
- rb_d = argv[1];
- rb_q = argv[2];
- rb_indxq = argv[3];
- rb_rho = argv[4];
- rb_z = argv[5];
-
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (4th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- rho = (real)NUM2DBL(rb_rho);
- n1 = NUM2INT(rb_n1);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of indxq");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dlamda = NA_PTR_TYPE(rb_dlamda, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = pow(n1,2)+pow(n-n1,2);
- rb_q2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- q2 = NA_PTR_TYPE(rb_q2, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_indxc = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxc = NA_PTR_TYPE(rb_indxc, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- coltyp = NA_PTR_TYPE(rb_coltyp, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq_out__ = NA_PTR_TYPE(rb_indxq_out__, integer*);
- MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rb_indxq));
- rb_indxq = rb_indxq_out__;
- indxq = indxq_out__;
- indx = ALLOC_N(integer, (n));
- indxp = ALLOC_N(integer, (n));
-
- slaed2_(&k, &n, &n1, d, q, &ldq, indxq, &rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, &info);
-
- free(indx);
- free(indxp);
- rb_k = INT2NUM(k);
- rb_info = INT2NUM(info);
- rb_rho = rb_float_new((double)rho);
- return rb_ary_new3(11, rb_k, rb_dlamda, rb_w, rb_q2, rb_indxc, rb_coltyp, rb_info, rb_d, rb_q, rb_indxq, rb_rho);
-}
-
-void
-init_lapack_slaed2(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed2", rb_slaed2, -1);
-}
diff --git a/slaed3.c b/slaed3.c
deleted file mode 100644
index 29646b4..0000000
--- a/slaed3.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed3_(integer *k, integer *n, integer *n1, real *d, real *q, integer *ldq, real *rho, real *dlamda, real *q2, integer *indx, integer *ctot, real *w, real *s, integer *info);
-
-static VALUE
-rb_slaed3(int argc, VALUE *argv, VALUE self){
- VALUE rb_n1;
- integer n1;
- VALUE rb_rho;
- real rho;
- VALUE rb_dlamda;
- real *dlamda;
- VALUE rb_q2;
- real *q2;
- VALUE rb_indx;
- integer *indx;
- VALUE rb_ctot;
- integer *ctot;
- VALUE rb_w;
- real *w;
- VALUE rb_d;
- real *d;
- VALUE rb_q;
- real *q;
- VALUE rb_info;
- integer info;
- VALUE rb_dlamda_out__;
- real *dlamda_out__;
- VALUE rb_w_out__;
- real *w_out__;
- real *s;
-
- integer k;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, q, info, dlamda, w = NumRu::Lapack.slaed3( n1, rho, dlamda, q2, indx, ctot, w)\n or\n NumRu::Lapack.slaed3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n* Purpose\n* =======\n*\n* SLAED3 finds the roots of the secular equation, as defined by the\n* values in D, W, and RHO, between 1 and K. It makes the\n* appropriate calls to SLAED4 and then updates the eigenvectors by\n* multiplying the matrix of eigenvectors of the pair of eigensystems\n* being combined by the matrix of eigenvectors of the K-by-K system\n* which is solved here.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* SLAED4. K >= 0.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (deflation may result in N>K).\n*\n* N1 (input) INTEGER\n* The location of the last eigenvalue in the leading submatrix.\n* min(1,N) <= N1 <= N/2.\n*\n* D (output) REAL array, dimension (N)\n* D(I) contains the updated eigenvalues for\n* 1 <= I <= K.\n*\n* Q (output) REAL array, dimension (LDQ,N)\n* Initially the first K columns are used as workspace.\n* On output the columns 1 to K contain\n* the updated eigenvectors.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) REAL\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input/output) REAL array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation. May be changed on output by\n* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n* Cray-2, or Cray C-90, as described above.\n*\n* Q2 (input) REAL array, dimension (LDQ2, N)\n* The first K columns of this matrix contain the non-deflated\n* eigenvectors for the split problem.\n*\n* INDX (input) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of the deflated\n* Q matrix into three groups (see SLAED2).\n* The rows of the eigenvectors found by SLAED4 must be likewise\n* permuted before the matrix multiply can take place.\n*\n* CTOT (input) INTEGER array, dimension (4)\n* A count of the total number of the various types of columns\n* in Q, as described in INDX. The fourth column type is any\n* column which has been deflated.\n*\n* W (input/output) REAL array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector. Destroyed on\n* output.\n*\n* S (workspace) REAL array, dimension (N1 + 1)*K\n* Will contain the eigenvectors of the repaired matrix which\n* will be multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_n1 = argv[0];
- rb_rho = argv[1];
- rb_dlamda = argv[2];
- rb_q2 = argv[3];
- rb_indx = argv[4];
- rb_ctot = argv[5];
- rb_w = argv[6];
-
- if (!NA_IsNArray(rb_ctot))
- rb_raise(rb_eArgError, "ctot (6th argument) must be NArray");
- if (NA_RANK(rb_ctot) != 1)
- rb_raise(rb_eArgError, "rank of ctot (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ctot) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
- if (NA_TYPE(rb_ctot) != NA_LINT)
- rb_ctot = na_change_type(rb_ctot, NA_LINT);
- ctot = NA_PTR_TYPE(rb_ctot, integer*);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (7th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
- k = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- if (!NA_IsNArray(rb_q2))
- rb_raise(rb_eArgError, "q2 (4th argument) must be NArray");
- if (NA_RANK(rb_q2) != 2)
- rb_raise(rb_eArgError, "rank of q2 (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q2);
- if (NA_SHAPE0(rb_q2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of q2 must be the same as shape 1 of q2");
- if (NA_TYPE(rb_q2) != NA_SFLOAT)
- rb_q2 = na_change_type(rb_q2, NA_SFLOAT);
- q2 = NA_PTR_TYPE(rb_q2, real*);
- if (!NA_IsNArray(rb_dlamda))
- rb_raise(rb_eArgError, "dlamda (3th argument) must be NArray");
- if (NA_RANK(rb_dlamda) != 1)
- rb_raise(rb_eArgError, "rank of dlamda (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlamda) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of dlamda must be the same as shape 0 of w");
- if (NA_TYPE(rb_dlamda) != NA_SFLOAT)
- rb_dlamda = na_change_type(rb_dlamda, NA_SFLOAT);
- dlamda = NA_PTR_TYPE(rb_dlamda, real*);
- if (!NA_IsNArray(rb_indx))
- rb_raise(rb_eArgError, "indx (5th argument) must be NArray");
- if (NA_RANK(rb_indx) != 1)
- rb_raise(rb_eArgError, "rank of indx (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_indx) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of indx must be the same as shape 1 of q2");
- if (NA_TYPE(rb_indx) != NA_LINT)
- rb_indx = na_change_type(rb_indx, NA_LINT);
- indx = NA_PTR_TYPE(rb_indx, integer*);
- n1 = NUM2INT(rb_n1);
- rho = (real)NUM2DBL(rb_rho);
- ldq = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[1];
- shape[0] = k;
- rb_dlamda_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dlamda_out__ = NA_PTR_TYPE(rb_dlamda_out__, real*);
- MEMCPY(dlamda_out__, dlamda, real, NA_TOTAL(rb_dlamda));
- rb_dlamda = rb_dlamda_out__;
- dlamda = dlamda_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, real*);
- MEMCPY(w_out__, w, real, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- s = ALLOC_N(real, (MAX(1,k))*(n1 + 1));
-
- slaed3_(&k, &n, &n1, d, q, &ldq, &rho, dlamda, q2, indx, ctot, w, s, &info);
-
- free(s);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_q, rb_info, rb_dlamda, rb_w);
-}
-
-void
-init_lapack_slaed3(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed3", rb_slaed3, -1);
-}
diff --git a/slaed4.c b/slaed4.c
deleted file mode 100644
index 996f1ce..0000000
--- a/slaed4.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed4_(integer *n, integer *i, real *d, real *z, real *delta, real *rho, real *dlam, integer *info);
-
-static VALUE
-rb_slaed4(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- real *d;
- VALUE rb_z;
- real *z;
- VALUE rb_rho;
- real rho;
- VALUE rb_delta;
- real *delta;
- VALUE rb_dlam;
- real dlam;
- VALUE rb_info;
- integer info;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, dlam, info = NumRu::Lapack.slaed4( i, d, z, rho)\n or\n NumRu::Lapack.slaed4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th updated eigenvalue of a symmetric\n* rank-one modification to a diagonal matrix whose elements are\n* given in the array d, and that\n*\n* D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) REAL array, dimension (N)\n* The original eigenvalues. It is assumed that they are in\n* order, D(I) < D(J) for I < J.\n*\n* Z (input) REAL array, dimension (N)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (N)\n* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5\n* for detail. The vector DELTA contains the information necessary\n* to construct the eigenvectors by SLAED3 and SLAED9.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) REAL\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = n;
- rb_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, real*);
-
- slaed4_(&n, &i, d, z, delta, &rho, &dlam, &info);
-
- rb_dlam = rb_float_new((double)dlam);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_delta, rb_dlam, rb_info);
-}
-
-void
-init_lapack_slaed4(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed4", rb_slaed4, -1);
-}
diff --git a/slaed5.c b/slaed5.c
deleted file mode 100644
index 2e257cb..0000000
--- a/slaed5.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed5_(integer *i, real *d, real *z, real *delta, real *rho, real *dlam);
-
-static VALUE
-rb_slaed5(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- real *d;
- VALUE rb_z;
- real *z;
- VALUE rb_rho;
- real rho;
- VALUE rb_delta;
- real *delta;
- VALUE rb_dlam;
- real dlam;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, dlam = NumRu::Lapack.slaed5( i, d, z, rho)\n or\n NumRu::Lapack.slaed5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n* Purpose\n* =======\n*\n* This subroutine computes the I-th eigenvalue of a symmetric rank-one\n* modification of a 2-by-2 diagonal matrix\n*\n* diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal elements in the array D are assumed to satisfy\n*\n* D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) REAL array, dimension (2)\n* The original eigenvalues. We assume D(1) < D(2).\n*\n* Z (input) REAL array, dimension (2)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (2)\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* DLAM (output) REAL\n* The computed lambda_I, the I-th updated eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = 2;
- rb_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, real*);
-
- slaed5_(&i, d, z, delta, &rho, &dlam);
-
- rb_dlam = rb_float_new((double)dlam);
- return rb_ary_new3(2, rb_delta, rb_dlam);
-}
-
-void
-init_lapack_slaed5(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed5", rb_slaed5, -1);
-}
diff --git a/slaed6.c b/slaed6.c
deleted file mode 100644
index 0447a55..0000000
--- a/slaed6.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed6_(integer *kniter, logical *orgati, real *rho, real *d, real *z, real *finit, real *tau, integer *info);
-
-static VALUE
-rb_slaed6(int argc, VALUE *argv, VALUE self){
- VALUE rb_kniter;
- integer kniter;
- VALUE rb_orgati;
- logical orgati;
- VALUE rb_rho;
- real rho;
- VALUE rb_d;
- real *d;
- VALUE rb_z;
- real *z;
- VALUE rb_finit;
- real finit;
- VALUE rb_tau;
- real tau;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info = NumRu::Lapack.slaed6( kniter, orgati, rho, d, z, finit)\n or\n NumRu::Lapack.slaed6 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n* Purpose\n* =======\n*\n* SLAED6 computes the positive or negative root (closest to the origin)\n* of\n* z(1) z(2) z(3)\n* f(x) = rho + --------- + ---------- + ---------\n* d(1)-x d(2)-x d(3)-x\n*\n* It is assumed that\n*\n* if ORGATI = .true. the root is between d(2) and d(3);\n* otherwise it is between d(1) and d(2)\n*\n* This routine will be called by SLAED4 when necessary. In most cases,\n* the root sought is the smallest in magnitude, though it might not be\n* in some extremely rare situations.\n*\n\n* Arguments\n* =========\n*\n* KNITER (input) INTEGER\n* Refer to SLAED4 for its significance.\n*\n* ORGATI (input) LOGICAL\n* If ORGATI is true, the needed root is between d(2) and\n* d(3); otherwise it is between d(1) and d(2). See\n* SLAED4 for further details.\n*\n* RHO (input) REAL \n* Refer to the equation f(x) above.\n*\n* D (input) REAL array, dimension (3)\n* D satisfies d(1) < d(2) < d(3).\n*\n* Z (input) REAL array, dimension (3)\n* Each of the elements in z must be positive.\n*\n* FINIT (input) REAL \n* The value of f at 0. It is more accurate than the one\n* evaluated inside this routine (if someone wants to do\n* so).\n*\n* TAU (output) REAL \n* The root of the equation f(x).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, failure to converge\n*\n\n* Further Details\n* ===============\n*\n* 30/06/99: Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* 10/02/03: This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). SJH.\n*\n* 05/10/06: Modified from a new version of Ren-Cang Li, use\n* Gragg-Thornton-Warner cubic convergent scheme for better stability.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_kniter = argv[0];
- rb_orgati = argv[1];
- rb_rho = argv[2];
- rb_d = argv[3];
- rb_z = argv[4];
- rb_finit = argv[5];
-
- orgati = (rb_orgati == Qtrue);
- finit = (real)NUM2DBL(rb_finit);
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (5th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 3);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 3);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- kniter = NUM2INT(rb_kniter);
-
- slaed6_(&kniter, &orgati, &rho, d, z, &finit, &tau, &info);
-
- rb_tau = rb_float_new((double)tau);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_tau, rb_info);
-}
-
-void
-init_lapack_slaed6(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed6", rb_slaed6, -1);
-}
diff --git a/slaed7.c b/slaed7.c
deleted file mode 100644
index 3642869..0000000
--- a/slaed7.c
+++ /dev/null
@@ -1,229 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed7_(integer *icompq, integer *n, integer *qsiz, integer *tlvls, integer *curlvl, integer *curpbm, real *d, real *q, integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *qstore, integer *qptr, integer *prmptr, integer *perm, integer *givptr, integer *givcol, real *givnum, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slaed7(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_tlvls;
- integer tlvls;
- VALUE rb_curlvl;
- integer curlvl;
- VALUE rb_curpbm;
- integer curpbm;
- VALUE rb_d;
- real *d;
- VALUE rb_q;
- real *q;
- VALUE rb_rho;
- real rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_qstore;
- real *qstore;
- VALUE rb_qptr;
- integer *qptr;
- VALUE rb_prmptr;
- integer *prmptr;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_qstore_out__;
- real *qstore_out__;
- VALUE rb_qptr_out__;
- integer *qptr_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.slaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum)\n or\n NumRu::Lapack.slaed7 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense symmetric matrix\n* that has been reduced to tridiagonal form. SLAED1 handles\n* the case in which all eigenvalues and eigenvectors of a symmetric\n* tridiagonal matrix are desired.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLAED8.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine SLAED4 (as called by SLAED9).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= CURLVL <= TLVLS.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) REAL array, dimension (LDQ, N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* The permutation which will reintegrate the subproblem just\n* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n* will be in ascending order.\n*\n* RHO (input) REAL\n* The subdiagonal element used to create the rank-1\n* modification.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSTORE (input/output) REAL array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) REAL array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* WORK (workspace) REAL array, dimension (3*N+QSIZ*N)\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 16)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
- rb_icompq = argv[0];
- rb_qsiz = argv[1];
- rb_tlvls = argv[2];
- rb_curlvl = argv[3];
- rb_curpbm = argv[4];
- rb_d = argv[5];
- rb_q = argv[6];
- rb_rho = argv[7];
- rb_cutpnt = argv[8];
- rb_qstore = argv[9];
- rb_qptr = argv[10];
- rb_prmptr = argv[11];
- rb_perm = argv[12];
- rb_givptr = argv[13];
- rb_givcol = argv[14];
- rb_givnum = argv[15];
-
- qsiz = NUM2INT(rb_qsiz);
- cutpnt = NUM2INT(rb_cutpnt);
- tlvls = NUM2INT(rb_tlvls);
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- curlvl = NUM2INT(rb_curlvl);
- icompq = NUM2INT(rb_icompq);
- curpbm = NUM2INT(rb_curpbm);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (13th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_perm) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_prmptr))
- rb_raise(rb_eArgError, "prmptr (12th argument) must be NArray");
- if (NA_RANK(rb_prmptr) != 1)
- rb_raise(rb_eArgError, "rank of prmptr (12th argument) must be %d", 1);
- if (NA_SHAPE0(rb_prmptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
- if (NA_TYPE(rb_prmptr) != NA_LINT)
- rb_prmptr = na_change_type(rb_prmptr, NA_LINT);
- prmptr = NA_PTR_TYPE(rb_prmptr, integer*);
- if (!NA_IsNArray(rb_qstore))
- rb_raise(rb_eArgError, "qstore (10th argument) must be NArray");
- if (NA_RANK(rb_qstore) != 1)
- rb_raise(rb_eArgError, "rank of qstore (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qstore) != (pow(n,2)+1))
- rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
- if (NA_TYPE(rb_qstore) != NA_SFLOAT)
- rb_qstore = na_change_type(rb_qstore, NA_SFLOAT);
- qstore = NA_PTR_TYPE(rb_qstore, real*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (14th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (15th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (15th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (16th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (16th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
- if (NA_TYPE(rb_givnum) != NA_SFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_SFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- if (!NA_IsNArray(rb_qptr))
- rb_raise(rb_eArgError, "qptr (11th argument) must be NArray");
- if (NA_RANK(rb_qptr) != 1)
- rb_raise(rb_eArgError, "rank of qptr (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qptr) != (n+2))
- rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
- if (NA_TYPE(rb_qptr) != NA_LINT)
- rb_qptr = na_change_type(rb_qptr, NA_LINT);
- qptr = NA_PTR_TYPE(rb_qptr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = pow(n,2)+1;
- rb_qstore_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- qstore_out__ = NA_PTR_TYPE(rb_qstore_out__, real*);
- MEMCPY(qstore_out__, qstore, real, NA_TOTAL(rb_qstore));
- rb_qstore = rb_qstore_out__;
- qstore = qstore_out__;
- {
- int shape[1];
- shape[0] = n+2;
- rb_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- qptr_out__ = NA_PTR_TYPE(rb_qptr_out__, integer*);
- MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rb_qptr));
- rb_qptr = rb_qptr_out__;
- qptr = qptr_out__;
- work = ALLOC_N(real, (3*n+qsiz*n));
- iwork = ALLOC_N(integer, (4*n));
-
- slaed7_(&icompq, &n, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, indxq, &rho, &cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_indxq, rb_info, rb_d, rb_q, rb_qstore, rb_qptr);
-}
-
-void
-init_lapack_slaed7(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed7", rb_slaed7, -1);
-}
diff --git a/slaed8.c b/slaed8.c
deleted file mode 100644
index b6d5614..0000000
--- a/slaed8.c
+++ /dev/null
@@ -1,189 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed8_(integer *icompq, integer *k, integer *n, integer *qsiz, real *d, real *q, integer *ldq, integer *indxq, real *rho, integer *cutpnt, real *z, real *dlamda, real *q2, integer *ldq2, real *w, integer *perm, integer *givptr, integer *givcol, real *givnum, integer *indxp, integer *indx, integer *info);
-
-static VALUE
-rb_slaed8(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_d;
- real *d;
- VALUE rb_q;
- real *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_rho;
- real rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_z;
- real *z;
- VALUE rb_ldq2;
- integer ldq2;
- VALUE rb_k;
- integer k;
- VALUE rb_dlamda;
- real *dlamda;
- VALUE rb_q2;
- real *q2;
- VALUE rb_w;
- real *w;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_q_out__;
- real *q_out__;
- integer *indxp;
- integer *indx;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.slaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, ldq2)\n or\n NumRu::Lapack.slaed8 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n* Purpose\n* =======\n*\n* SLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* = 0: Compute eigenvalues only.\n* = 1: Compute eigenvectors of original dense symmetric matrix\n* also. On entry, Q contains the orthogonal matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* K (output) INTEGER\n* The number of non-deflated eigenvalues, and the order of the\n* related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the orthogonal matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the eigenvalues of the two submatrices to be\n* combined. On exit, the trailing (N-K) updated eigenvalues\n* (those which were deflated) sorted into increasing order.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* If ICOMPQ = 0, Q is not referenced. Otherwise,\n* on entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* The permutation which separately sorts the two sub-problems\n* in D into ascending order. Note that elements in the second\n* half of this permutation must first have CUTPNT added to\n* their values in order to be accurate.\n*\n* RHO (input/output) REAL\n* On entry, the off-diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined.\n* On exit, RHO has been modified to the value required by\n* SLAED3.\n*\n* CUTPNT (input) INTEGER\n* The location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* Z (input) REAL array, dimension (N)\n* On entry, Z contains the updating vector (the last row of\n* the first sub-eigenvector matrix and the first row of the\n* second sub-eigenvector matrix).\n* On exit, the contents of Z are destroyed by the updating\n* process.\n*\n* DLAMDA (output) REAL array, dimension (N)\n* A copy of the first K eigenvalues which will be used by\n* SLAED3 to form the secular equation.\n*\n* Q2 (output) REAL array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* a copy of the first K eigenvectors which will be used by\n* SLAED7 in a matrix multiply (SGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* The first k values of the final deflation-altered z-vector and\n* will be passed to SLAED3.\n*\n* PERM (output) INTEGER array, dimension (N)\n* The permutations (from deflation and sorting) to be applied\n* to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) REAL array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* The permutation used to place deflated values of D at the end\n* of the array. INDXP(1:K) points to the nondeflated D-values\n* and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* The permutation used to sort the contents of D into ascending\n* order.\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* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_icompq = argv[0];
- rb_qsiz = argv[1];
- rb_d = argv[2];
- rb_q = argv[3];
- rb_ldq = argv[4];
- rb_indxq = argv[5];
- rb_rho = argv[6];
- rb_cutpnt = argv[7];
- rb_z = argv[8];
- rb_ldq2 = argv[9];
-
- qsiz = NUM2INT(rb_qsiz);
- cutpnt = NUM2INT(rb_cutpnt);
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (6th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- rho = (real)NUM2DBL(rb_rho);
- ldq = NUM2INT(rb_ldq);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (4th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != (icompq==0 ? 0 : n))
- rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", icompq==0 ? 0 : n);
- if (NA_SHAPE0(rb_q) != (icompq==0 ? 0 : ldq))
- rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", icompq==0 ? 0 : ldq);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- ldq2 = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dlamda = NA_PTR_TYPE(rb_dlamda, real*);
- {
- int shape[2];
- shape[0] = icompq==0 ? 0 : ldq2;
- shape[1] = icompq==0 ? 0 : n;
- rb_q2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q2 = NA_PTR_TYPE(rb_q2, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = icompq==0 ? 0 : ldq;
- shape[1] = icompq==0 ? 0 : n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- indxp = ALLOC_N(integer, (n));
- indx = ALLOC_N(integer, (n));
-
- slaed8_(&icompq, &k, &n, &qsiz, d, q, &ldq, indxq, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, perm, &givptr, givcol, givnum, indxp, indx, &info);
-
- free(indxp);
- free(indx);
- rb_k = INT2NUM(k);
- rb_givptr = INT2NUM(givptr);
- rb_info = INT2NUM(info);
- rb_rho = rb_float_new((double)rho);
- return rb_ary_new3(12, rb_k, rb_dlamda, rb_q2, rb_w, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_info, rb_d, rb_q, rb_rho);
-}
-
-void
-init_lapack_slaed8(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed8", rb_slaed8, -1);
-}
diff --git a/slaed9.c b/slaed9.c
deleted file mode 100644
index 4110ad6..0000000
--- a/slaed9.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaed9_(integer *k, integer *kstart, integer *kstop, integer *n, real *d, real *q, integer *ldq, real *rho, real *dlamda, real *w, real *s, integer *lds, integer *info);
-
-static VALUE
-rb_slaed9(int argc, VALUE *argv, VALUE self){
- VALUE rb_kstart;
- integer kstart;
- VALUE rb_kstop;
- integer kstop;
- VALUE rb_n;
- integer n;
- VALUE rb_rho;
- real rho;
- VALUE rb_dlamda;
- real *dlamda;
- VALUE rb_w;
- real *w;
- VALUE rb_d;
- real *d;
- VALUE rb_s;
- real *s;
- VALUE rb_info;
- integer info;
- real *q;
-
- integer k;
- integer lds;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, s, info = NumRu::Lapack.slaed9( kstart, kstop, n, rho, dlamda, w)\n or\n NumRu::Lapack.slaed9 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n* Purpose\n* =======\n*\n* SLAED9 finds the roots of the secular equation, as defined by the\n* values in D, Z, and RHO, between KSTART and KSTOP. It makes the\n* appropriate calls to SLAED4 and then stores the new matrix of\n* eigenvectors for use in calculating the next level of Z vectors.\n*\n\n* Arguments\n* =========\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved by\n* SLAED4. K >= 0.\n*\n* KSTART (input) INTEGER\n* KSTOP (input) INTEGER\n* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n* are to be computed. 1 <= KSTART <= KSTOP <= K.\n*\n* N (input) INTEGER\n* The number of rows and columns in the Q matrix.\n* N >= K (delation may result in N > K).\n*\n* D (output) REAL array, dimension (N)\n* D(I) contains the updated eigenvalues\n* for KSTART <= I <= KSTOP.\n*\n* Q (workspace) REAL array, dimension (LDQ,N)\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* RHO (input) REAL\n* The value of the parameter in the rank one update equation.\n* RHO >= 0 required.\n*\n* DLAMDA (input) REAL array, dimension (K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* W (input) REAL array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating vector.\n*\n* S (output) REAL array, dimension (LDS, K)\n* Will contain the eigenvectors of the repaired matrix which\n* will be stored for subsequent Z vector calculation and\n* multiplied by the previously accumulated eigenvectors\n* to update the system.\n*\n* LDS (input) INTEGER\n* The leading dimension of S. LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n REAL TEMP\n* ..\n* .. External Functions ..\n REAL SLAMC3, SNRM2\n EXTERNAL SLAMC3, SNRM2\n* ..\n* .. External Subroutines ..\n EXTERNAL SCOPY, SLAED4, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, SIGN, SQRT\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_kstart = argv[0];
- rb_kstop = argv[1];
- rb_n = argv[2];
- rb_rho = argv[3];
- rb_dlamda = argv[4];
- rb_w = argv[5];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (6th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
- k = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- kstart = NUM2INT(rb_kstart);
- if (!NA_IsNArray(rb_dlamda))
- rb_raise(rb_eArgError, "dlamda (5th argument) must be NArray");
- if (NA_RANK(rb_dlamda) != 1)
- rb_raise(rb_eArgError, "rank of dlamda (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlamda) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of dlamda must be the same as shape 0 of w");
- if (NA_TYPE(rb_dlamda) != NA_SFLOAT)
- rb_dlamda = na_change_type(rb_dlamda, NA_SFLOAT);
- dlamda = NA_PTR_TYPE(rb_dlamda, real*);
- rho = (real)NUM2DBL(rb_rho);
- kstop = NUM2INT(rb_kstop);
- n = NUM2INT(rb_n);
- lds = MAX( 1, k );
- ldq = MAX( 1, n );
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[2];
- shape[0] = lds;
- shape[1] = k;
- rb_s = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- q = ALLOC_N(real, (ldq)*(MAX(1,n)));
-
- slaed9_(&k, &kstart, &kstop, &n, d, q, &ldq, &rho, dlamda, w, s, &lds, &info);
-
- free(q);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_d, rb_s, rb_info);
-}
-
-void
-init_lapack_slaed9(VALUE mLapack){
- rb_define_module_function(mLapack, "slaed9", rb_slaed9, -1);
-}
diff --git a/slaeda.c b/slaeda.c
deleted file mode 100644
index 6aa0291..0000000
--- a/slaeda.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaeda_(integer *n, integer *tlvls, integer *curlvl, integer *curpbm, integer *prmptr, integer *perm, integer *givptr, integer *givcol, real *givnum, real *q, integer *qptr, real *z, real *ztemp, integer *info);
-
-static VALUE
-rb_slaeda(int argc, VALUE *argv, VALUE self){
- VALUE rb_tlvls;
- integer tlvls;
- VALUE rb_curlvl;
- integer curlvl;
- VALUE rb_curpbm;
- integer curpbm;
- VALUE rb_prmptr;
- integer *prmptr;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_q;
- real *q;
- VALUE rb_qptr;
- integer *qptr;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- real *ztemp;
-
- integer ldqptr;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, info = NumRu::Lapack.slaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr)\n or\n NumRu::Lapack.slaeda # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n* Purpose\n* =======\n*\n* SLAEDA computes the Z vector corresponding to the merge step in the\n* CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n* problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and incidentally the\n* size of the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) REAL array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\n*\n* Q (input) REAL array, dimension (N**2)\n* Contains the square eigenblocks from previous levels, the\n* starting positions for blocks are given by QPTR.\n*\n* QPTR (input) INTEGER array, dimension (N+2)\n* Contains a list of pointers which indicate where in Q an\n* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates\n* the size of the block.\n*\n* Z (output) REAL array, dimension (N)\n* On output this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix).\n*\n* ZTEMP (workspace) REAL 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_tlvls = argv[0];
- rb_curlvl = argv[1];
- rb_curpbm = argv[2];
- rb_prmptr = argv[3];
- rb_perm = argv[4];
- rb_givptr = argv[5];
- rb_givcol = argv[6];
- rb_givnum = argv[7];
- rb_q = argv[8];
- rb_qptr = argv[9];
-
- curpbm = NUM2INT(rb_curpbm);
- if (!NA_IsNArray(rb_qptr))
- rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
- if (NA_RANK(rb_qptr) != 1)
- rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
- ldqptr = NA_SHAPE0(rb_qptr);
- if (NA_TYPE(rb_qptr) != NA_LINT)
- rb_qptr = na_change_type(rb_qptr, NA_LINT);
- qptr = NA_PTR_TYPE(rb_qptr, integer*);
- tlvls = NUM2INT(rb_tlvls);
- curlvl = NUM2INT(rb_curlvl);
- n = ldqptr-2;
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (5th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_perm) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_prmptr))
- rb_raise(rb_eArgError, "prmptr (4th argument) must be NArray");
- if (NA_RANK(rb_prmptr) != 1)
- rb_raise(rb_eArgError, "rank of prmptr (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_prmptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
- if (NA_TYPE(rb_prmptr) != NA_LINT)
- rb_prmptr = na_change_type(rb_prmptr, NA_LINT);
- prmptr = NA_PTR_TYPE(rb_prmptr, integer*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (6th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (9th argument) must be NArray");
- if (NA_RANK(rb_q) != 1)
- rb_raise(rb_eArgError, "rank of q (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_q) != (pow(n,2)))
- rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", pow(n,2));
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (7th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (8th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
- if (NA_TYPE(rb_givnum) != NA_SFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_SFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- ztemp = ALLOC_N(real, (n));
-
- slaeda_(&n, &tlvls, &curlvl, &curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, &info);
-
- free(ztemp);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_z, rb_info);
-}
-
-void
-init_lapack_slaeda(VALUE mLapack){
- rb_define_module_function(mLapack, "slaeda", rb_slaeda, -1);
-}
diff --git a/slaein.c b/slaein.c
deleted file mode 100644
index b0f709a..0000000
--- a/slaein.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaein_(logical *rightv, logical *noinit, integer *n, real *h, integer *ldh, real *wr, real *wi, real *vr, real *vi, real *b, integer *ldb, real *work, real *eps3, real *smlnum, real *bignum, integer *info);
-
-static VALUE
-rb_slaein(int argc, VALUE *argv, VALUE self){
- VALUE rb_rightv;
- logical rightv;
- VALUE rb_noinit;
- logical noinit;
- VALUE rb_h;
- real *h;
- VALUE rb_wr;
- real wr;
- VALUE rb_wi;
- real wi;
- VALUE rb_vr;
- real *vr;
- VALUE rb_vi;
- real *vi;
- VALUE rb_eps3;
- real eps3;
- VALUE rb_smlnum;
- real smlnum;
- VALUE rb_bignum;
- real bignum;
- VALUE rb_info;
- integer info;
- VALUE rb_vr_out__;
- real *vr_out__;
- VALUE rb_vi_out__;
- real *vi_out__;
- real *b;
- real *work;
-
- integer ldh;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, vr, vi = NumRu::Lapack.slaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum)\n or\n NumRu::Lapack.slaein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n* Purpose\n* =======\n*\n* SLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in (VR,VI).\n* = .FALSE.: initial vector supplied in (VR,VI).\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) REAL array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (input) REAL\n* WI (input) REAL\n* The real and imaginary parts of the eigenvalue of H whose\n* corresponding right or left eigenvector is to be computed.\n*\n* VR (input/output) REAL array, dimension (N)\n* VI (input/output) REAL array, dimension (N)\n* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n* a real starting vector for inverse iteration using the real\n* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n* must contain the real and imaginary parts of a complex\n* starting vector for inverse iteration using the complex\n* eigenvalue (WR,WI); otherwise VR and VI need not be set.\n* On exit, if WI = 0.0 (real eigenvalue), VR contains the\n* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n* VR and VI contain the real and imaginary parts of the\n* computed complex eigenvector. The eigenvector is normalized\n* so that the component of largest magnitude has magnitude 1;\n* here the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n* VI is not referenced if WI = 0.0.\n*\n* B (workspace) REAL array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= N+1.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* EPS3 (input) REAL\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) REAL\n* A machine-dependent value close to the underflow threshold.\n*\n* BIGNUM (input) REAL\n* A machine-dependent value close to the overflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; VR is set to the\n* last iterate, and so is VI if WI.ne.0.0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_rightv = argv[0];
- rb_noinit = argv[1];
- rb_h = argv[2];
- rb_wr = argv[3];
- rb_wi = argv[4];
- rb_vr = argv[5];
- rb_vi = argv[6];
- rb_eps3 = argv[7];
- rb_smlnum = argv[8];
- rb_bignum = argv[9];
-
- smlnum = (real)NUM2DBL(rb_smlnum);
- eps3 = (real)NUM2DBL(rb_eps3);
- wr = (real)NUM2DBL(rb_wr);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 1)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SFLOAT)
- rb_vr = na_change_type(rb_vr, NA_SFLOAT);
- vr = NA_PTR_TYPE(rb_vr, real*);
- rightv = (rb_rightv == Qtrue);
- noinit = (rb_noinit == Qtrue);
- bignum = (real)NUM2DBL(rb_bignum);
- if (!NA_IsNArray(rb_vi))
- rb_raise(rb_eArgError, "vi (7th argument) must be NArray");
- if (NA_RANK(rb_vi) != 1)
- rb_raise(rb_eArgError, "rank of vi (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vi) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vi must be the same as shape 0 of vr");
- if (NA_TYPE(rb_vi) != NA_SFLOAT)
- rb_vi = na_change_type(rb_vi, NA_SFLOAT);
- vi = NA_PTR_TYPE(rb_vi, real*);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (3th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of vr");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- wi = (real)NUM2DBL(rb_wi);
- ldb = n+1;
- {
- int shape[1];
- shape[0] = n;
- rb_vr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, real*);
- MEMCPY(vr_out__, vr, real, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vi_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vi_out__ = NA_PTR_TYPE(rb_vi_out__, real*);
- MEMCPY(vi_out__, vi, real, NA_TOTAL(rb_vi));
- rb_vi = rb_vi_out__;
- vi = vi_out__;
- b = ALLOC_N(real, (ldb)*(n));
- work = ALLOC_N(real, (n));
-
- slaein_(&rightv, &noinit, &n, h, &ldh, &wr, &wi, vr, vi, b, &ldb, work, &eps3, &smlnum, &bignum, &info);
-
- free(b);
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_vr, rb_vi);
-}
-
-void
-init_lapack_slaein(VALUE mLapack){
- rb_define_module_function(mLapack, "slaein", rb_slaein, -1);
-}
diff --git a/slaev2.c b/slaev2.c
deleted file mode 100644
index a875021..0000000
--- a/slaev2.c
+++ /dev/null
@@ -1,49 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaev2_(real *a, real *b, real *c, real *rt1, real *rt2, real *cs1, real *sn1);
-
-static VALUE
-rb_slaev2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real a;
- VALUE rb_b;
- real b;
- VALUE rb_c;
- real c;
- VALUE rb_rt1;
- real rt1;
- VALUE rb_rt2;
- real rt2;
- VALUE rb_cs1;
- real cs1;
- VALUE rb_sn1;
- real sn1;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.slaev2( a, b, c)\n or\n NumRu::Lapack.slaev2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n* [ A B ]\n* [ B C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) REAL\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) REAL\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) REAL\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) REAL\n* SN1 (output) REAL\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a = (real)NUM2DBL(rb_a);
- b = (real)NUM2DBL(rb_b);
- c = (real)NUM2DBL(rb_c);
-
- slaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
-
- rb_rt1 = rb_float_new((double)rt1);
- rb_rt2 = rb_float_new((double)rt2);
- rb_cs1 = rb_float_new((double)cs1);
- rb_sn1 = rb_float_new((double)sn1);
- return rb_ary_new3(4, rb_rt1, rb_rt2, rb_cs1, rb_sn1);
-}
-
-void
-init_lapack_slaev2(VALUE mLapack){
- rb_define_module_function(mLapack, "slaev2", rb_slaev2, -1);
-}
diff --git a/slaexc.c b/slaexc.c
deleted file mode 100644
index 3837896..0000000
--- a/slaexc.c
+++ /dev/null
@@ -1,99 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaexc_(logical *wantq, integer *n, real *t, integer *ldt, real *q, integer *ldq, integer *j1, integer *n1, integer *n2, real *work, integer *info);
-
-static VALUE
-rb_slaexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_t;
- real *t;
- VALUE rb_q;
- real *q;
- VALUE rb_j1;
- integer j1;
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- real *t_out__;
- VALUE rb_q_out__;
- real *q_out__;
- real *work;
-
- integer ldt;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.slaexc( wantq, t, q, j1, n1, n2)\n or\n NumRu::Lapack.slaexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n* an upper quasi-triangular matrix T by an orthogonal similarity\n* transformation.\n*\n* T must be in Schur canonical form, that is, block upper triangular\n* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n* has its diagonal elemnts equal and its off-diagonal elements of\n* opposite sign.\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* = .TRUE. : accumulate the transformation in the matrix Q;\n* = .FALSE.: do not accumulate the transformation.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) REAL array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, the updated matrix T, again in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n* On exit, if WANTQ is .TRUE., the updated matrix Q.\n* If WANTQ is .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n*\n* J1 (input) INTEGER\n* The index of the first row of the first block T11.\n*\n* N1 (input) INTEGER\n* The order of the first block T11. N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block T22. N2 = 0, 1 or 2.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: the transformed matrix T would be too far from Schur\n* form; the blocks are not swapped and T and Q are\n* unchanged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_wantq = argv[0];
- rb_t = argv[1];
- rb_q = argv[2];
- rb_j1 = argv[3];
- rb_n1 = argv[4];
- rb_n2 = argv[5];
-
- n1 = NUM2INT(rb_n1);
- wantq = (rb_wantq == Qtrue);
- n2 = NUM2INT(rb_n2);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- j1 = NUM2INT(rb_j1);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (2th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, real*);
- MEMCPY(t_out__, t, real, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(real, (n));
-
- slaexc_(&wantq, &n, t, &ldt, q, &ldq, &j1, &n1, &n2, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_slaexc(VALUE mLapack){
- rb_define_module_function(mLapack, "slaexc", rb_slaexc, -1);
-}
diff --git a/slag2.c b/slag2.c
deleted file mode 100644
index 64b910f..0000000
--- a/slag2.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slag2_(real *a, integer *lda, real *b, integer *ldb, real *safmin, real *scale1, real *scale2, real *wr1, real *wr2, real *wi);
-
-static VALUE
-rb_slag2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_safmin;
- real safmin;
- VALUE rb_scale1;
- real scale1;
- VALUE rb_scale2;
- real scale2;
- VALUE rb_wr1;
- real wr1;
- VALUE rb_wr2;
- real wr2;
- VALUE rb_wi;
- real wi;
-
- integer lda;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale1, scale2, wr1, wr2, wi = NumRu::Lapack.slag2( a, b, safmin)\n or\n NumRu::Lapack.slag2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n* Purpose\n* =======\n*\n* SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n* problem A - w B, with scaling as necessary to avoid over-/underflow.\n*\n* The scaling factor \"s\" results in a modified eigenvalue equation\n*\n* s A - w B\n*\n* where s is a non-negative scaling factor chosen so that w, w B,\n* and s A do not overflow and, if possible, do not underflow, either.\n*\n\n* Arguments\n* =========\n*\n* A (input) REAL array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm\n* is less than 1/SAFMIN. Entries less than\n* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= 2.\n*\n* B (input) REAL array, dimension (LDB, 2)\n* On entry, the 2 x 2 upper triangular matrix B. It is\n* assumed that the one-norm of B is less than 1/SAFMIN. The\n* diagonals should be at least sqrt(SAFMIN) times the largest\n* element of B (in absolute value); if a diagonal is smaller\n* than that, then +/- sqrt(SAFMIN) will be used instead of\n* that diagonal.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 2.\n*\n* SAFMIN (input) REAL\n* The smallest positive number s.t. 1/SAFMIN does not\n* overflow. (This should always be SLAMCH('S') -- it is an\n* argument in order to avoid having to call SLAMCH frequently.)\n*\n* SCALE1 (output) REAL\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the first eigenvalue. If\n* the eigenvalues are complex, then the eigenvalues are\n* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the\n* exponent range of the machine), SCALE1=SCALE2, and SCALE1\n* will always be positive. If the eigenvalues are real, then\n* the first (real) eigenvalue is WR1 / SCALE1 , but this may\n* overflow or underflow, and in fact, SCALE1 may be zero or\n* less than the underflow threshhold if the exact eigenvalue\n* is sufficiently large.\n*\n* SCALE2 (output) REAL\n* A scaling factor used to avoid over-/underflow in the\n* eigenvalue equation which defines the second eigenvalue. If\n* the eigenvalues are complex, then SCALE2=SCALE1. If the\n* eigenvalues are real, then the second (real) eigenvalue is\n* WR2 / SCALE2 , but this may overflow or underflow, and in\n* fact, SCALE2 may be zero or less than the underflow\n* threshhold if the exact eigenvalue is sufficiently large.\n*\n* WR1 (output) REAL\n* If the eigenvalue is real, then WR1 is SCALE1 times the\n* eigenvalue closest to the (2,2) element of A B**(-1). If the\n* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n* part of the eigenvalues.\n*\n* WR2 (output) REAL\n* If the eigenvalue is real, then WR2 is SCALE2 times the\n* other eigenvalue. If the eigenvalue is complex, then\n* WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n*\n* WI (output) REAL\n* If the eigenvalue is real, then WI is zero. If the\n* eigenvalue is complex, then WI is SCALE1 times the imaginary\n* part of the eigenvalues. WI will always be non-negative.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_safmin = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- safmin = (real)NUM2DBL(rb_safmin);
-
- slag2_(a, &lda, b, &ldb, &safmin, &scale1, &scale2, &wr1, &wr2, &wi);
-
- rb_scale1 = rb_float_new((double)scale1);
- rb_scale2 = rb_float_new((double)scale2);
- rb_wr1 = rb_float_new((double)wr1);
- rb_wr2 = rb_float_new((double)wr2);
- rb_wi = rb_float_new((double)wi);
- return rb_ary_new3(5, rb_scale1, rb_scale2, rb_wr1, rb_wr2, rb_wi);
-}
-
-void
-init_lapack_slag2(VALUE mLapack){
- rb_define_module_function(mLapack, "slag2", rb_slag2, -1);
-}
diff --git a/slag2d.c b/slag2d.c
deleted file mode 100644
index 9455e72..0000000
--- a/slag2d.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slag2d_(integer *m, integer *n, real *sa, integer *ldsa, doublereal *a, integer *lda, integer *info);
-
-static VALUE
-rb_slag2d(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_sa;
- real *sa;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_info;
- integer info;
-
- integer ldsa;
- integer n;
- integer lda;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.slag2d( m, sa)\n or\n NumRu::Lapack.slag2d # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE\n* PRECISION matrix, A.\n*\n* Note that while it is possible to overflow while converting\n* from double to single, it is not possible to overflow when\n* converting from single to double.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* SA (input) REAL array, dimension (LDSA,N)\n* On entry, the M-by-N coefficient matrix SA.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* A (output) DOUBLE PRECISION array, dimension (LDA,N)\n* On exit, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_sa = argv[1];
-
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_sa))
- rb_raise(rb_eArgError, "sa (2th argument) must be NArray");
- if (NA_RANK(rb_sa) != 2)
- rb_raise(rb_eArgError, "rank of sa (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_sa);
- ldsa = NA_SHAPE0(rb_sa);
- if (NA_TYPE(rb_sa) != NA_SFLOAT)
- rb_sa = na_change_type(rb_sa, NA_SFLOAT);
- sa = NA_PTR_TYPE(rb_sa, real*);
- lda = MAX(1,m);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, doublereal*);
-
- slag2d_(&m, &n, sa, &ldsa, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_slag2d(VALUE mLapack){
- rb_define_module_function(mLapack, "slag2d", rb_slag2d, -1);
-}
diff --git a/slags2.c b/slags2.c
deleted file mode 100644
index 2134731..0000000
--- a/slags2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slags2_(logical *upper, real *a1, real *a2, real *a3, real *b1, real *b2, real *b3, real *csu, real *snu, real *csv, real *snv, real *csq, real *snq);
-
-static VALUE
-rb_slags2(int argc, VALUE *argv, VALUE self){
- VALUE rb_upper;
- logical upper;
- VALUE rb_a1;
- real a1;
- VALUE rb_a2;
- real a2;
- VALUE rb_a3;
- real a3;
- VALUE rb_b1;
- real b1;
- VALUE rb_b2;
- real b2;
- VALUE rb_b3;
- real b3;
- VALUE rb_csu;
- real csu;
- VALUE rb_snu;
- real snu;
- VALUE rb_csv;
- real csv;
- VALUE rb_snv;
- real snv;
- VALUE rb_csq;
- real csq;
- VALUE rb_snq;
- real snq;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.slags2( upper, a1, a2, a3, b1, b2, b3)\n or\n NumRu::Lapack.slags2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n*\n* The rows of the transformed A and B are parallel, where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )\n* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )\n*\n* Z' denotes the transpose of Z.\n*\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) REAL\n* A2 (input) REAL\n* A3 (input) REAL\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) REAL\n* B2 (input) REAL\n* B3 (input) REAL\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) REAL\n* SNU (output) REAL\n* The desired orthogonal matrix U.\n*\n* CSV (output) REAL\n* SNV (output) REAL\n* The desired orthogonal matrix V.\n*\n* CSQ (output) REAL\n* SNQ (output) REAL\n* The desired orthogonal matrix Q.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_upper = argv[0];
- rb_a1 = argv[1];
- rb_a2 = argv[2];
- rb_a3 = argv[3];
- rb_b1 = argv[4];
- rb_b2 = argv[5];
- rb_b3 = argv[6];
-
- b1 = (real)NUM2DBL(rb_b1);
- upper = (rb_upper == Qtrue);
- b2 = (real)NUM2DBL(rb_b2);
- a1 = (real)NUM2DBL(rb_a1);
- b3 = (real)NUM2DBL(rb_b3);
- a2 = (real)NUM2DBL(rb_a2);
- a3 = (real)NUM2DBL(rb_a3);
-
- slags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
-
- rb_csu = rb_float_new((double)csu);
- rb_snu = rb_float_new((double)snu);
- rb_csv = rb_float_new((double)csv);
- rb_snv = rb_float_new((double)snv);
- rb_csq = rb_float_new((double)csq);
- rb_snq = rb_float_new((double)snq);
- return rb_ary_new3(6, rb_csu, rb_snu, rb_csv, rb_snv, rb_csq, rb_snq);
-}
-
-void
-init_lapack_slags2(VALUE mLapack){
- rb_define_module_function(mLapack, "slags2", rb_slags2, -1);
-}
diff --git a/slagtf.c b/slagtf.c
deleted file mode 100644
index e779825..0000000
--- a/slagtf.c
+++ /dev/null
@@ -1,121 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slagtf_(integer *n, real *a, real *lambda, real *b, real *c, real *tol, real *d, integer *in, integer *info);
-
-static VALUE
-rb_slagtf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_lambda;
- real lambda;
- VALUE rb_b;
- real *b;
- VALUE rb_c;
- real *c;
- VALUE rb_tol;
- real tol;
- VALUE rb_d;
- real *d;
- VALUE rb_in;
- integer *in;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, in, info, a, b, c = NumRu::Lapack.slagtf( a, lambda, b, c, tol)\n or\n NumRu::Lapack.slagtf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n* Purpose\n* =======\n*\n* SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n* tridiagonal matrix and lambda is a scalar, as\n*\n* T - lambda*I = PLU,\n*\n* where P is a permutation matrix, L is a unit lower tridiagonal matrix\n* with at most one non-zero sub-diagonal elements per column and U is\n* an upper triangular matrix with at most two non-zero super-diagonal\n* elements per column.\n*\n* The factorization is obtained by Gaussian elimination with partial\n* pivoting and implicit row scaling.\n*\n* The parameter LAMBDA is included in the routine so that SLAGTF may\n* be used, in conjunction with SLAGTS, to obtain eigenvectors of T by\n* inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input/output) REAL array, dimension (N)\n* On entry, A must contain the diagonal elements of T.\n*\n* On exit, A is overwritten by the n diagonal elements of the\n* upper triangular matrix U of the factorization of T.\n*\n* LAMBDA (input) REAL\n* On entry, the scalar lambda.\n*\n* B (input/output) REAL array, dimension (N-1)\n* On entry, B must contain the (n-1) super-diagonal elements of\n* T.\n*\n* On exit, B is overwritten by the (n-1) super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* C (input/output) REAL array, dimension (N-1)\n* On entry, C must contain the (n-1) sub-diagonal elements of\n* T.\n*\n* On exit, C is overwritten by the (n-1) sub-diagonal elements\n* of the matrix L of the factorization of T.\n*\n* TOL (input) REAL\n* On entry, a relative tolerance used to indicate whether or\n* not the matrix (T - lambda*I) is nearly singular. TOL should\n* normally be chose as approximately the largest relative error\n* in the elements of T. For example, if the elements of T are\n* correct to about 4 significant figures, then TOL should be\n* set to about 5*10**(-4). If TOL is supplied as less than eps,\n* where eps is the relative machine precision, then the value\n* eps is used in place of TOL.\n*\n* D (output) REAL array, dimension (N-2)\n* On exit, D is overwritten by the (n-2) second super-diagonal\n* elements of the matrix U of the factorization of T.\n*\n* IN (output) INTEGER array, dimension (N)\n* On exit, IN contains details of the permutation matrix P. If\n* an interchange occurred at the kth step of the elimination,\n* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n* returns the smallest positive integer j such that\n*\n* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n*\n* where norm( A(j) ) denotes the sum of the absolute values of\n* the jth row of the matrix A. If no such j exists then IN(n)\n* is returned as zero. If IN(n) is returned as positive, then a\n* diagonal element of U is small, indicating that\n* (T - lambda*I) is singular or nearly singular,\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -k, the kth argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_lambda = argv[1];
- rb_b = argv[2];
- rb_c = argv[3];
- rb_tol = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- tol = (real)NUM2DBL(rb_tol);
- lambda = (real)NUM2DBL(rb_lambda);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 1)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_b) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- {
- int shape[1];
- shape[0] = n-2;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_in = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- in = NA_PTR_TYPE(rb_in, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_b_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- slagtf_(&n, a, &lambda, b, c, &tol, d, in, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_in, rb_info, rb_a, rb_b, rb_c);
-}
-
-void
-init_lapack_slagtf(VALUE mLapack){
- rb_define_module_function(mLapack, "slagtf", rb_slagtf, -1);
-}
diff --git a/slagtm.c b/slagtm.c
deleted file mode 100644
index c243fa4..0000000
--- a/slagtm.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slagtm_(char *trans, integer *n, integer *nrhs, real *alpha, real *dl, real *d, real *du, real *x, integer *ldx, real *beta, real *b, integer *ldb);
-
-static VALUE
-rb_slagtm(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb_x;
- real *x;
- VALUE rb_beta;
- real beta;
- VALUE rb_b;
- real *b;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldx;
- integer nrhs;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.slagtm( trans, alpha, dl, d, du, x, beta, b)\n or\n NumRu::Lapack.slagtm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* SLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A'* X + beta * B\n* = 'C': 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 matrices X and B.\n*\n* ALPHA (input) REAL\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) REAL array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) REAL array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) REAL array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) REAL\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_alpha = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_x = argv[5];
- rb_beta = argv[6];
- rb_b = argv[7];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- beta = (real)NUM2DBL(rb_beta);
- alpha = (real)NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- slagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_slagtm(VALUE mLapack){
- rb_define_module_function(mLapack, "slagtm", rb_slagtm, -1);
-}
diff --git a/slagts.c b/slagts.c
deleted file mode 100644
index 83323ba..0000000
--- a/slagts.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slagts_(integer *job, integer *n, real *a, real *b, real *c, real *d, integer *in, real *y, real *tol, integer *info);
-
-static VALUE
-rb_slagts(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- integer job;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_c;
- real *c;
- VALUE rb_d;
- real *d;
- VALUE rb_in;
- integer *in;
- VALUE rb_y;
- real *y;
- VALUE rb_tol;
- real tol;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- real *y_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, y, tol = NumRu::Lapack.slagts( job, a, b, c, d, in, y, tol)\n or\n NumRu::Lapack.slagts # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n* Purpose\n* =======\n*\n* SLAGTS may be used to solve one of the systems of equations\n*\n* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,\n*\n* where T is an n by n tridiagonal matrix, for x, following the\n* factorization of (T - lambda*I) as\n*\n* (T - lambda*I) = P*L*U ,\n*\n* by routine SLAGTF. The choice of equation to be solved is\n* controlled by the argument JOB, and in each case there is an option\n* to perturb zero or very small diagonal elements of U, this option\n* being intended for use in applications such as inverse iteration.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* Specifies the job to be performed by SLAGTS as follows:\n* = 1: The equations (T - lambda*I)x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -1: The equations (T - lambda*I)x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n* = 2: The equations (T - lambda*I)'x = y are to be solved,\n* but diagonal elements of U are not to be perturbed.\n* = -2: The equations (T - lambda*I)'x = y are to be solved\n* and, if overflow would otherwise occur, the diagonal\n* elements of U are to be perturbed. See argument TOL\n* below.\n*\n* N (input) INTEGER\n* The order of the matrix T.\n*\n* A (input) REAL array, dimension (N)\n* On entry, A must contain the diagonal elements of U as\n* returned from SLAGTF.\n*\n* B (input) REAL array, dimension (N-1)\n* On entry, B must contain the first super-diagonal elements of\n* U as returned from SLAGTF.\n*\n* C (input) REAL array, dimension (N-1)\n* On entry, C must contain the sub-diagonal elements of L as\n* returned from SLAGTF.\n*\n* D (input) REAL array, dimension (N-2)\n* On entry, D must contain the second super-diagonal elements\n* of U as returned from SLAGTF.\n*\n* IN (input) INTEGER array, dimension (N)\n* On entry, IN must contain details of the matrix P as returned\n* from SLAGTF.\n*\n* Y (input/output) REAL array, dimension (N)\n* On entry, the right hand side vector y.\n* On exit, Y is overwritten by the solution vector x.\n*\n* TOL (input/output) REAL\n* On entry, with JOB .lt. 0, TOL should be the minimum\n* perturbation to be made to very small diagonal elements of U.\n* TOL should normally be chosen as about eps*norm(U), where eps\n* is the relative machine precision, but if TOL is supplied as\n* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n* If JOB .gt. 0 then TOL is not referenced.\n*\n* On exit, TOL is changed as described above, only if TOL is\n* non-positive on entry. Otherwise TOL is unchanged.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* .lt. 0: if INFO = -i, the i-th argument had an illegal value\n* .gt. 0: overflow would occur when computing the INFO(th)\n* element of the solution vector x. This can only occur\n* when JOB is supplied as positive and either means\n* that a diagonal element of U is very small, or that\n* the elements of the right-hand side vector y are very\n* large.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_c = argv[3];
- rb_d = argv[4];
- rb_in = argv[5];
- rb_y = argv[6];
- rb_tol = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- tol = (real)NUM2DBL(rb_tol);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of a");
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_in))
- rb_raise(rb_eArgError, "in (6th argument) must be NArray");
- if (NA_RANK(rb_in) != 1)
- rb_raise(rb_eArgError, "rank of in (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_in) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of in must be the same as shape 0 of a");
- if (NA_TYPE(rb_in) != NA_LINT)
- rb_in = na_change_type(rb_in, NA_LINT);
- in = NA_PTR_TYPE(rb_in, integer*);
- job = NUM2INT(rb_job);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 1)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_b) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", n-2);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- slagts_(&job, &n, a, b, c, d, in, y, &tol, &info);
-
- rb_info = INT2NUM(info);
- rb_tol = rb_float_new((double)tol);
- return rb_ary_new3(3, rb_info, rb_y, rb_tol);
-}
-
-void
-init_lapack_slagts(VALUE mLapack){
- rb_define_module_function(mLapack, "slagts", rb_slagts, -1);
-}
diff --git a/slagv2.c b/slagv2.c
deleted file mode 100644
index 5b83bbe..0000000
--- a/slagv2.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slagv2_(real *a, integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real *beta, real *csl, real *snl, real *csr, real *snr);
-
-static VALUE
-rb_slagv2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_csl;
- real csl;
- VALUE rb_snl;
- real snl;
- VALUE rb_csr;
- real csr;
- VALUE rb_snr;
- real snr;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.slagv2( a, b)\n or\n NumRu::Lapack.slagv2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n* Purpose\n* =======\n*\n* SLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n* matrix pencil (A,B) where B is upper triangular. This routine\n* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n* SNR such that\n*\n* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n* types), then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],\n*\n* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n* then\n*\n* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n*\n* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]\n*\n* where b11 >= b22 > 0.\n*\n*\n\n* Arguments\n* =========\n*\n* A (input/output) REAL array, dimension (LDA, 2)\n* On entry, the 2 x 2 matrix A.\n* On exit, A is overwritten by the ``A-part'' of the\n* generalized Schur form.\n*\n* LDA (input) INTEGER\n* THe leading dimension of the array A. LDA >= 2.\n*\n* B (input/output) REAL array, dimension (LDB, 2)\n* On entry, the upper triangular 2 x 2 matrix B.\n* On exit, B is overwritten by the ``B-part'' of the\n* generalized Schur form.\n*\n* LDB (input) INTEGER\n* THe leading dimension of the array B. LDB >= 2.\n*\n* ALPHAR (output) REAL array, dimension (2)\n* ALPHAI (output) REAL array, dimension (2)\n* BETA (output) REAL array, dimension (2)\n* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may\n* be zero.\n*\n* CSL (output) REAL\n* The cosine of the left rotation matrix.\n*\n* SNL (output) REAL\n* The sine of the left rotation matrix.\n*\n* CSR (output) REAL\n* The cosine of the right rotation matrix.\n*\n* SNR (output) REAL\n* The sine of the right rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = 2;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = 2;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- slagv2_(a, &lda, b, &ldb, alphar, alphai, beta, &csl, &snl, &csr, &snr);
-
- rb_csl = rb_float_new((double)csl);
- rb_snl = rb_float_new((double)snl);
- rb_csr = rb_float_new((double)csr);
- rb_snr = rb_float_new((double)snr);
- return rb_ary_new3(9, rb_alphar, rb_alphai, rb_beta, rb_csl, rb_snl, rb_csr, rb_snr, rb_a, rb_b);
-}
-
-void
-init_lapack_slagv2(VALUE mLapack){
- rb_define_module_function(mLapack, "slagv2", rb_slagv2, -1);
-}
diff --git a/slahqr.c b/slahqr.c
deleted file mode 100644
index 58a72e7..0000000
--- a/slahqr.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slahqr_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, real *h, integer *ldh, real *wr, real *wi, integer *iloz, integer *ihiz, real *z, integer *ldz, integer *info);
-
-static VALUE
-rb_slahqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- real *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- real *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, info, h, z = NumRu::Lapack.slahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz)\n or\n NumRu::Lapack.slahqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* SLAHQR is an auxiliary routine called by SHSEQR to update the\n* eigenvalues and Schur decomposition already computed by SHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper quasi-triangular in\n* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n* ILO = 1). SLAHQR works primarily with the Hessenberg\n* submatrix in rows and columns ILO to IHI, but applies\n* transformations to all of H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n* quasi-triangular in rows and columns ILO:IHI, with any\n* 2-by-2 diagonal blocks in standard form. If INFO is zero\n* and WANTT is .FALSE., the contents of H are unspecified on\n* exit. The output state of H if INFO is nonzero is given\n* below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues ILO to IHI are stored in the corresponding\n* elements of WR and WI. If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with WR(i) = H(i,i), and, if\n* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by SHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: If INFO = i, SLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of WR and WI\n* contain those eigenvalues which have been\n* successfully computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix rows\n* and columns ILO thorugh INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of SLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_iloz = argv[5];
- rb_ihiz = argv[6];
- rb_z = argv[7];
- rb_ldz = argv[8];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- ldz = NUM2INT(rb_ldz);
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? n : 0;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- slahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_wr, rb_wi, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_slahqr(VALUE mLapack){
- rb_define_module_function(mLapack, "slahqr", rb_slahqr, -1);
-}
diff --git a/slahr2.c b/slahr2.c
deleted file mode 100644
index bcf9654..0000000
--- a/slahr2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slahr2_(integer *n, integer *k, integer *nb, real *a, integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy);
-
-static VALUE
-rb_slahr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_t;
- real *t;
- VALUE rb_y;
- real *y;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.slahr2( n, k, nb, a)\n or\n NumRu::Lapack.slahr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by SGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) REAL array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) REAL array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) REAL array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ldt = nb;
- ldy = n;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_slahr2(VALUE mLapack){
- rb_define_module_function(mLapack, "slahr2", rb_slahr2, -1);
-}
diff --git a/slahrd.c b/slahrd.c
deleted file mode 100644
index ef6b795..0000000
--- a/slahrd.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slahrd_(integer *n, integer *k, integer *nb, real *a, integer *lda, real *tau, real *t, integer *ldt, real *y, integer *ldy);
-
-static VALUE
-rb_slahrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_t;
- real *t;
- VALUE rb_y;
- real *y;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.slahrd( n, k, nb, a)\n or\n NumRu::Lapack.slahrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* SLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an orthogonal similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine SLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) REAL array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) REAL array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) REAL array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) REAL array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ldt = nb;
- ldy = n;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, real*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_slahrd(VALUE mLapack){
- rb_define_module_function(mLapack, "slahrd", rb_slahrd, -1);
-}
diff --git a/slaic1.c b/slaic1.c
deleted file mode 100644
index 5cbaf39..0000000
--- a/slaic1.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaic1_(integer *job, integer *j, real *x, real *sest, real *w, real *gamma, real *sestpr, real *s, real *c);
-
-static VALUE
-rb_slaic1(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- integer job;
- VALUE rb_x;
- real *x;
- VALUE rb_sest;
- real sest;
- VALUE rb_w;
- real *w;
- VALUE rb_gamma;
- real gamma;
- VALUE rb_sestpr;
- real sestpr;
- VALUE rb_s;
- real s;
- VALUE rb_c;
- real c;
-
- integer j;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.slaic1( job, x, sest, w, gamma)\n or\n NumRu::Lapack.slaic1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* SLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then SLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]\n* [ gamma ]\n*\n* where alpha = x'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) REAL array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) REAL\n* Estimated singular value of j by j matrix L\n*\n* W (input) REAL array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) REAL\n* The diagonal element gamma.\n*\n* SESTPR (output) REAL\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) REAL\n* Sine needed in forming xhat.\n*\n* C (output) REAL\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_job = argv[0];
- rb_x = argv[1];
- rb_sest = argv[2];
- rb_w = argv[3];
- rb_gamma = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (4th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
- j = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != j)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- gamma = (real)NUM2DBL(rb_gamma);
- job = NUM2INT(rb_job);
- sest = (real)NUM2DBL(rb_sest);
-
- slaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
-
- rb_sestpr = rb_float_new((double)sestpr);
- rb_s = rb_float_new((double)s);
- rb_c = rb_float_new((double)c);
- return rb_ary_new3(3, rb_sestpr, rb_s, rb_c);
-}
-
-void
-init_lapack_slaic1(VALUE mLapack){
- rb_define_module_function(mLapack, "slaic1", rb_slaic1, -1);
-}
diff --git a/slaln2.c b/slaln2.c
deleted file mode 100644
index 4a100f0..0000000
--- a/slaln2.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaln2_(logical *ltrans, integer *na, integer *nw, real *smin, real *ca, real *a, integer *lda, real *d1, real *d2, real *b, integer *ldb, real *wr, real *wi, real *x, integer *ldx, real *scale, real *xnorm, integer *info);
-
-static VALUE
-rb_slaln2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ltrans;
- logical ltrans;
- VALUE rb_smin;
- real smin;
- VALUE rb_ca;
- real ca;
- VALUE rb_a;
- real *a;
- VALUE rb_d1;
- real d1;
- VALUE rb_d2;
- real d2;
- VALUE rb_b;
- real *b;
- VALUE rb_wr;
- real wr;
- VALUE rb_wi;
- real wi;
- VALUE rb_x;
- real *x;
- VALUE rb_scale;
- real scale;
- VALUE rb_xnorm;
- real xnorm;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer na;
- integer ldb;
- integer nw;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, scale, xnorm, info = NumRu::Lapack.slaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi)\n or\n NumRu::Lapack.slaln2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLALN2 solves a system of the form (ca A - w D ) X = s B\n* or (ca A' - w D) X = s B with possible scaling (\"s\") and\n* perturbation of A. (A' means A-transpose.)\n*\n* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n* real diagonal matrix, w is a real or complex value, and X and B are\n* NA x 1 matrices -- real if w is real, complex if w is complex. NA\n* may be 1 or 2.\n*\n* If w is complex, X and B are represented as NA x 2 matrices,\n* the first column of each being the real part and the second\n* being the imaginary part.\n*\n* \"s\" is a scaling factor (.LE. 1), computed by SLALN2, which is\n* so chosen that X can be computed without overflow. X is further\n* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n* than overflow.\n*\n* If both singular values of (ca A - w D) are less than SMIN,\n* SMIN*identity will be used instead of (ca A - w D). If only one\n* singular value is less than SMIN, one element of (ca A - w D) will be\n* perturbed enough to make the smallest singular value roughly SMIN.\n* If both singular values are at least SMIN, (ca A - w D) will not be\n* perturbed. In any case, the perturbation will be at most some small\n* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values\n* are computed by infinity-norm approximations, and thus will only be\n* correct to a factor of 2 or so.\n*\n* Note: all input quantities are assumed to be smaller than overflow\n* by a reasonable factor. (See BIGNUM.)\n*\n\n* Arguments\n* ==========\n*\n* LTRANS (input) LOGICAL\n* =.TRUE.: A-transpose will be used.\n* =.FALSE.: A will be used (not transposed.)\n*\n* NA (input) INTEGER\n* The size of the matrix A. It may (only) be 1 or 2.\n*\n* NW (input) INTEGER\n* 1 if \"w\" is real, 2 if \"w\" is complex. It may only be 1\n* or 2.\n*\n* SMIN (input) REAL\n* The desired lower bound on the singular values of A. This\n* should be a safe distance away from underflow or overflow,\n* say, between (underflow/machine precision) and (machine\n* precision * overflow ). (See BIGNUM and ULP.)\n*\n* CA (input) REAL\n* The coefficient c, which A is multiplied by.\n*\n* A (input) REAL array, dimension (LDA,NA)\n* The NA x NA matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. It must be at least NA.\n*\n* D1 (input) REAL\n* The 1,1 element in the diagonal matrix D.\n*\n* D2 (input) REAL\n* The 2,2 element in the diagonal matrix D. Not used if NW=1.\n*\n* B (input) REAL array, dimension (LDB,NW)\n* The NA x NW matrix B (right-hand side). If NW=2 (\"w\" is\n* complex), column 1 contains the real part of B and column 2\n* contains the imaginary part.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. It must be at least NA.\n*\n* WR (input) REAL\n* The real part of the scalar \"w\".\n*\n* WI (input) REAL\n* The imaginary part of the scalar \"w\". Not used if NW=1.\n*\n* X (output) REAL array, dimension (LDX,NW)\n* The NA x NW matrix X (unknowns), as computed by SLALN2.\n* If NW=2 (\"w\" is complex), on exit, column 1 will contain\n* the real part of X and column 2 will contain the imaginary\n* part.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. It must be at least NA.\n*\n* SCALE (output) REAL\n* The scale factor that B must be multiplied by to insure\n* that overflow does not occur when computing X. Thus,\n* (ca A - w D) X will be SCALE*B, not B (ignoring\n* perturbations of A.) It will be at most 1.\n*\n* XNORM (output) REAL\n* The infinity-norm of X, when X is regarded as an NA x NW\n* real matrix.\n*\n* INFO (output) INTEGER\n* An error flag. It will be set to zero if no error occurs,\n* a negative number if an argument is in error, or a positive\n* number if ca A - w D had to be perturbed.\n* The possible values are:\n* = 0: No error occurred, and (ca A - w D) did not have to be\n* perturbed.\n* = 1: (ca A - w D) had to be perturbed to make its smallest\n* (or only) singular value greater than SMIN.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_ltrans = argv[0];
- rb_smin = argv[1];
- rb_ca = argv[2];
- rb_a = argv[3];
- rb_d1 = argv[4];
- rb_d2 = argv[5];
- rb_b = argv[6];
- rb_wr = argv[7];
- rb_wi = argv[8];
-
- smin = (real)NUM2DBL(rb_smin);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- na = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nw = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- d1 = (real)NUM2DBL(rb_d1);
- d2 = (real)NUM2DBL(rb_d2);
- ca = (real)NUM2DBL(rb_ca);
- ltrans = (rb_ltrans == Qtrue);
- wi = (real)NUM2DBL(rb_wi);
- wr = (real)NUM2DBL(rb_wr);
- ldx = na;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nw;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
-
- slaln2_(<rans, &na, &nw, &smin, &ca, a, &lda, &d1, &d2, b, &ldb, &wr, &wi, x, &ldx, &scale, &xnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_xnorm = rb_float_new((double)xnorm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_x, rb_scale, rb_xnorm, rb_info);
-}
-
-void
-init_lapack_slaln2(VALUE mLapack){
- rb_define_module_function(mLapack, "slaln2", rb_slaln2, -1);
-}
diff --git a/slals0.c b/slals0.c
deleted file mode 100644
index ee73738..0000000
--- a/slals0.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *difl, real *difr, real *z, integer *k, real *c, real *s, real *work, integer *info);
-
-static VALUE
-rb_slals0(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_b;
- real *b;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_poles;
- real *poles;
- VALUE rb_difl;
- real *difl;
- VALUE rb_difr;
- real *difr;
- VALUE rb_z;
- real *z;
- VALUE rb_c;
- real c;
- VALUE rb_s;
- real s;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
- real *bx;
- real *work;
-
- integer ldb;
- integer nrhs;
- integer n;
- integer ldgcol;
- integer ldgnum;
- integer k;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.slals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s)\n or\n NumRu::Lapack.slals0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) REAL array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) REAL array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) REAL array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) REAL array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) REAL array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) REAL array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) REAL array, dimension ( K )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_b = argv[4];
- rb_perm = argv[5];
- rb_givptr = argv[6];
- rb_givcol = argv[7];
- rb_givnum = argv[8];
- rb_poles = argv[9];
- rb_difl = argv[10];
- rb_difr = argv[11];
- rb_z = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
- if (NA_RANK(rb_difl) != 1)
- rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
- k = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_SFLOAT)
- rb_difl = na_change_type(rb_difl, NA_SFLOAT);
- difl = NA_PTR_TYPE(rb_difl, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- c = (real)NUM2DBL(rb_c);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
- ldgcol = NA_SHAPE0(rb_givcol);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (13th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- nr = NUM2INT(rb_nr);
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
- ldgnum = NA_SHAPE0(rb_poles);
- if (NA_TYPE(rb_poles) != NA_SFLOAT)
- rb_poles = na_change_type(rb_poles, NA_SFLOAT);
- poles = NA_PTR_TYPE(rb_poles, real*);
- icompq = NUM2INT(rb_icompq);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
- if (NA_SHAPE0(rb_givnum) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of poles");
- if (NA_TYPE(rb_givnum) != NA_SFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_SFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- s = (real)NUM2DBL(rb_s);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
- if (NA_SHAPE0(rb_difr) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of poles");
- if (NA_TYPE(rb_difr) != NA_SFLOAT)
- rb_difr = na_change_type(rb_difr, NA_SFLOAT);
- difr = NA_PTR_TYPE(rb_difr, real*);
- givptr = NUM2INT(rb_givptr);
- ldbx = n;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- bx = ALLOC_N(real, (ldbx)*(nrhs));
- work = ALLOC_N(real, (k));
-
- slals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, &info);
-
- free(bx);
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_slals0(VALUE mLapack){
- rb_define_module_function(mLapack, "slals0", rb_slals0, -1);
-}
diff --git a/slalsa.c b/slalsa.c
deleted file mode 100644
index bd80335..0000000
--- a/slalsa.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slalsa_(integer *icompq, integer *smlsiz, integer *n, integer *nrhs, real *b, integer *ldb, real *bx, integer *ldbx, real *u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real *z, real *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum, real *c, real *s, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slalsa(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_b;
- real *b;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_k;
- integer *k;
- VALUE rb_difl;
- real *difl;
- VALUE rb_difr;
- real *difr;
- VALUE rb_z;
- real *z;
- VALUE rb_poles;
- real *poles;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- real *s;
- VALUE rb_bx;
- real *bx;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldu;
- integer smlsiz;
- integer n;
- integer nlvl;
- integer ldgcol;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.slalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s)\n or\n NumRu::Lapack.slalsa # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, SLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by SLALSA.\n*\n\n* Arguments\n* =========\n*\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) REAL array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) REAL array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) REAL array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) REAL array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) REAL array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) REAL array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) REAL array.\n* The dimension must be at least N.\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_b = argv[1];
- rb_u = argv[2];
- rb_vt = argv[3];
- rb_k = argv[4];
- rb_difl = argv[5];
- rb_difr = argv[6];
- rb_z = argv[7];
- rb_poles = argv[8];
- rb_givptr = argv[9];
- rb_givcol = argv[10];
- rb_perm = argv[11];
- rb_givnum = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (5th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
- if (NA_RANK(rb_difl) != 2)
- rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
- nlvl = NA_SHAPE1(rb_difl);
- if (nlvl != ((int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1))
- rb_raise(rb_eRuntimeError, "shape 1 of difl must be %d", (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
- ldu = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_SFLOAT)
- rb_difl = na_change_type(rb_difl, NA_SFLOAT);
- difl = NA_PTR_TYPE(rb_difl, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (14th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (3th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
- smlsiz = NA_SHAPE1(rb_u);
- if (NA_SHAPE0(rb_u) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of u must be the same as shape 0 of difl");
- if (NA_TYPE(rb_u) != NA_SFLOAT)
- rb_u = na_change_type(rb_u, NA_SFLOAT);
- u = NA_PTR_TYPE(rb_u, real*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of difl");
- if (NA_SHAPE0(rb_z) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (15th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
- if (NA_RANK(rb_perm) != 2)
- rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_perm) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of perm must be the same as shape 1 of difl");
- ldgcol = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- ldbx = n;
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_poles) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of difl");
- if (NA_TYPE(rb_poles) != NA_SFLOAT)
- rb_poles = na_change_type(rb_poles, NA_SFLOAT);
- poles = NA_PTR_TYPE(rb_poles, real*);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_difr) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of difl");
- if (NA_TYPE(rb_difr) != NA_SFLOAT)
- rb_difr = na_change_type(rb_difr, NA_SFLOAT);
- difr = NA_PTR_TYPE(rb_difr, real*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vt) != (smlsiz+1))
- rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
- if (NA_SHAPE0(rb_vt) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of difl");
- if (NA_TYPE(rb_vt) != NA_SFLOAT)
- rb_vt = na_change_type(rb_vt, NA_SFLOAT);
- vt = NA_PTR_TYPE(rb_vt, real*);
- nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givnum) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of difl");
- if (NA_TYPE(rb_givnum) != NA_SFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_SFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givcol) != ldgcol)
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldbx;
- shape[1] = nrhs;
- rb_bx = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- bx = NA_PTR_TYPE(rb_bx, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (n));
- iwork = ALLOC_N(integer, (3 * n));
-
- slalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_bx, rb_info, rb_b);
-}
-
-void
-init_lapack_slalsa(VALUE mLapack){
- rb_define_module_function(mLapack, "slalsa", rb_slalsa, -1);
-}
diff --git a/slalsd.c b/slalsd.c
deleted file mode 100644
index ee9c4b2..0000000
--- a/slalsd.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, real *d, real *e, real *b, integer *ldb, real *rcond, integer *rank, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slalsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_b;
- real *b;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer nlvl;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.slalsd( uplo, smlsiz, d, e, b, rcond)\n or\n NumRu::Lapack.slalsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) REAL array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) REAL\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) REAL array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n*\n* IWORK (workspace) INTEGER array, dimension at least\n* (3*N*NLVL + 11*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_smlsiz = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_b = argv[4];
- rb_rcond = argv[5];
-
- rcond = (real)NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- smlsiz = NUM2INT(rb_smlsiz);
- uplo = StringValueCStr(rb_uplo)[0];
- nlvl = MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2)));
- iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
-
- slalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_slalsd(VALUE mLapack){
- rb_define_module_function(mLapack, "slalsd", rb_slalsd, -1);
-}
diff --git a/slamrg.c b/slamrg.c
deleted file mode 100644
index 08c6719..0000000
--- a/slamrg.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slamrg_(integer *n1, integer *n2, real *a, integer *strd1, integer *strd2, integer *index);
-
-static VALUE
-rb_slamrg(int argc, VALUE *argv, VALUE self){
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_a;
- real *a;
- VALUE rb_strd1;
- integer strd1;
- VALUE rb_strd2;
- integer strd2;
- VALUE rb_index;
- integer *index;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n index = NumRu::Lapack.slamrg( n1, n2, a, strd1, strd2)\n or\n NumRu::Lapack.slamrg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )\n\n* Purpose\n* =======\n*\n* SLAMRG will create a permutation list which will merge the elements\n* of A (which is composed of two independently sorted sets) into a\n* single set which is sorted in ascending order.\n*\n\n* Arguments\n* =========\n*\n* N1 (input) INTEGER\n* N2 (input) INTEGER\n* These arguements contain the respective lengths of the two\n* sorted lists to be merged.\n*\n* A (input) REAL array, dimension (N1+N2)\n* The first N1 elements of A contain a list of numbers which\n* are sorted in either ascending or descending order. Likewise\n* for the final N2 elements.\n*\n* STRD1 (input) INTEGER\n* STRD2 (input) INTEGER\n* These are the strides to be taken through the array A.\n* Allowable strides are 1 and -1. They indicate whether a\n* subset of A is sorted in ascending (STRDx = 1) or descending\n* (STRDx = -1) order.\n*\n* INDEX (output) INTEGER array, dimension (N1+N2)\n* On exit this array will contain a permutation such that\n* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n* sorted in ascending order.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IND1, IND2, N1SV, N2SV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_n1 = argv[0];
- rb_n2 = argv[1];
- rb_a = argv[2];
- rb_strd1 = argv[3];
- rb_strd2 = argv[4];
-
- strd1 = NUM2INT(rb_strd1);
- n2 = NUM2INT(rb_n2);
- n1 = NUM2INT(rb_n1);
- strd2 = NUM2INT(rb_strd2);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n1+n2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n1+n2);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = n1+n2;
- rb_index = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- index = NA_PTR_TYPE(rb_index, integer*);
-
- slamrg_(&n1, &n2, a, &strd1, &strd2, index);
-
- return rb_index;
-}
-
-void
-init_lapack_slamrg(VALUE mLapack){
- rb_define_module_function(mLapack, "slamrg", rb_slamrg, -1);
-}
diff --git a/slaneg.c b/slaneg.c
deleted file mode 100644
index 587f08a..0000000
--- a/slaneg.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern integer slaneg_(integer *n, real *d, real *lld, real *sigma, real *pivmin, integer *r);
-
-static VALUE
-rb_slaneg(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_lld;
- real *lld;
- VALUE rb_sigma;
- real sigma;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_r;
- integer r;
- VALUE rb___out__;
- integer __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slaneg( d, lld, sigma, pivmin, r)\n or\n NumRu::Lapack.slaneg # print help\n\n\nFORTRAN MANUAL\n INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n* Purpose\n* =======\n*\n* SLANEG computes the Sturm count, the number of negative pivots\n* encountered while factoring tridiagonal T - sigma I = L D L^T.\n* This implementation works directly on the factors without forming\n* the tridiagonal matrix T. The Sturm count is also the number of\n* eigenvalues of T less than sigma.\n*\n* This routine is called from SLARRB.\n*\n* The current routine does not use the PIVMIN parameter but rather\n* requires IEEE-754 propagation of Infinities and NaNs. This\n* routine also has no input range restrictions but does require\n* default exception handling such that x/0 produces Inf when x is\n* non-zero, and Inf/Inf produces NaN. For more information, see:\n*\n* Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n* Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624\n* (Tech report version in LAWN 172 with the same title.)\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) REAL array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* SIGMA (input) REAL \n* Shift amount in T - sigma I = L D L^T.\n*\n* PIVMIN (input) REAL \n* The minimum pivot in the Sturm sequence. May be used\n* when zero pivots are encountered on non-IEEE-754\n* architectures.\n*\n* R (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, University of California, Berkeley, USA\n* Jason Riedy, University of California, Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_lld = argv[1];
- rb_sigma = argv[2];
- rb_pivmin = argv[3];
- rb_r = argv[4];
-
- pivmin = (real)NUM2DBL(rb_pivmin);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- sigma = (real)NUM2DBL(rb_sigma);
- r = NUM2INT(rb_r);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_SFLOAT)
- rb_lld = na_change_type(rb_lld, NA_SFLOAT);
- lld = NA_PTR_TYPE(rb_lld, real*);
-
- __out__ = slaneg_(&n, d, lld, &sigma, &pivmin, &r);
-
- rb___out__ = INT2NUM(__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slaneg(VALUE mLapack){
- rb_define_module_function(mLapack, "slaneg", rb_slaneg, -1);
-}
diff --git a/slangb.c b/slangb.c
deleted file mode 100644
index f8fe216..0000000
--- a/slangb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slangb_(char *norm, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *work);
-
-static VALUE
-rb_slangb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slangb( norm, kl, ku, ab)\n or\n NumRu::Lapack.slangb # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* SLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* SLANGB returns the value\n*\n* SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slangb(VALUE mLapack){
- rb_define_module_function(mLapack, "slangb", rb_slangb, -1);
-}
diff --git a/slange.c b/slange.c
deleted file mode 100644
index 7b2d60e..0000000
--- a/slange.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slange_(char *norm, integer *m, integer *n, real *a, integer *lda, real *work);
-
-static VALUE
-rb_slange(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slange( norm, m, a)\n or\n NumRu::Lapack.slange # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real matrix A.\n*\n* Description\n* ===========\n*\n* SLANGE returns the value\n*\n* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* SLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* SLANGE is set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slange_(&norm, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slange(VALUE mLapack){
- rb_define_module_function(mLapack, "slange", rb_slange, -1);
-}
diff --git a/slangt.c b/slangt.c
deleted file mode 100644
index c29ac87..0000000
--- a/slangt.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slangt_(char *norm, integer *n, real *dl, real *d, real *du);
-
-static VALUE
-rb_slangt(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- real *dl;
- VALUE rb_d;
- real *d;
- VALUE rb_du;
- real *du;
- VALUE rb___out__;
- real __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slangt( norm, dl, d, du)\n or\n NumRu::Lapack.slangt # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* SLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* SLANGT returns the value\n*\n* SLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANGT is\n* set to zero.\n*\n* DL (input) REAL array, dimension (N-1)\n* The (n-1) sub-diagonal 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) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_SFLOAT)
- rb_du = na_change_type(rb_du, NA_SFLOAT);
- du = NA_PTR_TYPE(rb_du, real*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_SFLOAT)
- rb_dl = na_change_type(rb_dl, NA_SFLOAT);
- dl = NA_PTR_TYPE(rb_dl, real*);
-
- __out__ = slangt_(&norm, &n, dl, d, du);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slangt(VALUE mLapack){
- rb_define_module_function(mLapack, "slangt", rb_slangt, -1);
-}
diff --git a/slanhs.c b/slanhs.c
deleted file mode 100644
index 6912b36..0000000
--- a/slanhs.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slanhs_(char *norm, integer *n, real *a, integer *lda, real *work);
-
-static VALUE
-rb_slanhs(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- real *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slanhs( norm, a)\n or\n NumRu::Lapack.slanhs # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* SLANHS returns the value\n*\n* SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANHS is\n* set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slanhs_(&norm, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slanhs(VALUE mLapack){
- rb_define_module_function(mLapack, "slanhs", rb_slanhs, -1);
-}
diff --git a/slansb.c b/slansb.c
deleted file mode 100644
index 69fe4cc..0000000
--- a/slansb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slansb_(char *norm, char *uplo, integer *n, integer *k, real *ab, integer *ldab, real *work);
-
-static VALUE
-rb_slansb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- real *ab;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansb( norm, uplo, k, ab)\n or\n NumRu::Lapack.slansb # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* SLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* SLANSB returns the value\n*\n* SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_k = argv[2];
- rb_ab = argv[3];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slansb(VALUE mLapack){
- rb_define_module_function(mLapack, "slansb", rb_slansb, -1);
-}
diff --git a/slansf.c b/slansf.c
deleted file mode 100644
index 9ddb0fe..0000000
--- a/slansf.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slansf_(char *norm, char *transr, char *uplo, integer *n, real *a, real *work);
-
-static VALUE
-rb_slansf(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- real *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansf( norm, transr, uplo, n, a)\n or\n NumRu::Lapack.slansf # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* SLANSF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* SLANSF returns the value\n*\n* SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSF as described\n* above.\n*\n* TRANSR (input) CHARACTER*1\n* Specifies whether the RFP format of A is normal or\n* transposed format.\n* = 'N': RFP format is Normal;\n* = 'T': RFP format is Transpose.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* = 'U': RFP A came from an upper triangular matrix;\n* = 'L': RFP A came from a lower triangular matrix.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSF is\n* set to zero.\n*\n* A (input) REAL array, dimension ( N*(N+1)/2 );\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* part of the symmetric matrix A stored in RFP format. See the\n* \"Notes\" below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_transr = argv[1];
- rb_uplo = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));
-
- __out__ = slansf_(&norm, &transr, &uplo, &n, a, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slansf(VALUE mLapack){
- rb_define_module_function(mLapack, "slansf", rb_slansf, -1);
-}
diff --git a/slansp.c b/slansp.c
deleted file mode 100644
index 2282068..0000000
--- a/slansp.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slansp_(char *norm, char *uplo, integer *n, real *ap, real *work);
-
-static VALUE
-rb_slansp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansp( norm, uplo, n, ap)\n or\n NumRu::Lapack.slansp # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* SLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* SLANSP returns the value\n*\n* SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSP is\n* set to zero.\n*\n* AP (input) REAL array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slansp_(&norm, &uplo, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slansp(VALUE mLapack){
- rb_define_module_function(mLapack, "slansp", rb_slansp, -1);
-}
diff --git a/slanst.c b/slanst.c
deleted file mode 100644
index 47351e8..0000000
--- a/slanst.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slanst_(char *norm, integer *n, real *d, real *e);
-
-static VALUE
-rb_slanst(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb___out__;
- real __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slanst( norm, d, e)\n or\n NumRu::Lapack.slanst # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANST( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* SLANST returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* SLANST returns the value\n*\n* SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANST as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANST is\n* set to zero.\n*\n* D (input) REAL array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
-
- __out__ = slanst_(&norm, &n, d, e);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slanst(VALUE mLapack){
- rb_define_module_function(mLapack, "slanst", rb_slanst, -1);
-}
diff --git a/slansy.c b/slansy.c
deleted file mode 100644
index 1645a33..0000000
--- a/slansy.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slansy_(char *norm, char *uplo, integer *n, real *a, integer *lda, real *work);
-
-static VALUE
-rb_slansy(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slansy( norm, uplo, a)\n or\n NumRu::Lapack.slansy # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* real symmetric matrix A.\n*\n* Description\n* ===========\n*\n* SLANSY returns the value\n*\n* SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANSY is\n* set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slansy_(&norm, &uplo, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slansy(VALUE mLapack){
- rb_define_module_function(mLapack, "slansy", rb_slansy, -1);
-}
diff --git a/slantb.c b/slantb.c
deleted file mode 100644
index 8439b69..0000000
--- a/slantb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, real *ab, integer *ldab, real *work);
-
-static VALUE
-rb_slantb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- real *ab;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slantb( norm, uplo, diag, k, ab)\n or\n NumRu::Lapack.slantb # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* SLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* SLANTB returns the value\n*\n* SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_k = argv[3];
- rb_ab = argv[4];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slantb(VALUE mLapack){
- rb_define_module_function(mLapack, "slantb", rb_slantb, -1);
-}
diff --git a/slantp.c b/slantp.c
deleted file mode 100644
index c793289..0000000
--- a/slantp.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slantp_(char *norm, char *uplo, char *diag, integer *n, real *ap, real *work);
-
-static VALUE
-rb_slantp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slantp( norm, uplo, diag, n, ap)\n or\n NumRu::Lapack.slantp # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* SLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* SLANTP returns the value\n*\n* SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, SLANTP is\n* set to zero.\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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slantp_(&norm, &uplo, &diag, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slantp(VALUE mLapack){
- rb_define_module_function(mLapack, "slantp", rb_slantp, -1);
-}
diff --git a/slantr.c b/slantr.c
deleted file mode 100644
index d63cf73..0000000
--- a/slantr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, real *a, integer *lda, real *work);
-
-static VALUE
-rb_slantr(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb___out__;
- real __out__;
- real *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slantr( norm, uplo, diag, m, a)\n or\n NumRu::Lapack.slantr # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* SLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* SLANTR returns the value\n*\n* SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in SLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_m = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- __out__ = slantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slantr(VALUE mLapack){
- rb_define_module_function(mLapack, "slantr", rb_slantr, -1);
-}
diff --git a/slanv2.c b/slanv2.c
deleted file mode 100644
index fcf8ad4..0000000
--- a/slanv2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slanv2_(real *a, real *b, real *c, real *d, real *rt1r, real *rt1i, real *rt2r, real *rt2i, real *cs, real *sn);
-
-static VALUE
-rb_slanv2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real a;
- VALUE rb_b;
- real b;
- VALUE rb_c;
- real c;
- VALUE rb_d;
- real d;
- VALUE rb_rt1r;
- real rt1r;
- VALUE rb_rt1i;
- real rt1i;
- VALUE rb_rt2r;
- real rt2r;
- VALUE rb_rt2i;
- real rt2i;
- VALUE rb_cs;
- real cs;
- VALUE rb_sn;
- real sn;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.slanv2( a, b, c, d)\n or\n NumRu::Lapack.slanv2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n* Purpose\n* =======\n*\n* SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n* matrix in standard form:\n*\n* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]\n* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]\n*\n* where either\n* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n* conjugate eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* A (input/output) REAL \n* B (input/output) REAL \n* C (input/output) REAL \n* D (input/output) REAL \n* On entry, the elements of the input matrix.\n* On exit, they are overwritten by the elements of the\n* standardised Schur form.\n*\n* RT1R (output) REAL \n* RT1I (output) REAL \n* RT2R (output) REAL \n* RT2I (output) REAL \n* The real and imaginary parts of the eigenvalues. If the\n* eigenvalues are a complex conjugate pair, RT1I > 0.\n*\n* CS (output) REAL \n* SN (output) REAL \n* Parameters of the rotation matrix.\n*\n\n* Further Details\n* ===============\n*\n* Modified by V. Sima, Research Institute for Informatics, Bucharest,\n* Romania, to reduce the risk of cancellation errors,\n* when computing real eigenvalues, and to ensure, if possible, that\n* abs(RT1R) >= abs(RT2R).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
-
- a = (real)NUM2DBL(rb_a);
- b = (real)NUM2DBL(rb_b);
- c = (real)NUM2DBL(rb_c);
- d = (real)NUM2DBL(rb_d);
-
- slanv2_(&a, &b, &c, &d, &rt1r, &rt1i, &rt2r, &rt2i, &cs, &sn);
-
- rb_rt1r = rb_float_new((double)rt1r);
- rb_rt1i = rb_float_new((double)rt1i);
- rb_rt2r = rb_float_new((double)rt2r);
- rb_rt2i = rb_float_new((double)rt2i);
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- rb_a = rb_float_new((double)a);
- rb_b = rb_float_new((double)b);
- rb_c = rb_float_new((double)c);
- rb_d = rb_float_new((double)d);
- return rb_ary_new3(10, rb_rt1r, rb_rt1i, rb_rt2r, rb_rt2i, rb_cs, rb_sn, rb_a, rb_b, rb_c, rb_d);
-}
-
-void
-init_lapack_slanv2(VALUE mLapack){
- rb_define_module_function(mLapack, "slanv2", rb_slanv2, -1);
-}
diff --git a/slapll.c b/slapll.c
deleted file mode 100644
index a8b541a..0000000
--- a/slapll.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slapll_(integer *n, real *x, integer *incx, real *y, integer *incy, real *ssmin);
-
-static VALUE
-rb_slapll(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_ssmin;
- real ssmin;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_y_out__;
- real *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.slapll( n, x, incx, y, incy)\n or\n NumRu::Lapack.slapll # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) REAL array,\n* dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) REAL\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
-
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- slapll_(&n, x, &incx, y, &incy, &ssmin);
-
- rb_ssmin = rb_float_new((double)ssmin);
- return rb_ary_new3(3, rb_ssmin, rb_x, rb_y);
-}
-
-void
-init_lapack_slapll(VALUE mLapack){
- rb_define_module_function(mLapack, "slapll", rb_slapll, -1);
-}
diff --git a/slapmr.c b/slapmr.c
deleted file mode 100644
index db0fb69..0000000
--- a/slapmr.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slapmr_(logical *forwrd, integer *m, integer *n, real *x, integer *ldx, integer *k);
-
-static VALUE
-rb_slapmr(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_x;
- real *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.slapmr( forwrd, x, k)\n or\n NumRu::Lapack.slapmr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* SLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n REAL TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_forwrd = argv[0];
- rb_x = argv[1];
- rb_k = argv[2];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (3th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- slapmr_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_slapmr(VALUE mLapack){
- rb_define_module_function(mLapack, "slapmr", rb_slapmr, -1);
-}
diff --git a/slapmt.c b/slapmt.c
deleted file mode 100644
index 0c2d12c..0000000
--- a/slapmt.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slapmt_(logical *forwrd, integer *m, integer *n, real *x, integer *ldx, integer *k);
-
-static VALUE
-rb_slapmt(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_m;
- integer m;
- VALUE rb_x;
- real *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.slapmt( forwrd, m, x, k)\n or\n NumRu::Lapack.slapmt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* SLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, J, IN\n REAL TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_forwrd = argv[0];
- rb_m = argv[1];
- rb_x = argv[2];
- rb_k = argv[3];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (4th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 0 of k");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- m = NUM2INT(rb_m);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- slapmt_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_slapmt(VALUE mLapack){
- rb_define_module_function(mLapack, "slapmt", rb_slapmt, -1);
-}
diff --git a/slapy2.c b/slapy2.c
deleted file mode 100644
index 6c682e3..0000000
--- a/slapy2.c
+++ /dev/null
@@ -1,36 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slapy2_(real *x, real *y);
-
-static VALUE
-rb_slapy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- real x;
- VALUE rb_y;
- real y;
- VALUE rb___out__;
- real __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slapy2( x, y)\n or\n NumRu::Lapack.slapy2 # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLAPY2( X, Y )\n\n* Purpose\n* =======\n*\n* SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n* overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) REAL\n* Y (input) REAL\n* X and Y specify the values x and y.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
-
- x = (real)NUM2DBL(rb_x);
- y = (real)NUM2DBL(rb_y);
-
- __out__ = slapy2_(&x, &y);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slapy2(VALUE mLapack){
- rb_define_module_function(mLapack, "slapy2", rb_slapy2, -1);
-}
diff --git a/slapy3.c b/slapy3.c
deleted file mode 100644
index b6ee8cb..0000000
--- a/slapy3.c
+++ /dev/null
@@ -1,40 +0,0 @@
-#include "rb_lapack.h"
-
-extern real slapy3_(real *x, real *y, real *z);
-
-static VALUE
-rb_slapy3(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- real x;
- VALUE rb_y;
- real y;
- VALUE rb_z;
- real z;
- VALUE rb___out__;
- real __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.slapy3( x, y, z)\n or\n NumRu::Lapack.slapy3 # print help\n\n\nFORTRAN MANUAL\n REAL FUNCTION SLAPY3( X, Y, Z )\n\n* Purpose\n* =======\n*\n* SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n* unnecessary overflow.\n*\n\n* Arguments\n* =========\n*\n* X (input) REAL\n* Y (input) REAL\n* Z (input) REAL\n* X, Y and Z specify the values x, y and z.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_z = argv[2];
-
- x = (real)NUM2DBL(rb_x);
- y = (real)NUM2DBL(rb_y);
- z = (real)NUM2DBL(rb_z);
-
- __out__ = slapy3_(&x, &y, &z);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_slapy3(VALUE mLapack){
- rb_define_module_function(mLapack, "slapy3", rb_slapy3, -1);
-}
diff --git a/slaqgb.c b/slaqgb.c
deleted file mode 100644
index b6b326c..0000000
--- a/slaqgb.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqgb_(integer *m, integer *n, integer *kl, integer *ku, real *ab, integer *ldab, real *r, real *c, real *rowcnd, real *colcnd, real *amax, char *equed);
-
-static VALUE
-rb_slaqgb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- real *ab;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.slaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.slaqgb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_r = argv[3];
- rb_c = argv[4];
- rb_rowcnd = argv[5];
- rb_colcnd = argv[6];
- rb_amax = argv[7];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- amax = (real)NUM2DBL(rb_amax);
- colcnd = (real)NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (4th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- rowcnd = (real)NUM2DBL(rb_rowcnd);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- slaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_slaqgb(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqgb", rb_slaqgb, -1);
-}
diff --git a/slaqge.c b/slaqge.c
deleted file mode 100644
index 8167662..0000000
--- a/slaqge.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqge_(integer *m, integer *n, real *a, integer *lda, real *r, real *c, real *rowcnd, real *colcnd, real *amax, char *equed);
-
-static VALUE
-rb_slaqge(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_r;
- real *r;
- VALUE rb_c;
- real *c;
- VALUE rb_rowcnd;
- real rowcnd;
- VALUE rb_colcnd;
- real colcnd;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.slaqge( a, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.slaqge # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) REAL array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) REAL array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) REAL\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) REAL\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) REAL\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_a = argv[0];
- rb_r = argv[1];
- rb_c = argv[2];
- rb_rowcnd = argv[3];
- rb_colcnd = argv[4];
- rb_amax = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- amax = (real)NUM2DBL(rb_amax);
- colcnd = (real)NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (2th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_SFLOAT)
- rb_r = na_change_type(rb_r, NA_SFLOAT);
- r = NA_PTR_TYPE(rb_r, real*);
- rowcnd = (real)NUM2DBL(rb_rowcnd);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_slaqge(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqge", rb_slaqge, -1);
-}
diff --git a/slaqp2.c b/slaqp2.c
deleted file mode 100644
index 0fdb1f4..0000000
--- a/slaqp2.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqp2_(integer *m, integer *n, integer *offset, real *a, integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real *work);
-
-static VALUE
-rb_slaqp2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- real *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- real *vn1;
- VALUE rb_vn2;
- real *vn2;
- VALUE rb_tau;
- real *tau;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- real *vn1_out__;
- VALUE rb_vn2_out__;
- real *vn2_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.slaqp2( m, offset, a, jpvt, vn1, vn2)\n or\n NumRu::Lapack.slaqp2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* SLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n* the triangular factor obtained; the elements in block \n* A(OFFSET+1:M,1:N) below the diagonal, together with the \n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) REAL array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_SFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_SFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, real*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_SFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_SFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, real*);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- offset = NUM2INT(rb_offset);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, real*);
- MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, real*);
- MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- work = ALLOC_N(real, (n));
-
- slaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
-
- free(work);
- return rb_ary_new3(5, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2);
-}
-
-void
-init_lapack_slaqp2(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqp2", rb_slaqp2, -1);
-}
diff --git a/slaqps.c b/slaqps.c
deleted file mode 100644
index c0757e6..0000000
--- a/slaqps.c
+++ /dev/null
@@ -1,189 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqps_(integer *m, integer *n, integer *offset, integer *nb, integer *kb, real *a, integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real *auxv, real *f, integer *ldf);
-
-static VALUE
-rb_slaqps(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- real *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- real *vn1;
- VALUE rb_vn2;
- real *vn2;
- VALUE rb_auxv;
- real *auxv;
- VALUE rb_f;
- real *f;
- VALUE rb_kb;
- integer kb;
- VALUE rb_tau;
- real *tau;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- real *vn1_out__;
- VALUE rb_vn2_out__;
- real *vn2_out__;
- VALUE rb_auxv_out__;
- real *auxv_out__;
- VALUE rb_f_out__;
- real *f_out__;
-
- integer lda;
- integer n;
- integer nb;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.slaqps( m, offset, a, jpvt, vn1, vn2, auxv, f)\n or\n NumRu::Lapack.slaqps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* SLAQPS computes a step of QR factorization with column pivoting\n* of a real M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) REAL array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) REAL array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) REAL array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) REAL array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) REAL array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
- rb_auxv = argv[6];
- rb_f = argv[7];
-
- if (!NA_IsNArray(rb_auxv))
- rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
- if (NA_RANK(rb_auxv) != 1)
- rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
- nb = NA_SHAPE0(rb_auxv);
- if (NA_TYPE(rb_auxv) != NA_SFLOAT)
- rb_auxv = na_change_type(rb_auxv, NA_SFLOAT);
- auxv = NA_PTR_TYPE(rb_auxv, real*);
- offset = NUM2INT(rb_offset);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_SFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_SFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, real*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != nb)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_SFLOAT)
- rb_f = na_change_type(rb_f, NA_SFLOAT);
- f = NA_PTR_TYPE(rb_f, real*);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_SFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_SFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, real*);
- kb = nb;
- {
- int shape[1];
- shape[0] = kb;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, real*);
- MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, real*);
- MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- {
- int shape[1];
- shape[0] = nb;
- rb_auxv_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- auxv_out__ = NA_PTR_TYPE(rb_auxv_out__, real*);
- MEMCPY(auxv_out__, auxv, real, NA_TOTAL(rb_auxv));
- rb_auxv = rb_auxv_out__;
- auxv = auxv_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = nb;
- rb_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, real*);
- MEMCPY(f_out__, f, real, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
-
- slaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
-
- rb_kb = INT2NUM(kb);
- return rb_ary_new3(8, rb_kb, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2, rb_auxv, rb_f);
-}
-
-void
-init_lapack_slaqps(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqps", rb_slaqps, -1);
-}
diff --git a/slaqr0.c b/slaqr0.c
deleted file mode 100644
index 28d3791..0000000
--- a/slaqr0.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, real *h, integer *ldh, real *wr, real *wi, integer *iloz, integer *ihiz, real *z, integer *ldz, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_slaqr0(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_h;
- real *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- real *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ihi;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.slaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, lwork)\n or\n NumRu::Lapack.slaqr0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to SGEBAL, and then passed to SGEHRD when the\n* matrix output by SGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) REAL array, dimension (IHI)\n* WI (output) REAL array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) REAL array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then SLAQR0 does a workspace query.\n* In this case, SLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, SLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_h = argv[3];
- rb_iloz = argv[4];
- rb_ihiz = argv[5];
- rb_z = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- ihi = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (4th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = ihi;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- slaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_wr, rb_wi, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_slaqr0(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqr0", rb_slaqr0, -1);
-}
diff --git a/slaqr1.c b/slaqr1.c
deleted file mode 100644
index bdb955c..0000000
--- a/slaqr1.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqr1_(integer *n, real *h, integer *ldh, real *sr1, real *si1, real *sr2, real *si2, real *v);
-
-static VALUE
-rb_slaqr1(int argc, VALUE *argv, VALUE self){
- VALUE rb_h;
- real *h;
- VALUE rb_sr1;
- real sr1;
- VALUE rb_si1;
- real si1;
- VALUE rb_sr2;
- real sr2;
- VALUE rb_si2;
- real si2;
- VALUE rb_v;
- real *v;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n v = NumRu::Lapack.slaqr1( h, sr1, si1, sr2, si2)\n or\n NumRu::Lapack.slaqr1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n*\n* scaling to avoid overflows and most underflows. It\n* is assumed that either\n*\n* 1) sr1 = sr2 and si1 = -si2\n* or\n* 2) si1 = si2 = 0.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) REAL array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* SR1 (input) REAL\n* SI1 The shifts in (*).\n* SR2\n* SI2\n*\n* V (output) REAL array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_h = argv[0];
- rb_sr1 = argv[1];
- rb_si1 = argv[2];
- rb_sr2 = argv[3];
- rb_si2 = argv[4];
-
- si1 = (real)NUM2DBL(rb_si1);
- si2 = (real)NUM2DBL(rb_si2);
- sr1 = (real)NUM2DBL(rb_sr1);
- sr2 = (real)NUM2DBL(rb_sr2);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (1th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_v = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, real*);
-
- slaqr1_(&n, h, &ldh, &sr1, &si1, &sr2, &si2, v);
-
- return rb_v;
-}
-
-void
-init_lapack_slaqr1(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqr1", rb_slaqr1, -1);
-}
diff --git a/slaqr2.c b/slaqr2.c
deleted file mode 100644
index 27c2628..0000000
--- a/slaqr2.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, real *h, integer *ldh, integer *iloz, integer *ihiz, real *z, integer *ldz, integer *ns, integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *work, integer *lwork);
-
-static VALUE
-rb_slaqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- real *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- real *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_nv;
- integer nv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sr;
- real *sr;
- VALUE rb_si;
- real *si;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_z_out__;
- real *z_out__;
- real *v;
- real *t;
- real *wv;
- real *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
- integer ldt;
- integer ldwv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.slaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, lwork)\n or\n NumRu::Lapack.slaqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to SLAQR3 except that it avoids\n* recursion by calling SLAHQR instead of SLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) REAL array, dimension KBOT\n* SI (output) REAL array, dimension KBOT\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) REAL array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) REAL array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) REAL array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) REAL array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; SLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_nv = argv[10];
- rb_lwork = argv[11];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- kbot = NUM2INT(rb_kbot);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sr = NA_PTR_TYPE(rb_sr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- si = NA_PTR_TYPE(rb_si, real*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
- wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- slaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(6, rb_ns, rb_nd, rb_sr, rb_si, rb_h, rb_z);
-}
-
-void
-init_lapack_slaqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqr2", rb_slaqr2, -1);
-}
diff --git a/slaqr3.c b/slaqr3.c
deleted file mode 100644
index fc0c28c..0000000
--- a/slaqr3.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqr3_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, real *h, integer *ldh, integer *iloz, integer *ihiz, real *z, integer *ldz, integer *ns, integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real *work, integer *lwork);
-
-static VALUE
-rb_slaqr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- real *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- real *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_nv;
- integer nv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sr;
- real *sr;
- VALUE rb_si;
- real *si;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_z_out__;
- real *z_out__;
- real *v;
- real *t;
- real *wv;
- real *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
- integer ldt;
- integer ldwv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sr, si, h, z = NumRu::Lapack.slaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, lwork)\n or\n NumRu::Lapack.slaqr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an orthogonal similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an orthogonal similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the quasi-triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the orthogonal matrix Z is updated so\n* so that the orthogonal Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the orthogonal matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by an orthogonal\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the orthogonal\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SR (output) REAL array, dimension KBOT\n* SI (output) REAL array, dimension KBOT\n* On output, the real and imaginary parts of approximate\n* eigenvalues that may be used for shifts are stored in\n* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n* The real and imaginary parts of converged eigenvalues\n* are stored in SR(KBOT-ND+1) through SR(KBOT) and\n* SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n* V (workspace) REAL array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) REAL array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) REAL array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) REAL array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; SLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_nv = argv[10];
- rb_lwork = argv[11];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- kbot = NUM2INT(rb_kbot);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sr = NA_PTR_TYPE(rb_sr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- si = NA_PTR_TYPE(rb_si, real*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
- wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- slaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(6, rb_ns, rb_nd, rb_sr, rb_si, rb_h, rb_z);
-}
-
-void
-init_lapack_slaqr3(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqr3", rb_slaqr3, -1);
-}
diff --git a/slaqr4.c b/slaqr4.c
deleted file mode 100644
index f0707be..0000000
--- a/slaqr4.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqr4_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, real *h, integer *ldh, real *wr, real *wi, integer *iloz, integer *ihiz, real *z, integer *ldz, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_slaqr4(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_h;
- real *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- real *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ihi;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, work, info, h, z = NumRu::Lapack.slaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, lwork)\n or\n NumRu::Lapack.slaqr4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n* Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input orthogonal\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to SGEBAL, and then passed to SGEHRD when the\n* matrix output by SGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) REAL array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n* the upper quasi-triangular matrix T from the Schur\n* decomposition (the Schur form); 2-by-2 diagonal blocks\n* (corresponding to complex conjugate pairs of eigenvalues)\n* are returned in standard form, with H(i,i) = H(i+1,i+1)\n* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* WR (output) REAL array, dimension (IHI)\n* WI (output) REAL array, dimension (IHI)\n* The real and imaginary parts, respectively, of the computed\n* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n* and WI(ILO:IHI). If two eigenvalues are computed as a\n* complex conjugate pair, they are stored in consecutive\n* elements of WR and WI, say the i-th and (i+1)th, with\n* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n* the eigenvalues are stored in the same order as on the\n* diagonal of the Schur form returned in H, with\n* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n* WI(i+1) = -WI(i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n* Z (input/output) REAL array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) REAL array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then SLAQR4 does a workspace query.\n* In this case, SLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, SLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is an orthogonal matrix. The final\n* value of H is upper Hessenberg and quasi-triangular\n* in rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the orthogonal matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_h = argv[3];
- rb_iloz = argv[4];
- rb_ihiz = argv[5];
- rb_z = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- ihi = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- lwork = NUM2INT(rb_lwork);
- iloz = NUM2INT(rb_iloz);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (4th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = ihi;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = ihi;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- slaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_wr, rb_wi, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_slaqr4(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqr4", rb_slaqr4, -1);
-}
diff --git a/slaqr5.c b/slaqr5.c
deleted file mode 100644
index 3010027..0000000
--- a/slaqr5.c
+++ /dev/null
@@ -1,183 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqr5_(logical *wantt, logical *wantz, integer *kacc22, integer *n, integer *ktop, integer *kbot, integer *nshfts, real *sr, real *si, real *h, integer *ldh, integer *iloz, integer *ihiz, real *z, integer *ldz, real *v, integer *ldv, real *u, integer *ldu, integer *nv, real *wv, integer *ldwv, integer *nh, real *wh, integer *ldwh);
-
-static VALUE
-rb_slaqr5(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_kacc22;
- integer kacc22;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_sr;
- real *sr;
- VALUE rb_si;
- real *si;
- VALUE rb_h;
- real *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- real *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_nv;
- integer nv;
- VALUE rb_nh;
- integer nh;
- VALUE rb_sr_out__;
- real *sr_out__;
- VALUE rb_si_out__;
- real *si_out__;
- VALUE rb_h_out__;
- real *h_out__;
- VALUE rb_z_out__;
- real *z_out__;
- real *v;
- real *u;
- real *wv;
- real *wh;
-
- integer nshfts;
- integer ldh;
- integer n;
- integer ldv;
- integer ldu;
- integer ldwv;
- integer ldwh;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sr, si, h, z = NumRu::Lapack.slaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, ldz, nv, nh)\n or\n NumRu::Lapack.slaqr5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by SLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the quasi-triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the orthogonal Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: SLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: SLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: SLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* SR (input/output) REAL array of size (NSHFTS)\n* SI (input/output) REAL array of size (NSHFTS)\n* SR contains the real parts and SI contains the imaginary\n* parts of the NSHFTS shifts of origin that define the\n* multi-shift QR sweep. On output SR and SI may be\n* reordered.\n*\n* H (input/output) REAL array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) REAL array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep orthogonal\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) REAL array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) REAL array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) REAL array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) REAL array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_kacc22 = argv[2];
- rb_ktop = argv[3];
- rb_kbot = argv[4];
- rb_sr = argv[5];
- rb_si = argv[6];
- rb_h = argv[7];
- rb_iloz = argv[8];
- rb_ihiz = argv[9];
- rb_z = argv[10];
- rb_ldz = argv[11];
- rb_nv = argv[12];
- rb_nh = argv[13];
-
- if (!NA_IsNArray(rb_si))
- rb_raise(rb_eArgError, "si (7th argument) must be NArray");
- if (NA_RANK(rb_si) != 1)
- rb_raise(rb_eArgError, "rank of si (7th argument) must be %d", 1);
- nshfts = NA_SHAPE0(rb_si);
- if (NA_TYPE(rb_si) != NA_SFLOAT)
- rb_si = na_change_type(rb_si, NA_SFLOAT);
- si = NA_PTR_TYPE(rb_si, real*);
- kacc22 = NUM2INT(rb_kacc22);
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_sr))
- rb_raise(rb_eArgError, "sr (6th argument) must be NArray");
- if (NA_RANK(rb_sr) != 1)
- rb_raise(rb_eArgError, "rank of sr (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sr) != nshfts)
- rb_raise(rb_eRuntimeError, "shape 0 of sr must be the same as shape 0 of si");
- if (NA_TYPE(rb_sr) != NA_SFLOAT)
- rb_sr = na_change_type(rb_sr, NA_SFLOAT);
- sr = NA_PTR_TYPE(rb_sr, real*);
- kbot = NUM2INT(rb_kbot);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (8th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_SFLOAT)
- rb_h = na_change_type(rb_h, NA_SFLOAT);
- h = NA_PTR_TYPE(rb_h, real*);
- nv = NUM2INT(rb_nv);
- ihiz = NUM2INT(rb_ihiz);
- wantt = (rb_wantt == Qtrue);
- ldv = 3;
- iloz = NUM2INT(rb_iloz);
- ldz = n;
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (11th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? ihiz : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- ldwv = nv;
- ldu = 3*nshfts-3;
- ldwh = 3*nshfts-3;
- {
- int shape[1];
- shape[0] = nshfts;
- rb_sr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sr_out__ = NA_PTR_TYPE(rb_sr_out__, real*);
- MEMCPY(sr_out__, sr, real, NA_TOTAL(rb_sr));
- rb_sr = rb_sr_out__;
- sr = sr_out__;
- {
- int shape[1];
- shape[0] = nshfts;
- rb_si_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- si_out__ = NA_PTR_TYPE(rb_si_out__, real*);
- MEMCPY(si_out__, si, real, NA_TOTAL(rb_si));
- rb_si = rb_si_out__;
- si = si_out__;
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, real*);
- MEMCPY(h_out__, h, real, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? ihiz : 0;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(real, (ldv)*(nshfts/2));
- u = ALLOC_N(real, (ldu)*(3*nshfts-3));
- wv = ALLOC_N(real, (ldwv)*(3*nshfts-3));
- wh = ALLOC_N(real, (ldwh)*(MAX(1,nh)));
-
- slaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, sr, si, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
-
- free(v);
- free(u);
- free(wv);
- free(wh);
- return rb_ary_new3(4, rb_sr, rb_si, rb_h, rb_z);
-}
-
-void
-init_lapack_slaqr5(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqr5", rb_slaqr5, -1);
-}
diff --git a/slaqsb.c b/slaqsb.c
deleted file mode 100644
index b3b4d07..0000000
--- a/slaqsb.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqsb_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_slaqsb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.slaqsb( uplo, kd, ab, s, scond, amax)\n or\n NumRu::Lapack.slaqsb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_s = argv[3];
- rb_scond = argv[4];
- rb_amax = argv[5];
-
- scond = (real)NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kd = NUM2INT(rb_kd);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- slaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_slaqsb(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqsb", rb_slaqsb, -1);
-}
diff --git a/slaqsp.c b/slaqsp.c
deleted file mode 100644
index f401381..0000000
--- a/slaqsp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqsp_(char *uplo, integer *n, real *ap, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_slaqsp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ap_out__;
- real *ap_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ap = NumRu::Lapack.slaqsp( uplo, ap, s, scond, amax)\n or\n NumRu::Lapack.slaqsp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQSP 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* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\n*\n* S (input) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = (real)NUM2DBL(rb_scond);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- slaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ap);
-}
-
-void
-init_lapack_slaqsp(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqsp", rb_slaqsp, -1);
-}
diff --git a/slaqsy.c b/slaqsy.c
deleted file mode 100644
index a2ca99d..0000000
--- a/slaqsy.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqsy_(char *uplo, integer *n, real *a, integer *lda, real *s, real *scond, real *amax, char *equed);
-
-static VALUE
-rb_slaqsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.slaqsy( uplo, a, s, scond, amax)\n or\n NumRu::Lapack.slaqsy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* SLAQSY 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) REAL 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) REAL array, dimension (N)\n* The scale factors for A.\n*\n* SCOND (input) REAL\n* Ratio of the smallest S(i) to the largest S(i).\n*\n* AMAX (input) REAL\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = (real)NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- amax = (real)NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_slaqsy(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqsy", rb_slaqsy, -1);
-}
diff --git a/slaqtr.c b/slaqtr.c
deleted file mode 100644
index 5e8e2b7..0000000
--- a/slaqtr.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaqtr_(logical *ltran, logical *lreal, integer *n, real *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work, integer *info);
-
-static VALUE
-rb_slaqtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_ltran;
- logical ltran;
- VALUE rb_lreal;
- logical lreal;
- VALUE rb_t;
- real *t;
- VALUE rb_b;
- real *b;
- VALUE rb_w;
- real w;
- VALUE rb_x;
- real *x;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
-
- integer ldt;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x = NumRu::Lapack.slaqtr( ltran, lreal, t, b, w, x)\n or\n NumRu::Lapack.slaqtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLAQTR solves the real quasi-triangular system\n*\n* op(T)*p = scale*c, if LREAL = .TRUE.\n*\n* or the complex quasi-triangular systems\n*\n* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.\n*\n* in real arithmetic, where T is upper quasi-triangular.\n* If LREAL = .FALSE., then the first diagonal block of T must be\n* 1 by 1, B is the specially structured matrix\n*\n* B = [ b(1) b(2) ... b(n) ]\n* [ w ]\n* [ w ]\n* [ . ]\n* [ w ]\n*\n* op(A) = A or A', A' denotes the conjugate transpose of\n* matrix A.\n*\n* On input, X = [ c ]. On output, X = [ p ].\n* [ d ] [ q ]\n*\n* This subroutine is designed for the condition number estimation\n* in routine STRSNA.\n*\n\n* Arguments\n* =========\n*\n* LTRAN (input) LOGICAL\n* On entry, LTRAN specifies the option of conjugate transpose:\n* = .FALSE., op(T+i*B) = T+i*B,\n* = .TRUE., op(T+i*B) = (T+i*B)'.\n*\n* LREAL (input) LOGICAL\n* On entry, LREAL specifies the input matrix structure:\n* = .FALSE., the input is complex\n* = .TRUE., the input is real\n*\n* N (input) INTEGER\n* On entry, N specifies the order of T+i*B. N >= 0.\n*\n* T (input) REAL array, dimension (LDT,N)\n* On entry, T contains a matrix in Schur canonical form.\n* If LREAL = .FALSE., then the first diagonal block of T must\n* be 1 by 1.\n*\n* LDT (input) INTEGER\n* The leading dimension of the matrix T. LDT >= max(1,N).\n*\n* B (input) REAL array, dimension (N)\n* On entry, B contains the elements to form the matrix\n* B as described above.\n* If LREAL = .TRUE., B is not referenced.\n*\n* W (input) REAL\n* On entry, W is the diagonal element of the matrix B.\n* If LREAL = .TRUE., W is not referenced.\n*\n* SCALE (output) REAL\n* On exit, SCALE is the scale factor.\n*\n* X (input/output) REAL array, dimension (2*N)\n* On entry, X contains the right hand side of the system.\n* On exit, X is overwritten by the solution.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: the some diagonal 1 by 1 block has been perturbed by\n* a small number SMIN to keep nonsingularity.\n* 2: the some diagonal 2 by 2 block has been perturbed by\n* a small number in SLALN2 to keep nonsingularity.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_ltran = argv[0];
- rb_lreal = argv[1];
- rb_t = argv[2];
- rb_b = argv[3];
- rb_w = argv[4];
- rb_x = argv[5];
-
- w = (real)NUM2DBL(rb_w);
- lreal = (rb_lreal == Qtrue);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (3th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- ltran = (rb_ltran == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 1)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 1 of t");
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 2*n);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 2*n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (n));
-
- slaqtr_(<ran, &lreal, &n, t, &ldt, b, &w, &scale, x, work, &info);
-
- free(work);
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_scale, rb_info, rb_x);
-}
-
-void
-init_lapack_slaqtr(VALUE mLapack){
- rb_define_module_function(mLapack, "slaqtr", rb_slaqtr, -1);
-}
diff --git a/slar1v.c b/slar1v.c
deleted file mode 100644
index 2cf599a..0000000
--- a/slar1v.c
+++ /dev/null
@@ -1,154 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slar1v_(integer *n, integer *b1, integer *bn, real *lambda, real *d, real *l, real *ld, real *lld, real *pivmin, real *gaptol, real *z, logical *wantnc, integer *negcnt, real *ztz, real *mingma, integer *r, integer *isuppz, real *nrminv, real *resid, real *rqcorr, real *work);
-
-static VALUE
-rb_slar1v(int argc, VALUE *argv, VALUE self){
- VALUE rb_b1;
- integer b1;
- VALUE rb_bn;
- integer bn;
- VALUE rb_lambda;
- real lambda;
- VALUE rb_d;
- real *d;
- VALUE rb_l;
- real *l;
- VALUE rb_ld;
- real *ld;
- VALUE rb_lld;
- real *lld;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_gaptol;
- real gaptol;
- VALUE rb_z;
- real *z;
- VALUE rb_wantnc;
- logical wantnc;
- VALUE rb_r;
- integer r;
- VALUE rb_negcnt;
- integer negcnt;
- VALUE rb_ztz;
- real ztz;
- VALUE rb_mingma;
- real mingma;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_nrminv;
- real nrminv;
- VALUE rb_resid;
- real resid;
- VALUE rb_rqcorr;
- real rqcorr;
- VALUE rb_z_out__;
- real *z_out__;
- real *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.slar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r)\n or\n NumRu::Lapack.slar1v # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAR1V( 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* SLAR1V 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) REAL \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) REAL 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) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D.\n*\n* LD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*D(i).\n*\n* LLD (input) REAL array, dimension (N-1)\n* The n-1 elements L(i)*L(i)*D(i).\n*\n* PIVMIN (input) REAL \n* The minimum pivot in the Sturm sequence.\n*\n* GAPTOL (input) REAL \n* Tolerance that indicates when eigenvector entries are negligible\n* w.r.t. their contribution to the residual.\n*\n* Z (input/output) REAL 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) REAL \n* The square of the 2-norm of Z.\n*\n* MINGMA (output) REAL \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) REAL \n* NRMINV = 1/SQRT( ZTZ )\n*\n* RESID (output) REAL \n* The residual of the FP vector.\n* RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n* RQCORR (output) REAL \n* The Rayleigh Quotient correction to LAMBDA.\n* RQCORR = MINGMA*TMP\n*\n* WORK (workspace) REAL 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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_b1 = argv[0];
- rb_bn = argv[1];
- rb_lambda = argv[2];
- rb_d = argv[3];
- rb_l = argv[4];
- rb_ld = argv[5];
- rb_lld = argv[6];
- rb_pivmin = argv[7];
- rb_gaptol = argv[8];
- rb_z = argv[9];
- rb_wantnc = argv[10];
- rb_r = argv[11];
-
- pivmin = (real)NUM2DBL(rb_pivmin);
- bn = NUM2INT(rb_bn);
- lambda = (real)NUM2DBL(rb_lambda);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (10th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- wantnc = (rb_wantnc == Qtrue);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- r = NUM2INT(rb_r);
- gaptol = (real)NUM2DBL(rb_gaptol);
- b1 = NUM2INT(rb_b1);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_SFLOAT)
- rb_lld = na_change_type(rb_lld, NA_SFLOAT);
- lld = NA_PTR_TYPE(rb_lld, real*);
- if (!NA_IsNArray(rb_ld))
- rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
- if (NA_RANK(rb_ld) != 1)
- rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
- if (NA_TYPE(rb_ld) != NA_SFLOAT)
- rb_ld = na_change_type(rb_ld, NA_SFLOAT);
- ld = NA_PTR_TYPE(rb_ld, real*);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (5th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
- if (NA_TYPE(rb_l) != NA_SFLOAT)
- rb_l = na_change_type(rb_l, NA_SFLOAT);
- l = NA_PTR_TYPE(rb_l, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(real, (4*n));
-
- slar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);
-
- free(work);
- rb_negcnt = INT2NUM(negcnt);
- rb_ztz = rb_float_new((double)ztz);
- rb_mingma = rb_float_new((double)mingma);
- rb_nrminv = rb_float_new((double)nrminv);
- rb_resid = rb_float_new((double)resid);
- rb_rqcorr = rb_float_new((double)rqcorr);
- rb_r = INT2NUM(r);
- return rb_ary_new3(9, rb_negcnt, rb_ztz, rb_mingma, rb_isuppz, rb_nrminv, rb_resid, rb_rqcorr, rb_z, rb_r);
-}
-
-void
-init_lapack_slar1v(VALUE mLapack){
- rb_define_module_function(mLapack, "slar1v", rb_slar1v, -1);
-}
diff --git a/slar2v.c b/slar2v.c
deleted file mode 100644
index 5aabc5d..0000000
--- a/slar2v.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slar2v_(integer *n, real *x, real *y, real *z, integer *incx, real *c, real *s, integer *incc);
-
-static VALUE
-rb_slar2v(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- real *x;
- VALUE rb_y;
- real *y;
- VALUE rb_z;
- real *z;
- VALUE rb_incx;
- integer incx;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- real *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_y_out__;
- real *y_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.slar2v( n, x, y, z, incx, c, s, incc)\n or\n NumRu::Lapack.slar2v # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n* Purpose\n* =======\n*\n* SLAR2V applies a vector of real plane rotations from both sides to\n* a sequence of 2-by-2 real symmetric matrices, defined by the elements\n* of the vectors x, y and z. For i = 1,2,...,n\n*\n* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )\n* ( z(i) y(i) ) ( -s(i) c(i) ) ( 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) REAL array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCX)\n* The vector y.\n*\n* Z (input/output) REAL array,\n* 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) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) REAL 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 REAL CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_y = argv[2];
- rb_z = argv[3];
- rb_incx = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- n = NUM2INT(rb_n);
- incc = NUM2INT(rb_incc);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (3th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- slar2v_(&n, x, y, z, &incx, c, s, &incc);
-
- return rb_ary_new3(3, rb_x, rb_y, rb_z);
-}
-
-void
-init_lapack_slar2v(VALUE mLapack){
- rb_define_module_function(mLapack, "slar2v", rb_slar2v, -1);
-}
diff --git a/slarf.c b/slarf.c
deleted file mode 100644
index b53df60..0000000
--- a/slarf.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarf_(char *side, integer *m, integer *n, real *v, integer *incv, real *tau, real *c, integer *ldc, real *work);
-
-static VALUE
-rb_slarf(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- real *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- real tau;
- VALUE rb_c;
- real *c;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarf( side, m, v, incv, tau, c)\n or\n NumRu::Lapack.slarf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* SLARF applies a real elementary reflector H to a real m by n matrix\n* C, from either the left or the right. H is represented in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) REAL array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) REAL\n* The value tau in the representation of H.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_v = argv[2];
- rb_incv = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- tau = (real)NUM2DBL(rb_tau);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (3th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- slarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_slarf(VALUE mLapack){
- rb_define_module_function(mLapack, "slarf", rb_slarf, -1);
-}
diff --git a/slarfb.c b/slarfb.c
deleted file mode 100644
index 3a1bcd2..0000000
--- a/slarfb.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, real *v, integer *ldv, real *t, integer *ldt, real *c, integer *ldc, real *work, integer *ldwork);
-
-static VALUE
-rb_slarfb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- real *v;
- VALUE rb_t;
- real *t;
- VALUE rb_c;
- real *c;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer ldv;
- integer k;
- integer ldt;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarfb( side, trans, direct, storev, m, v, t, c)\n or\n NumRu::Lapack.slarfb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* SLARFB applies a real block reflector H or its transpose H' to a\n* real m by n matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'T': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) REAL array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) REAL array, dimension (LDT,K)\n* The triangular k by k matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_v = argv[5];
- rb_t = argv[6];
- rb_c = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- k = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- direct = StringValueCStr(rb_direct)[0];
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != k)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of v");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (ldwork)*(k));
-
- slarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_slarfb(VALUE mLapack){
- rb_define_module_function(mLapack, "slarfb", rb_slarfb, -1);
-}
diff --git a/slarfg.c b/slarfg.c
deleted file mode 100644
index 0afec86..0000000
--- a/slarfg.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarfg_(integer *n, real *alpha, real *x, integer *incx, real *tau);
-
-static VALUE
-rb_slarfg(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- real tau;
- VALUE rb_x_out__;
- real *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.slarfg( n, alpha, x, incx)\n or\n NumRu::Lapack.slarfg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* SLARFG generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, and x is an (n-1)-element real\n* vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n* Otherwise 1 <= tau <= 2.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) REAL\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) REAL array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) REAL\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha = (real)NUM2DBL(rb_alpha);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- slarfg_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_float_new((double)tau);
- rb_alpha = rb_float_new((double)alpha);
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_slarfg(VALUE mLapack){
- rb_define_module_function(mLapack, "slarfg", rb_slarfg, -1);
-}
diff --git a/slarfgp.c b/slarfgp.c
deleted file mode 100644
index d778c32..0000000
--- a/slarfgp.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarfgp_(integer *n, real *alpha, real *x, integer *incx, real *tau);
-
-static VALUE
-rb_slarfgp(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- real tau;
- VALUE rb_x_out__;
- real *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.slarfgp( n, alpha, x, incx)\n or\n NumRu::Lapack.slarfgp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* SLARFGP generates a real elementary reflector H of order n, such\n* that\n*\n* H * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is non-negative, and x is\n* an (n-1)-element real vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a real scalar and v is a real (n-1)-element\n* vector.\n*\n* If the elements of x are all zero, then tau = 0 and H is taken to be\n* the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) REAL\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) REAL array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) REAL\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha = (real)NUM2DBL(rb_alpha);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- slarfgp_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_float_new((double)tau);
- rb_alpha = rb_float_new((double)alpha);
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_slarfgp(VALUE mLapack){
- rb_define_module_function(mLapack, "slarfgp", rb_slarfgp, -1);
-}
diff --git a/slarft.c b/slarft.c
deleted file mode 100644
index 9b5aaaa..0000000
--- a/slarft.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarft_(char *direct, char *storev, integer *n, integer *k, real *v, integer *ldv, real *tau, real *t, integer *ldt);
-
-static VALUE
-rb_slarft(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- real *v;
- VALUE rb_tau;
- real *tau;
- VALUE rb_t;
- real *t;
- VALUE rb_v_out__;
- real *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.slarft( direct, storev, n, v, tau)\n or\n NumRu::Lapack.slarft # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* SLARFT forms the triangular factor T of a real block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) REAL array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) REAL array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, real*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- slarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_slarft(VALUE mLapack){
- rb_define_module_function(mLapack, "slarft", rb_slarft, -1);
-}
diff --git a/slarfx.c b/slarfx.c
deleted file mode 100644
index 544aaae..0000000
--- a/slarfx.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarfx_(char *side, integer *m, integer *n, real *v, real *tau, real *c, integer *ldc, real *work);
-
-static VALUE
-rb_slarfx(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_v;
- real *v;
- VALUE rb_tau;
- real tau;
- VALUE rb_c;
- real *c;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarfx( side, v, tau, c)\n or\n NumRu::Lapack.slarfx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* SLARFX applies a real elementary reflector H to a real m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) REAL array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) REAL\n* The value tau in the representation of H.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= (1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_side = argv[0];
- rb_v = argv[1];
- rb_tau = argv[2];
- rb_c = argv[3];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (2th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- tau = (real)NUM2DBL(rb_tau);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- slarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_slarfx(VALUE mLapack){
- rb_define_module_function(mLapack, "slarfx", rb_slarfx, -1);
-}
diff --git a/slargv.c b/slargv.c
deleted file mode 100644
index 4ab9586..0000000
--- a/slargv.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slargv_(integer *n, real *x, integer *incx, real *y, integer *incy, real *c, integer *incc);
-
-static VALUE
-rb_slargv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_incc;
- integer incc;
- VALUE rb_c;
- real *c;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_y_out__;
- real *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.slargv( n, x, incx, y, incy, incc)\n or\n NumRu::Lapack.slargv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* SLARGV generates a vector of real plane rotations, determined by\n* elements of the real vectors x and y. For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( a(i) )\n* ( -s(i) c(i) ) ( y(i) ) = ( 0 )\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) REAL array,\n* dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_incc = argv[5];
-
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incc;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- slargv_(&n, x, &incx, y, &incy, c, &incc);
-
- return rb_ary_new3(3, rb_c, rb_x, rb_y);
-}
-
-void
-init_lapack_slargv(VALUE mLapack){
- rb_define_module_function(mLapack, "slargv", rb_slargv, -1);
-}
diff --git a/slarnv.c b/slarnv.c
deleted file mode 100644
index 50f170d..0000000
--- a/slarnv.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarnv_(integer *idist, integer *iseed, integer *n, real *x);
-
-static VALUE
-rb_slarnv(int argc, VALUE *argv, VALUE self){
- VALUE rb_idist;
- integer idist;
- VALUE rb_iseed;
- integer *iseed;
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- real *x;
- VALUE rb_iseed_out__;
- integer *iseed_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.slarnv( idist, iseed, n)\n or\n NumRu::Lapack.slarnv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* SLARNV returns a vector of n random real numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: uniform (0,1)\n* = 2: uniform (-1,1)\n* = 3: normal (0,1)\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) REAL array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine SLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_idist = argv[0];
- rb_iseed = argv[1];
- rb_n = argv[2];
-
- n = NUM2INT(rb_n);
- idist = NUM2INT(rb_idist);
- if (!NA_IsNArray(rb_iseed))
- rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
- if (NA_RANK(rb_iseed) != 1)
- rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iseed) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
- if (NA_TYPE(rb_iseed) != NA_LINT)
- rb_iseed = na_change_type(rb_iseed, NA_LINT);
- iseed = NA_PTR_TYPE(rb_iseed, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 4;
- rb_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iseed_out__ = NA_PTR_TYPE(rb_iseed_out__, integer*);
- MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rb_iseed));
- rb_iseed = rb_iseed_out__;
- iseed = iseed_out__;
-
- slarnv_(&idist, iseed, &n, x);
-
- return rb_ary_new3(2, rb_x, rb_iseed);
-}
-
-void
-init_lapack_slarnv(VALUE mLapack){
- rb_define_module_function(mLapack, "slarnv", rb_slarnv, -1);
-}
diff --git a/slarra.c b/slarra.c
deleted file mode 100644
index b3f73e4..0000000
--- a/slarra.c
+++ /dev/null
@@ -1,105 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarra_(integer *n, real *d, real *e, real *e2, real *spltol, real *tnrm, integer *nsplit, integer *isplit, integer *info);
-
-static VALUE
-rb_slarra(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_e2;
- real *e2;
- VALUE rb_spltol;
- real spltol;
- VALUE rb_tnrm;
- real tnrm;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_info;
- integer info;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_e2_out__;
- real *e2_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n nsplit, isplit, info, e, e2 = NumRu::Lapack.slarra( d, e, e2, spltol, tnrm)\n or\n NumRu::Lapack.slarra # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n* Purpose\n* =======\n*\n* Compute the splitting points with threshold SPLTOL.\n* SLARRA sets any \"small\" off-diagonal elements to zero.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n* are set to zero, the other entries of E are untouched.\n*\n* E2 (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* SPLTOL (input) REAL \n* The threshold for splitting. Two criteria can be used:\n* SPLTOL<0 : criterion based on absolute off-diagonal value\n* SPLTOL>0 : criterion that preserves relative accuracy\n*\n* TNRM (input) REAL \n* The norm of the matrix.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_e2 = argv[2];
- rb_spltol = argv[3];
- rb_tnrm = argv[4];
-
- tnrm = (real)NUM2DBL(rb_tnrm);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (3th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e2);
- if (NA_TYPE(rb_e2) != NA_SFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_SFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, real*);
- spltol = (real)NUM2DBL(rb_spltol);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e2");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of e2");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e2_out__ = NA_PTR_TYPE(rb_e2_out__, real*);
- MEMCPY(e2_out__, e2, real, NA_TOTAL(rb_e2));
- rb_e2 = rb_e2_out__;
- e2 = e2_out__;
-
- slarra_(&n, d, e, e2, &spltol, &tnrm, &nsplit, isplit, &info);
-
- rb_nsplit = INT2NUM(nsplit);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_nsplit, rb_isplit, rb_info, rb_e, rb_e2);
-}
-
-void
-init_lapack_slarra(VALUE mLapack){
- rb_define_module_function(mLapack, "slarra", rb_slarra, -1);
-}
diff --git a/slarrb.c b/slarrb.c
deleted file mode 100644
index 3b2a544..0000000
--- a/slarrb.c
+++ /dev/null
@@ -1,159 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrb_(integer *n, real *d, real *lld, integer *ifirst, integer *ilast, real *rtol1, real *rtol2, integer *offset, real *w, real *wgap, real *werr, real *work, integer *iwork, real *pivmin, real *spdiam, integer *twist, integer *info);
-
-static VALUE
-rb_slarrb(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_lld;
- real *lld;
- VALUE rb_ifirst;
- integer ifirst;
- VALUE rb_ilast;
- integer ilast;
- VALUE rb_rtol1;
- real rtol1;
- VALUE rb_rtol2;
- real rtol2;
- VALUE rb_offset;
- integer offset;
- VALUE rb_w;
- real *w;
- VALUE rb_wgap;
- real *wgap;
- VALUE rb_werr;
- real *werr;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_spdiam;
- real spdiam;
- VALUE rb_twist;
- integer twist;
- VALUE rb_info;
- integer info;
- VALUE rb_w_out__;
- real *w_out__;
- VALUE rb_wgap_out__;
- real *wgap_out__;
- VALUE rb_werr_out__;
- real *werr_out__;
- real *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, w, wgap, werr = NumRu::Lapack.slarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist)\n or\n NumRu::Lapack.slarrb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n* Purpose\n* =======\n*\n* Given the relatively robust representation(RRR) L D L^T, SLARRB\n* does \"limited\" bisection to refine the eigenvalues of L D L^T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses and their gaps are input in WERR\n* and WGAP, respectively. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* LLD (input) REAL array, dimension (N-1)\n* The (N-1) elements L(i)*L(i)*D(i).\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n* where GAP is the (estimated) distance to the nearest\n* eigenvalue.\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) REAL array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST throug\n* ILAST.\n* On output, these estimates are refined.\n*\n* WGAP (input/output) REAL array, dimension (N-1)\n* On input, the (estimated) gaps between consecutive\n* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n* then WGAP(IFIRST-OFFSET) must be set to ZERO.\n* On output, these gaps are refined.\n*\n* WERR (input/output) REAL array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) REAL\n* The minimum pivot in the Sturm sequence.\n*\n* SPDIAM (input) REAL\n* The spectral diameter of the matrix.\n*\n* TWIST (input) INTEGER\n* The twist index for the twisted factorization that is used\n* for the negcount.\n* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n*\n* INFO (output) INTEGER\n* Error flag.\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 (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_d = argv[0];
- rb_lld = argv[1];
- rb_ifirst = argv[2];
- rb_ilast = argv[3];
- rb_rtol1 = argv[4];
- rb_rtol2 = argv[5];
- rb_offset = argv[6];
- rb_w = argv[7];
- rb_wgap = argv[8];
- rb_werr = argv[9];
- rb_pivmin = argv[10];
- rb_spdiam = argv[11];
- rb_twist = argv[12];
-
- ilast = NUM2INT(rb_ilast);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (8th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- rtol2 = (real)NUM2DBL(rb_rtol2);
- spdiam = (real)NUM2DBL(rb_spdiam);
- offset = NUM2INT(rb_offset);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- pivmin = (real)NUM2DBL(rb_pivmin);
- twist = NUM2INT(rb_twist);
- rtol1 = (real)NUM2DBL(rb_rtol1);
- ifirst = NUM2INT(rb_ifirst);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (10th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_SFLOAT)
- rb_werr = na_change_type(rb_werr, NA_SFLOAT);
- werr = NA_PTR_TYPE(rb_werr, real*);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_SFLOAT)
- rb_lld = na_change_type(rb_lld, NA_SFLOAT);
- lld = NA_PTR_TYPE(rb_lld, real*);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (9th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", n-1);
- if (NA_TYPE(rb_wgap) != NA_SFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_SFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, real*);
- MEMCPY(w_out__, w, real, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, real*);
- MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, real*);
- MEMCPY(werr_out__, werr, real, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- work = ALLOC_N(real, (2*n));
- iwork = ALLOC_N(integer, (2*n));
-
- slarrb_(&n, d, lld, &ifirst, &ilast, &rtol1, &rtol2, &offset, w, wgap, werr, work, iwork, &pivmin, &spdiam, &twist, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_w, rb_wgap, rb_werr);
-}
-
-void
-init_lapack_slarrb(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrb", rb_slarrb, -1);
-}
diff --git a/slarrc.c b/slarrc.c
deleted file mode 100644
index f1dd6a7..0000000
--- a/slarrc.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrc_(char *jobt, integer *n, real *vl, real *vu, real *d, real *e, real *pivmin, integer *eigcnt, integer *lcnt, integer *rcnt, integer *info);
-
-static VALUE
-rb_slarrc(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobt;
- char jobt;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_eigcnt;
- integer eigcnt;
- VALUE rb_lcnt;
- integer lcnt;
- VALUE rb_rcnt;
- integer rcnt;
- VALUE rb_info;
- integer info;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n eigcnt, lcnt, rcnt, info = NumRu::Lapack.slarrc( jobt, vl, vu, d, e, pivmin)\n or\n NumRu::Lapack.slarrc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n* Purpose\n* =======\n*\n* Find the number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n* if JOBT = 'L'.\n*\n\n* Arguments\n* =========\n*\n* JOBT (input) CHARACTER*1\n* = 'T': Compute Sturm count for matrix T.\n* = 'L': Compute Sturm count for matrix L D L^T.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* The lower and upper bounds for the eigenvalues.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n* JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n*\n* E (input) DOUBLE PRECISION array, dimension (N)\n* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n*\n* PIVMIN (input) REAL\n* The minimum pivot in the Sturm sequence for T.\n*\n* EIGCNT (output) INTEGER\n* The number of eigenvalues of the symmetric tridiagonal matrix T\n* that are in the interval (VL,VU]\n*\n* LCNT (output) INTEGER\n* RCNT (output) INTEGER\n* The left and right negcounts of the interval.\n*\n* INFO (output) INTEGER\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobt = argv[0];
- rb_vl = argv[1];
- rb_vu = argv[2];
- rb_d = argv[3];
- rb_e = argv[4];
- rb_pivmin = argv[5];
-
- vl = (real)NUM2DBL(rb_vl);
- jobt = StringValueCStr(rb_jobt)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (5th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- vu = (real)NUM2DBL(rb_vu);
- pivmin = (real)NUM2DBL(rb_pivmin);
-
- slarrc_(&jobt, &n, &vl, &vu, d, e, &pivmin, &eigcnt, &lcnt, &rcnt, &info);
-
- rb_eigcnt = INT2NUM(eigcnt);
- rb_lcnt = INT2NUM(lcnt);
- rb_rcnt = INT2NUM(rcnt);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_eigcnt, rb_lcnt, rb_rcnt, rb_info);
-}
-
-void
-init_lapack_slarrc(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrc", rb_slarrc, -1);
-}
diff --git a/slarrd.c b/slarrd.c
deleted file mode 100644
index 013aa41..0000000
--- a/slarrd.c
+++ /dev/null
@@ -1,171 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrd_(char *range, char *order, integer *n, real *vl, real *vu, integer *il, integer *iu, real *gers, real *reltol, real *d, real *e, real *e2, real *pivmin, integer *nsplit, integer *isplit, integer *m, real *w, real *werr, real *wl, real *wu, integer *iblock, integer *indexw, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slarrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_range;
- char range;
- VALUE rb_order;
- char order;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_gers;
- real *gers;
- VALUE rb_reltol;
- real reltol;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_e2;
- real *e2;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_werr;
- real *werr;
- VALUE rb_wl;
- real wl;
- VALUE rb_wu;
- real wu;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.slarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit)\n or\n NumRu::Lapack.slarrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLARRD computes the eigenvalues of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from SSTEMR.\n* The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) REAL \n* VU (input) REAL \n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* GERS (input) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* RELTOL (input) REAL \n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) REAL array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) REAL \n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* NSPLIT (input) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* W (output) REAL array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalue approximations. SLARRD computes an interval\n* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n* approximation is given as the interval midpoint\n* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n* WERR(j) = abs( a_j - b_j)/2\n*\n* WERR (output) REAL array, dimension (N)\n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* WL (output) REAL \n* WU (output) REAL \n* The interval (WL, WU] contains all the wanted eigenvalues.\n* If RANGE='V', then WL=VL and WU=VU.\n* If RANGE='A', then WL and WU are the global Gerschgorin bounds\n* on the spectrum.\n* If RANGE='I', then WL and WU are computed by SLAEBZ from the\n* index range specified.\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (SLARRD may use the remaining N-M elements as\n* workspace.)\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n* i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE REAL , default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n* Based on contributions by\n* W. Kahan, University of California, Berkeley, USA\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\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_range = argv[0];
- rb_order = argv[1];
- rb_vl = argv[2];
- rb_vu = argv[3];
- rb_il = argv[4];
- rb_iu = argv[5];
- rb_gers = argv[6];
- rb_reltol = argv[7];
- rb_d = argv[8];
- rb_e = argv[9];
- rb_e2 = argv[10];
- rb_pivmin = argv[11];
- rb_nsplit = argv[12];
- rb_isplit = argv[13];
-
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- pivmin = (real)NUM2DBL(rb_pivmin);
- vu = (real)NUM2DBL(rb_vu);
- nsplit = NUM2INT(rb_nsplit);
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (9th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (14th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- range = StringValueCStr(rb_range)[0];
- order = StringValueCStr(rb_order)[0];
- reltol = (real)NUM2DBL(rb_reltol);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (10th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- if (!NA_IsNArray(rb_gers))
- rb_raise(rb_eArgError, "gers (7th argument) must be NArray");
- if (NA_RANK(rb_gers) != 1)
- rb_raise(rb_eArgError, "rank of gers (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_gers) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
- if (NA_TYPE(rb_gers) != NA_SFLOAT)
- rb_gers = na_change_type(rb_gers, NA_SFLOAT);
- gers = NA_PTR_TYPE(rb_gers, real*);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (11th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e2) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
- if (NA_TYPE(rb_e2) != NA_SFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_SFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- werr = NA_PTR_TYPE(rb_werr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (3*n));
-
- slarrd_(&range, &order, &n, &vl, &vu, &il, &iu, gers, &reltol, d, e, e2, &pivmin, &nsplit, isplit, &m, w, werr, &wl, &wu, iblock, indexw, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_wl = rb_float_new((double)wl);
- rb_wu = rb_float_new((double)wu);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_werr, rb_wl, rb_wu, rb_iblock, rb_indexw, rb_info);
-}
-
-void
-init_lapack_slarrd(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrd", rb_slarrd, -1);
-}
diff --git a/slarre.c b/slarre.c
deleted file mode 100644
index ac5a3a9..0000000
--- a/slarre.c
+++ /dev/null
@@ -1,202 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarre_(char *range, integer *n, real *vl, real *vu, integer *il, integer *iu, real *d, real *e, real *e2, real *rtol1, real *rtol2, real *spltol, integer *nsplit, integer *isplit, integer *m, real *w, real *werr, real *wgap, integer *iblock, integer *indexw, real *gers, real *pivmin, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slarre(int argc, VALUE *argv, VALUE self){
- VALUE rb_range;
- char range;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_e2;
- real *e2;
- VALUE rb_rtol1;
- real rtol1;
- VALUE rb_rtol2;
- real rtol2;
- VALUE rb_spltol;
- real spltol;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_werr;
- real *werr;
- VALUE rb_wgap;
- real *wgap;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_gers;
- real *gers;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_e2_out__;
- real *e2_out__;
- real *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.slarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol)\n or\n NumRu::Lapack.slarre # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* To find the desired eigenvalues of a given real symmetric\n* tridiagonal matrix T, SLARRE sets any \"small\" off-diagonal\n* elements to zero, and for each unreduced block T_i, it finds\n* (a) a suitable shift at one end of the block's spectrum,\n* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n* (c) eigenvalues of each L_i D_i L_i^T.\n* The representations and eigenvalues found are then used by\n* SSTEMR to compute the eigenvectors of T.\n* The accuracy varies depending on whether bisection is used to\n* find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to\n* conpute all and then discard any unwanted one.\n* As an added benefit, SLARRE also outputs the n\n* Gerschgorin intervals for the matrices L_i D_i L_i^T.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* VL (input/output) REAL \n* VU (input/output) REAL \n* If RANGE='V', the lower and upper bounds for the eigenvalues.\n* Eigenvalues less than or equal to VL, or greater than VU,\n* will not be returned. VL < VU.\n* If RANGE='I' or ='A', SLARRE computes bounds on the desired\n* part of the spectrum.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal\n* matrix T.\n* On exit, the N diagonal elements of the diagonal\n* matrices D_i.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) need not be set.\n* On exit, E contains the subdiagonal elements of the unit\n* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, contain the base points sigma_i on output.\n*\n* E2 (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the SQUARES of the\n* subdiagonal elements of the tridiagonal matrix T;\n* E2(N) need not be set.\n* On exit, the entries E2( ISPLIT( I ) ),\n* 1 <= I <= NSPLIT, have been set to zero\n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* SPLTOL (input) REAL \n* The threshold for splitting.\n*\n* NSPLIT (output) INTEGER\n* The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n* M (output) INTEGER\n* The total number of eigenvalues (of all L_i D_i L_i^T)\n* found.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the eigenvalues. The\n* eigenvalues of each of the blocks, L_i D_i L_i^T, are\n* sorted in ascending order ( SLARRE may use the\n* remaining N-M elements as workspace).\n*\n* WERR (output) REAL array, dimension (N)\n* The error bound on the corresponding eigenvalue in W.\n*\n* WGAP (output) REAL array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n* The gap is only with respect to the eigenvalues of the same block\n* as each block has its own representation tree.\n* Exception: at the right end of a block we store the left gap\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (output) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n*\n* GERS (output) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)).\n*\n* PIVMIN (output) REAL\n* The minimum pivot in the Sturm sequence for T.\n*\n* WORK (workspace) REAL array, dimension (6*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n* Workspace.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: A problem occured in SLARRE.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in SLARRD.\n* = 2: No base representation could be found in MAXTRY iterations.\n* Increasing MAXTRY and recompilation might be a remedy.\n* =-3: Problem in SLARRB when computing the refined root\n* representation for SLASQ2.\n* =-4: Problem in SLARRB when preforming bisection on the\n* desired part of the spectrum.\n* =-5: Problem in SLASQ2.\n* =-6: Problem in SLASQ2.\n*\n\n* Further Details\n* The base representations are required to suffer very little\n* element growth and consequently define all their eigenvalues to\n* high relative accuracy.\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 (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_range = argv[0];
- rb_vl = argv[1];
- rb_vu = argv[2];
- rb_il = argv[3];
- rb_iu = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_e2 = argv[7];
- rb_rtol1 = argv[8];
- rb_rtol2 = argv[9];
- rb_spltol = argv[10];
-
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (8th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e2);
- if (NA_TYPE(rb_e2) != NA_SFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_SFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, real*);
- il = NUM2INT(rb_il);
- spltol = (real)NUM2DBL(rb_spltol);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e2");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of e2");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- range = StringValueCStr(rb_range)[0];
- rtol1 = (real)NUM2DBL(rb_rtol1);
- vu = (real)NUM2DBL(rb_vu);
- rtol2 = (real)NUM2DBL(rb_rtol2);
- {
- int shape[1];
- shape[0] = n;
- rb_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- werr = NA_PTR_TYPE(rb_werr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wgap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wgap = NA_PTR_TYPE(rb_wgap, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- {
- int shape[1];
- shape[0] = 2*n;
- rb_gers = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- gers = NA_PTR_TYPE(rb_gers, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e2_out__ = NA_PTR_TYPE(rb_e2_out__, real*);
- MEMCPY(e2_out__, e2, real, NA_TOTAL(rb_e2));
- rb_e2 = rb_e2_out__;
- e2 = e2_out__;
- work = ALLOC_N(real, (6*n));
- iwork = ALLOC_N(integer, (5*n));
-
- slarre_(&range, &n, &vl, &vu, &il, &iu, d, e, e2, &rtol1, &rtol2, &spltol, &nsplit, isplit, &m, w, werr, wgap, iblock, indexw, gers, &pivmin, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_nsplit = INT2NUM(nsplit);
- rb_m = INT2NUM(m);
- rb_pivmin = rb_float_new((double)pivmin);
- rb_info = INT2NUM(info);
- rb_vl = rb_float_new((double)vl);
- rb_vu = rb_float_new((double)vu);
- return rb_ary_new3(16, rb_nsplit, rb_isplit, rb_m, rb_w, rb_werr, rb_wgap, rb_iblock, rb_indexw, rb_gers, rb_pivmin, rb_info, rb_vl, rb_vu, rb_d, rb_e, rb_e2);
-}
-
-void
-init_lapack_slarre(VALUE mLapack){
- rb_define_module_function(mLapack, "slarre", rb_slarre, -1);
-}
diff --git a/slarrf.c b/slarrf.c
deleted file mode 100644
index 3c093f1..0000000
--- a/slarrf.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrf_(integer *n, real *d, real *l, real *ld, integer *clstrt, integer *clend, real *w, real *wgap, real *werr, real *spdiam, real *clgapl, real *clgapr, real *pivmin, real *sigma, real *dplus, real *lplus, real *work, integer *info);
-
-static VALUE
-rb_slarrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_l;
- real *l;
- VALUE rb_ld;
- real *ld;
- VALUE rb_clstrt;
- integer clstrt;
- VALUE rb_clend;
- integer clend;
- VALUE rb_w;
- real *w;
- VALUE rb_wgap;
- real *wgap;
- VALUE rb_werr;
- real *werr;
- VALUE rb_spdiam;
- real spdiam;
- VALUE rb_clgapl;
- real clgapl;
- VALUE rb_clgapr;
- real clgapr;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_sigma;
- real sigma;
- VALUE rb_dplus;
- real *dplus;
- VALUE rb_lplus;
- real *lplus;
- VALUE rb_info;
- integer info;
- VALUE rb_wgap_out__;
- real *wgap_out__;
- real *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sigma, dplus, lplus, info, wgap = NumRu::Lapack.slarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin)\n or\n NumRu::Lapack.slarrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial representation L D L^T and its cluster of close\n* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n* W( CLEND ), SLARRF finds a new relatively robust representation\n* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix (subblock, if the matrix splitted).\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D.\n*\n* L (input) REAL array, dimension (N-1)\n* The (N-1) subdiagonal elements of the unit bidiagonal\n* matrix L.\n*\n* LD (input) REAL array, dimension (N-1)\n* The (N-1) elements L(i)*D(i).\n*\n* CLSTRT (input) INTEGER\n* The index of the first eigenvalue in the cluster.\n*\n* CLEND (input) INTEGER\n* The index of the last eigenvalue in the cluster.\n*\n* W (input) REAL array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n* W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n* close eigenalues.\n*\n* WGAP (input/output) REAL array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* The separation from the right neighbor eigenvalue in W.\n*\n* WERR (input) REAL array, dimension\n* dimension is >= (CLEND-CLSTRT+1)\n* WERR contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue APPROXIMATION in W\n*\n* SPDIAM (input) REAL\n* estimate of the spectral diameter obtained from the\n* Gerschgorin intervals\n*\n* CLGAPL (input) REAL\n*\n* CLGAPR (input) REAL\n* absolute gap on each end of the cluster.\n* Set by the calling routine to protect against shifts too close\n* to eigenvalues outside the cluster.\n*\n* PIVMIN (input) REAL\n* The minimum pivot allowed in the Sturm sequence.\n*\n* SIGMA (output) REAL \n* The shift used to form L(+) D(+) L(+)^T.\n*\n* DPLUS (output) REAL array, dimension (N)\n* The N diagonal elements of the diagonal matrix D(+).\n*\n* LPLUS (output) REAL array, dimension (N-1)\n* The first (N-1) elements of LPLUS contain the subdiagonal\n* elements of the unit bidiagonal matrix L(+).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Workspace.\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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_d = argv[0];
- rb_l = argv[1];
- rb_ld = argv[2];
- rb_clstrt = argv[3];
- rb_clend = argv[4];
- rb_w = argv[5];
- rb_wgap = argv[6];
- rb_werr = argv[7];
- rb_spdiam = argv[8];
- rb_clgapl = argv[9];
- rb_clgapr = argv[10];
- rb_pivmin = argv[11];
-
- pivmin = (real)NUM2DBL(rb_pivmin);
- clgapl = (real)NUM2DBL(rb_clgapl);
- clend = NUM2INT(rb_clend);
- clgapr = (real)NUM2DBL(rb_clgapr);
- spdiam = (real)NUM2DBL(rb_spdiam);
- clstrt = NUM2INT(rb_clstrt);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_ld))
- rb_raise(rb_eArgError, "ld (3th argument) must be NArray");
- if (NA_RANK(rb_ld) != 1)
- rb_raise(rb_eArgError, "rank of ld (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
- if (NA_TYPE(rb_ld) != NA_SFLOAT)
- rb_ld = na_change_type(rb_ld, NA_SFLOAT);
- ld = NA_PTR_TYPE(rb_ld, real*);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != (clend-clstrt+1))
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be %d", clend-clstrt+1);
- if (NA_TYPE(rb_werr) != NA_SFLOAT)
- rb_werr = na_change_type(rb_werr, NA_SFLOAT);
- werr = NA_PTR_TYPE(rb_werr, real*);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (7th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != (clend-clstrt+1))
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", clend-clstrt+1);
- if (NA_TYPE(rb_wgap) != NA_SFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_SFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, real*);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (2th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
- if (NA_TYPE(rb_l) != NA_SFLOAT)
- rb_l = na_change_type(rb_l, NA_SFLOAT);
- l = NA_PTR_TYPE(rb_l, real*);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (6th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_w) != (clend-clstrt+1))
- rb_raise(rb_eRuntimeError, "shape 0 of w must be %d", clend-clstrt+1);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_dplus = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dplus = NA_PTR_TYPE(rb_dplus, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_lplus = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- lplus = NA_PTR_TYPE(rb_lplus, real*);
- {
- int shape[1];
- shape[0] = clend-clstrt+1;
- rb_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, real*);
- MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- work = ALLOC_N(real, (2*n));
-
- slarrf_(&n, d, l, ld, &clstrt, &clend, w, wgap, werr, &spdiam, &clgapl, &clgapr, &pivmin, &sigma, dplus, lplus, work, &info);
-
- free(work);
- rb_sigma = rb_float_new((double)sigma);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_sigma, rb_dplus, rb_lplus, rb_info, rb_wgap);
-}
-
-void
-init_lapack_slarrf(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrf", rb_slarrf, -1);
-}
diff --git a/slarrj.c b/slarrj.c
deleted file mode 100644
index 6ca18ee..0000000
--- a/slarrj.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrj_(integer *n, real *d, real *e2, integer *ifirst, integer *ilast, real *rtol, integer *offset, real *w, real *werr, real *work, integer *iwork, real *pivmin, real *spdiam, integer *info);
-
-static VALUE
-rb_slarrj(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e2;
- real *e2;
- VALUE rb_ifirst;
- integer ifirst;
- VALUE rb_ilast;
- integer ilast;
- VALUE rb_rtol;
- real rtol;
- VALUE rb_offset;
- integer offset;
- VALUE rb_w;
- real *w;
- VALUE rb_werr;
- real *werr;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_spdiam;
- real spdiam;
- VALUE rb_info;
- integer info;
- VALUE rb_w_out__;
- real *w_out__;
- VALUE rb_werr_out__;
- real *werr_out__;
- real *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, w, werr = NumRu::Lapack.slarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam)\n or\n NumRu::Lapack.slarrj # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n* Purpose\n* =======\n*\n* Given the initial eigenvalue approximations of T, SLARRJ\n* does bisection to refine the eigenvalues of T,\n* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n* guesses for these eigenvalues are input in W, the corresponding estimate\n* of the error in these guesses in WERR. During bisection, intervals\n* [left, right] are maintained by storing their mid-points and\n* semi-widths in the arrays W and WERR respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of T.\n*\n* E2 (input) REAL array, dimension (N-1)\n* The Squares of the (N-1) subdiagonal elements of T.\n*\n* IFIRST (input) INTEGER\n* The index of the first eigenvalue to be computed.\n*\n* ILAST (input) INTEGER\n* The index of the last eigenvalue to be computed.\n*\n* RTOL (input) REAL \n* Tolerance for the convergence of the bisection intervals.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n*\n* OFFSET (input) INTEGER\n* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n* through ILAST-OFFSET elements of these arrays are to be used.\n*\n* W (input/output) REAL array, dimension (N)\n* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n* estimates of the eigenvalues of L D L^T indexed IFIRST through\n* ILAST.\n* On output, these estimates are refined.\n*\n* WERR (input/output) REAL array, dimension (N)\n* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n* the errors in the estimates of the corresponding elements in W.\n* On output, these errors are refined.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (2*N)\n* Workspace.\n*\n* PIVMIN (input) REAL\n* The minimum pivot in the Sturm sequence for T.\n*\n* SPDIAM (input) REAL\n* The spectral diameter of T.\n*\n* INFO (output) INTEGER\n* Error flag.\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 (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_d = argv[0];
- rb_e2 = argv[1];
- rb_ifirst = argv[2];
- rb_ilast = argv[3];
- rb_rtol = argv[4];
- rb_offset = argv[5];
- rb_w = argv[6];
- rb_werr = argv[7];
- rb_pivmin = argv[8];
- rb_spdiam = argv[9];
-
- ilast = NUM2INT(rb_ilast);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (7th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- rtol = (real)NUM2DBL(rb_rtol);
- offset = NUM2INT(rb_offset);
- spdiam = (real)NUM2DBL(rb_spdiam);
- pivmin = (real)NUM2DBL(rb_pivmin);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_SFLOAT)
- rb_werr = na_change_type(rb_werr, NA_SFLOAT);
- werr = NA_PTR_TYPE(rb_werr, real*);
- ifirst = NUM2INT(rb_ifirst);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (2th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e2) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
- if (NA_TYPE(rb_e2) != NA_SFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_SFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, real*);
- MEMCPY(w_out__, w, real, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, real*);
- MEMCPY(werr_out__, werr, real, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- work = ALLOC_N(real, (2*n));
- iwork = ALLOC_N(integer, (2*n));
-
- slarrj_(&n, d, e2, &ifirst, &ilast, &rtol, &offset, w, werr, work, iwork, &pivmin, &spdiam, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_w, rb_werr);
-}
-
-void
-init_lapack_slarrj(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrj", rb_slarrj, -1);
-}
diff --git a/slarrk.c b/slarrk.c
deleted file mode 100644
index 419e86e..0000000
--- a/slarrk.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrk_(integer *n, integer *iw, real *gl, real *gu, real *d, real *e2, real *pivmin, real *reltol, real *w, real *werr, integer *info);
-
-static VALUE
-rb_slarrk(int argc, VALUE *argv, VALUE self){
- VALUE rb_iw;
- integer iw;
- VALUE rb_gl;
- real gl;
- VALUE rb_gu;
- real gu;
- VALUE rb_d;
- real *d;
- VALUE rb_e2;
- real *e2;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_reltol;
- real reltol;
- VALUE rb_w;
- real w;
- VALUE rb_werr;
- real werr;
- VALUE rb_info;
- integer info;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, werr, info = NumRu::Lapack.slarrk( iw, gl, gu, d, e2, pivmin, reltol)\n or\n NumRu::Lapack.slarrk # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n* Purpose\n* =======\n*\n* SLARRK computes one eigenvalue of a symmetric tridiagonal\n* matrix T to suitable accuracy. This is an auxiliary code to be\n* called from SSTEMR.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* IW (input) INTEGER\n* The index of the eigenvalues to be returned.\n*\n* GL (input) REAL \n* GU (input) REAL \n* An upper and a lower bound on the eigenvalue.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E2 (input) REAL array, dimension (N-1)\n* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n* PIVMIN (input) REAL \n* The minimum pivot allowed in the Sturm sequence for T.\n*\n* RELTOL (input) REAL \n* The minimum relative width of an interval. When an interval\n* is narrower than RELTOL times the larger (in\n* magnitude) endpoint, then it is considered to be\n* sufficiently small, i.e., converged. Note: this should\n* always be at least radix*machine epsilon.\n*\n* W (output) REAL \n*\n* WERR (output) REAL \n* The error bound on the corresponding eigenvalue approximation\n* in W.\n*\n* INFO (output) INTEGER\n* = 0: Eigenvalue converged\n* = -1: Eigenvalue did NOT converge\n*\n* Internal Parameters\n* ===================\n*\n* FUDGE REAL , default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_iw = argv[0];
- rb_gl = argv[1];
- rb_gu = argv[2];
- rb_d = argv[3];
- rb_e2 = argv[4];
- rb_pivmin = argv[5];
- rb_reltol = argv[6];
-
- pivmin = (real)NUM2DBL(rb_pivmin);
- gu = (real)NUM2DBL(rb_gu);
- iw = NUM2INT(rb_iw);
- gl = (real)NUM2DBL(rb_gl);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- reltol = (real)NUM2DBL(rb_reltol);
- if (!NA_IsNArray(rb_e2))
- rb_raise(rb_eArgError, "e2 (5th argument) must be NArray");
- if (NA_RANK(rb_e2) != 1)
- rb_raise(rb_eArgError, "rank of e2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e2) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
- if (NA_TYPE(rb_e2) != NA_SFLOAT)
- rb_e2 = na_change_type(rb_e2, NA_SFLOAT);
- e2 = NA_PTR_TYPE(rb_e2, real*);
-
- slarrk_(&n, &iw, &gl, &gu, d, e2, &pivmin, &reltol, &w, &werr, &info);
-
- rb_w = rb_float_new((double)w);
- rb_werr = rb_float_new((double)werr);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_w, rb_werr, rb_info);
-}
-
-void
-init_lapack_slarrk(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrk", rb_slarrk, -1);
-}
diff --git a/slarrr.c b/slarrr.c
deleted file mode 100644
index 8069c3c..0000000
--- a/slarrr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrr_(integer *n, real *d, real *e, integer *info);
-
-static VALUE
-rb_slarrr(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_info;
- integer info;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, e = NumRu::Lapack.slarrr( d, e)\n or\n NumRu::Lapack.slarrr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRR( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* Perform tests to decide whether the symmetric tridiagonal matrix T\n* warrants expensive computations which guarantee high relative accuracy\n* in the eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N > 0.\n*\n* D (input) REAL array, dimension (N)\n* The N diagonal elements of the tridiagonal matrix T.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the first (N-1) entries contain the subdiagonal\n* elements of the tridiagonal matrix T; E(N) is set to ZERO.\n*\n* INFO (output) INTEGER\n* INFO = 0(default) : the matrix warrants computations preserving\n* relative accuracy.\n* INFO = 1 : the matrix warrants computations guaranteeing\n* only absolute accuracy.\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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- slarrr_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_e);
-}
-
-void
-init_lapack_slarrr(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrr", rb_slarrr, -1);
-}
diff --git a/slarrv.c b/slarrv.c
deleted file mode 100644
index 297c36f..0000000
--- a/slarrv.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarrv_(integer *n, real *vl, real *vu, real *d, real *l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr, real *wgap, integer *iblock, integer *indexw, real *gers, real *z, integer *ldz, integer *isuppz, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slarrv(int argc, VALUE *argv, VALUE self){
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_d;
- real *d;
- VALUE rb_l;
- real *l;
- VALUE rb_pivmin;
- real pivmin;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_dol;
- integer dol;
- VALUE rb_dou;
- integer dou;
- VALUE rb_minrgp;
- real minrgp;
- VALUE rb_rtol1;
- real rtol1;
- VALUE rb_rtol2;
- real rtol2;
- VALUE rb_w;
- real *w;
- VALUE rb_werr;
- real *werr;
- VALUE rb_wgap;
- real *wgap;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_gers;
- real *gers;
- VALUE rb_z;
- real *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_l_out__;
- real *l_out__;
- VALUE rb_w_out__;
- real *w_out__;
- VALUE rb_werr_out__;
- real *werr_out__;
- VALUE rb_wgap_out__;
- real *wgap_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.slarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers)\n or\n NumRu::Lapack.slarrv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by SLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) REAL \n* VU (input) REAL \n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by SLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (input) REAL\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) REAL \n*\n* RTOL1 (input) REAL \n* RTOL2 (input) REAL \n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) REAL array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from SLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) REAL array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) REAL array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) REAL array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) REAL array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in SLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in SLARRB when refining a child's eigenvalues.\n* =-2: Problem in SLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in SLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 (argc != 18)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
- rb_vl = argv[0];
- rb_vu = argv[1];
- rb_d = argv[2];
- rb_l = argv[3];
- rb_pivmin = argv[4];
- rb_isplit = argv[5];
- rb_m = argv[6];
- rb_dol = argv[7];
- rb_dou = argv[8];
- rb_minrgp = argv[9];
- rb_rtol1 = argv[10];
- rb_rtol2 = argv[11];
- rb_w = argv[12];
- rb_werr = argv[13];
- rb_wgap = argv[14];
- rb_iblock = argv[15];
- rb_indexw = argv[16];
- rb_gers = argv[17];
-
- vl = (real)NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (13th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- dol = NUM2INT(rb_dol);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (4th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of w");
- if (NA_TYPE(rb_l) != NA_SFLOAT)
- rb_l = na_change_type(rb_l, NA_SFLOAT);
- l = NA_PTR_TYPE(rb_l, real*);
- pivmin = (real)NUM2DBL(rb_pivmin);
- dou = NUM2INT(rb_dou);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of w");
- if (NA_TYPE(rb_wgap) != NA_SFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_SFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, real*);
- m = NUM2INT(rb_m);
- minrgp = (real)NUM2DBL(rb_minrgp);
- rtol2 = (real)NUM2DBL(rb_rtol2);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_indexw))
- rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
- if (NA_RANK(rb_indexw) != 1)
- rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
- if (NA_SHAPE0(rb_indexw) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of w");
- if (NA_TYPE(rb_indexw) != NA_LINT)
- rb_indexw = na_change_type(rb_indexw, NA_LINT);
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_SFLOAT)
- rb_werr = na_change_type(rb_werr, NA_SFLOAT);
- werr = NA_PTR_TYPE(rb_werr, real*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- rtol1 = (real)NUM2DBL(rb_rtol1);
- vu = (real)NUM2DBL(rb_vu);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_gers))
- rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
- if (NA_RANK(rb_gers) != 1)
- rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_gers) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
- if (NA_TYPE(rb_gers) != NA_SFLOAT)
- rb_gers = na_change_type(rb_gers, NA_SFLOAT);
- gers = NA_PTR_TYPE(rb_gers, real*);
- ldz = n;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_l_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- l_out__ = NA_PTR_TYPE(rb_l_out__, real*);
- MEMCPY(l_out__, l, real, NA_TOTAL(rb_l));
- rb_l = rb_l_out__;
- l = l_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, real*);
- MEMCPY(w_out__, w, real, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, real*);
- MEMCPY(werr_out__, werr, real, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, real*);
- MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- work = ALLOC_N(real, (12*n));
- iwork = ALLOC_N(integer, (7*n));
-
- slarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_z, rb_isuppz, rb_info, rb_d, rb_l, rb_w, rb_werr, rb_wgap);
-}
-
-void
-init_lapack_slarrv(VALUE mLapack){
- rb_define_module_function(mLapack, "slarrv", rb_slarrv, -1);
-}
diff --git a/slarscl2.c b/slarscl2.c
deleted file mode 100644
index c4675b6..0000000
--- a/slarscl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarscl2_(integer *m, integer *n, real *d, real *x, integer *ldx);
-
-static VALUE
-rb_slarscl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_x;
- real *x;
- VALUE rb_x_out__;
- real *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.slarscl2( d, x)\n or\n NumRu::Lapack.slarscl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* SLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- slarscl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_slarscl2(VALUE mLapack){
- rb_define_module_function(mLapack, "slarscl2", rb_slarscl2, -1);
-}
diff --git a/slartg.c b/slartg.c
deleted file mode 100644
index fa6a15e..0000000
--- a/slartg.c
+++ /dev/null
@@ -1,42 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slartg_(real *f, real *g, real *cs, real *sn, real *r);
-
-static VALUE
-rb_slartg(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- real f;
- VALUE rb_g;
- real g;
- VALUE rb_cs;
- real cs;
- VALUE rb_sn;
- real sn;
- VALUE rb_r;
- real r;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.slartg( f, g)\n or\n NumRu::Lapack.slartg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* SLARTG generate a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the BLAS1 routine SROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n* floating point operations (saves work in SBDSQR when\n* there are zeros on the diagonal).\n*\n* If F exceeds G in magnitude, CS will be positive.\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The first component of vector to be rotated.\n*\n* G (input) REAL\n* The second component of vector to be rotated.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) REAL\n* The sine of the rotation.\n*\n* R (output) REAL\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
-
- f = (real)NUM2DBL(rb_f);
- g = (real)NUM2DBL(rb_g);
-
- slartg_(&f, &g, &cs, &sn, &r);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- rb_r = rb_float_new((double)r);
- return rb_ary_new3(3, rb_cs, rb_sn, rb_r);
-}
-
-void
-init_lapack_slartg(VALUE mLapack){
- rb_define_module_function(mLapack, "slartg", rb_slartg, -1);
-}
diff --git a/slartgp.c b/slartgp.c
deleted file mode 100644
index 11d44e9..0000000
--- a/slartgp.c
+++ /dev/null
@@ -1,42 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slartgp_(real *f, real *g, real *cs, real *sn, real *r);
-
-static VALUE
-rb_slartgp(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- real f;
- VALUE rb_g;
- real g;
- VALUE rb_cs;
- real cs;
- VALUE rb_sn;
- real sn;
- VALUE rb_r;
- real r;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.slartgp( f, g)\n or\n NumRu::Lapack.slartgp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTGP( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* SLARTGP generates a plane rotation so that\n*\n* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a slower, more accurate version of the Level 1 BLAS routine SROTG,\n* with the following other differences:\n* F and G are unchanged on return.\n* If G=0, then CS=(+/-)1 and SN=0.\n* If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n*\n* The sign is chosen so that R >= 0.\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The first component of vector to be rotated.\n*\n* G (input) REAL\n* The second component of vector to be rotated.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) REAL\n* The sine of the rotation.\n*\n* R (output) REAL\n* The nonzero component of the rotated vector.\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
-
- f = (real)NUM2DBL(rb_f);
- g = (real)NUM2DBL(rb_g);
-
- slartgp_(&f, &g, &cs, &sn, &r);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- rb_r = rb_float_new((double)r);
- return rb_ary_new3(3, rb_cs, rb_sn, rb_r);
-}
-
-void
-init_lapack_slartgp(VALUE mLapack){
- rb_define_module_function(mLapack, "slartgp", rb_slartgp, -1);
-}
diff --git a/slartgs.c b/slartgs.c
deleted file mode 100644
index a6704f4..0000000
--- a/slartgs.c
+++ /dev/null
@@ -1,43 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slartgs_(real *x, real *y, real *sigma, real *cs, real *sn);
-
-static VALUE
-rb_slartgs(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- real x;
- VALUE rb_y;
- real y;
- VALUE rb_sigma;
- real sigma;
- VALUE rb_cs;
- real cs;
- VALUE rb_sn;
- real sn;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn = NumRu::Lapack.slartgs( x, y, sigma)\n or\n NumRu::Lapack.slartgs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN )\n\n* Purpose\n* =======\n*\n* SLARTGS generates a plane rotation designed to introduce a bulge in\n* Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n* problem. X and Y are the top-row entries, and SIGMA is the shift.\n* The computed CS and SN define a plane rotation satisfying\n*\n* [ CS SN ] . [ X^2 - SIGMA ] = [ R ],\n* [ -SN CS ] [ X * Y ] [ 0 ]\n*\n* with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the\n* rotation is by PI/2.\n*\n\n* Arguments\n* =========\n*\n* X (input) REAL\n* The (1,1) entry of an upper bidiagonal matrix.\n*\n* Y (input) REAL\n* The (1,2) entry of an upper bidiagonal matrix.\n*\n* SIGMA (input) REAL\n* The shift.\n*\n* CS (output) REAL\n* The cosine of the rotation.\n*\n* SN (output) REAL\n* The sine of the rotation.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_sigma = argv[2];
-
- x = (real)NUM2DBL(rb_x);
- y = (real)NUM2DBL(rb_y);
- sigma = (real)NUM2DBL(rb_sigma);
-
- slartgs_(&x, &y, &sigma, &cs, &sn);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_float_new((double)sn);
- return rb_ary_new3(2, rb_cs, rb_sn);
-}
-
-void
-init_lapack_slartgs(VALUE mLapack){
- rb_define_module_function(mLapack, "slartgs", rb_slartgs, -1);
-}
diff --git a/slartv.c b/slartv.c
deleted file mode 100644
index 1c5fa7a..0000000
--- a/slartv.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slartv_(integer *n, real *x, integer *incx, real *y, integer *incy, real *c, real *s, integer *incc);
-
-static VALUE
-rb_slartv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- real *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- real *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_y_out__;
- real *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.slartv( n, x, incx, y, incy, c, s, incc)\n or\n NumRu::Lapack.slartv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* SLARTV applies a vector of real plane rotations to elements of the\n* real vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -s(i) c(i) ) ( y(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) REAL array,\n* dimension (1+(N-1)*INCX)\n* The vector x.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) REAL array,\n* dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (input) REAL array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* S (input) REAL 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, IY\n REAL XI, YI\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_SFLOAT)
- rb_y = na_change_type(rb_y, NA_SFLOAT);
- y = NA_PTR_TYPE(rb_y, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, real*);
- MEMCPY(y_out__, y, real, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- slartv_(&n, x, &incx, y, &incy, c, s, &incc);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_slartv(VALUE mLapack){
- rb_define_module_function(mLapack, "slartv", rb_slartv, -1);
-}
diff --git a/slaruv.c b/slaruv.c
deleted file mode 100644
index 71df688..0000000
--- a/slaruv.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaruv_(integer *iseed, integer *n, real *x);
-
-static VALUE
-rb_slaruv(int argc, VALUE *argv, VALUE self){
- VALUE rb_iseed;
- integer *iseed;
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- real *x;
- VALUE rb_iseed_out__;
- integer *iseed_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.slaruv( iseed, n)\n or\n NumRu::Lapack.slaruv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARUV( ISEED, N, X )\n\n* Purpose\n* =======\n*\n* SLARUV returns a vector of n random real numbers from a uniform (0,1)\n* distribution (n <= 128).\n*\n* This is an auxiliary routine called by SLARNV and CLARNV.\n*\n\n* Arguments\n* =========\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated. N <= 128.\n*\n* X (output) REAL array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine uses a multiplicative congruential method with modulus\n* 2**48 and multiplier 33952834046453 (see G.S.Fishman,\n* 'Multiplicative congruential random number generators with modulus\n* 2**b: an exhaustive analysis for b = 32 and a partial analysis for\n* b = 48', Math. Comp. 189, pp 331-344, 1990).\n*\n* 48-bit integers are stored in 4 integer array elements with 12 bits\n* per element. Hence the routine is portable across machines with\n* integers of 32 bits or more.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_iseed = argv[0];
- rb_n = argv[1];
-
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_iseed))
- rb_raise(rb_eArgError, "iseed (1th argument) must be NArray");
- if (NA_RANK(rb_iseed) != 1)
- rb_raise(rb_eArgError, "rank of iseed (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iseed) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
- if (NA_TYPE(rb_iseed) != NA_LINT)
- rb_iseed = na_change_type(rb_iseed, NA_LINT);
- iseed = NA_PTR_TYPE(rb_iseed, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = 4;
- rb_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iseed_out__ = NA_PTR_TYPE(rb_iseed_out__, integer*);
- MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rb_iseed));
- rb_iseed = rb_iseed_out__;
- iseed = iseed_out__;
-
- slaruv_(iseed, &n, x);
-
- return rb_ary_new3(2, rb_x, rb_iseed);
-}
-
-void
-init_lapack_slaruv(VALUE mLapack){
- rb_define_module_function(mLapack, "slaruv", rb_slaruv, -1);
-}
diff --git a/slarz.c b/slarz.c
deleted file mode 100644
index 58ad4f8..0000000
--- a/slarz.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarz_(char *side, integer *m, integer *n, integer *l, real *v, integer *incv, real *tau, real *c, integer *ldc, real *work);
-
-static VALUE
-rb_slarz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- real *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- real tau;
- VALUE rb_c;
- real *c;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarz( side, m, l, v, incv, tau, c)\n or\n NumRu::Lapack.slarz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* SLARZ applies a real elementary reflector H to a real M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a real scalar and v is a real vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n*\n* H is a product of k elementary reflectors as returned by STZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) REAL array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* STZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) REAL\n* The value tau in the representation of H.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_l = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- tau = (real)NUM2DBL(rb_tau);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1+(l-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- slarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_slarz(VALUE mLapack){
- rb_define_module_function(mLapack, "slarz", rb_slarz, -1);
-}
diff --git a/slarzb.c b/slarzb.c
deleted file mode 100644
index 07064f5..0000000
--- a/slarzb.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarzb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, integer *l, real *v, integer *ldv, real *t, integer *ldt, real *c, integer *ldc, real *work, integer *ldwork);
-
-static VALUE
-rb_slarzb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- real *v;
- VALUE rb_t;
- real *t;
- VALUE rb_c;
- real *c;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer ldv;
- integer nv;
- integer ldt;
- integer k;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.slarzb( side, trans, direct, storev, m, l, v, t, c)\n or\n NumRu::Lapack.slarzb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* SLARZB applies a real block reflector H or its transpose H**T to\n* a real distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) REAL array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) REAL array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_l = argv[5];
- rb_v = argv[6];
- rb_t = argv[7];
- rb_c = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- nv = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- direct = StringValueCStr(rb_direct)[0];
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (8th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
- k = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (ldwork)*(k));
-
- slarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_slarzb(VALUE mLapack){
- rb_define_module_function(mLapack, "slarzb", rb_slarzb, -1);
-}
diff --git a/slarzt.c b/slarzt.c
deleted file mode 100644
index e8f4a10..0000000
--- a/slarzt.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slarzt_(char *direct, char *storev, integer *n, integer *k, real *v, integer *ldv, real *tau, real *t, integer *ldt);
-
-static VALUE
-rb_slarzt(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- real *v;
- VALUE rb_tau;
- real *tau;
- VALUE rb_t;
- real *t;
- VALUE rb_v_out__;
- real *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.slarzt( direct, storev, n, v, tau)\n or\n NumRu::Lapack.slarzt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* SLARZT forms the triangular factor T of a real block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) REAL array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) REAL array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, real*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- slarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_slarzt(VALUE mLapack){
- rb_define_module_function(mLapack, "slarzt", rb_slarzt, -1);
-}
diff --git a/slas2.c b/slas2.c
deleted file mode 100644
index ff01f92..0000000
--- a/slas2.c
+++ /dev/null
@@ -1,43 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slas2_(real *f, real *g, real *h, real *ssmin, real *ssmax);
-
-static VALUE
-rb_slas2(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- real f;
- VALUE rb_g;
- real g;
- VALUE rb_h;
- real h;
- VALUE rb_ssmin;
- real ssmin;
- VALUE rb_ssmax;
- real ssmax;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, ssmax = NumRu::Lapack.slas2( f, g, h)\n or\n NumRu::Lapack.slas2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )\n\n* Purpose\n* =======\n*\n* SLAS2 computes the singular values of the 2-by-2 matrix\n* [ F G ]\n* [ 0 H ].\n* On return, SSMIN is the smaller singular value and SSMAX is the\n* larger singular value.\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) REAL\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) REAL\n* The smaller singular value.\n*\n* SSMAX (output) REAL\n* The larger singular value.\n*\n\n* Further Details\n* ===============\n*\n* Barring over/underflow, all output quantities are correct to within\n* a few units in the last place (ulps), even in the absence of a guard\n* digit in addition/subtraction.\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows, or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* ====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
- rb_h = argv[2];
-
- f = (real)NUM2DBL(rb_f);
- g = (real)NUM2DBL(rb_g);
- h = (real)NUM2DBL(rb_h);
-
- slas2_(&f, &g, &h, &ssmin, &ssmax);
-
- rb_ssmin = rb_float_new((double)ssmin);
- rb_ssmax = rb_float_new((double)ssmax);
- return rb_ary_new3(2, rb_ssmin, rb_ssmax);
-}
-
-void
-init_lapack_slas2(VALUE mLapack){
- rb_define_module_function(mLapack, "slas2", rb_slas2, -1);
-}
diff --git a/slascl.c b/slascl.c
deleted file mode 100644
index b1ce51a..0000000
--- a/slascl.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slascl_(char *type, integer *kl, integer *ku, real *cfrom, real *cto, integer *m, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_slascl(int argc, VALUE *argv, VALUE self){
- VALUE rb_type;
- char type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_cfrom;
- real cfrom;
- VALUE rb_cto;
- real cto;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.slascl( type, kl, ku, cfrom, cto, m, a)\n or\n NumRu::Lapack.slascl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLASCL multiplies the M by N real matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See SGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) REAL\n* CTO (input) REAL\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_type = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_cfrom = argv[3];
- rb_cto = argv[4];
- rb_m = argv[5];
- rb_a = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- cfrom = (real)NUM2DBL(rb_cfrom);
- type = StringValueCStr(rb_type)[0];
- cto = (real)NUM2DBL(rb_cto);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_slascl(VALUE mLapack){
- rb_define_module_function(mLapack, "slascl", rb_slascl, -1);
-}
diff --git a/slascl2.c b/slascl2.c
deleted file mode 100644
index 7c7ef8d..0000000
--- a/slascl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slascl2_(integer *m, integer *n, real *d, real *x, integer *ldx);
-
-static VALUE
-rb_slascl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_x;
- real *x;
- VALUE rb_x_out__;
- real *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.slascl2( d, x)\n or\n NumRu::Lapack.slascl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* SLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) REAL array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) REAL array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- slascl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_slascl2(VALUE mLapack){
- rb_define_module_function(mLapack, "slascl2", rb_slascl2, -1);
-}
diff --git a/slasd0.c b/slasd0.c
deleted file mode 100644
index 86db173..0000000
--- a/slasd0.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd0_(integer *n, integer *sqre, real *d, real *e, real *u, integer *ldu, real *vt, integer *ldvt, integer *smlsiz, integer *iwork, real *work, integer *info);
-
-static VALUE
-rb_slasd0(int argc, VALUE *argv, VALUE self){
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- integer *iwork;
- real *work;
-
- integer n;
- integer ldu;
- integer ldvt;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n u, vt, info, d = NumRu::Lapack.slasd0( sqre, d, e, smlsiz)\n or\n NumRu::Lapack.slasd0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, SLASD0 computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M\n* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n* The algorithm computes orthogonal matrices U and VT such that\n* B = U * S * VT. The singular values S are overwritten on D.\n*\n* A related subroutine, SLASDA, computes only the singular values,\n* and optionally, the singular vectors in compact form.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the row dimension of the upper bidiagonal matrix.\n* This is also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N+1;\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix.\n* On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) REAL array, dimension (M-1)\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) REAL array, dimension at least (LDQ, N)\n* On exit, U contains the left singular vectors.\n*\n* LDU (input) INTEGER\n* On entry, leading dimension of U.\n*\n* VT (output) REAL array, dimension at least (LDVT, M)\n* On exit, VT' contains the right singular vectors.\n*\n* LDVT (input) INTEGER\n* On entry, leading dimension of VT.\n*\n* SMLSIZ (input) INTEGER\n* On entry, maximum size of the subproblems at the\n* bottom of the computation tree.\n*\n* IWORK (workspace) INTEGER array, dimension (8*N)\n*\n* WORK (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n REAL ALPHA, BETA\n* ..\n* .. External Subroutines ..\n EXTERNAL SLASD1, SLASDQ, SLASDT, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_sqre = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_smlsiz = argv[3];
-
- smlsiz = NUM2INT(rb_smlsiz);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- ldu = n;
- m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
- ldvt = m;
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- iwork = ALLOC_N(integer, (8*n));
- work = ALLOC_N(real, (3*pow(m,2)+2*m));
-
- slasd0_(&n, &sqre, d, e, u, &ldu, vt, &ldvt, &smlsiz, iwork, work, &info);
-
- free(iwork);
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_u, rb_vt, rb_info, rb_d);
-}
-
-void
-init_lapack_slasd0(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd0", rb_slasd0, -1);
-}
diff --git a/slasd1.c b/slasd1.c
deleted file mode 100644
index 521232b..0000000
--- a/slasd1.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd1_(integer *nl, integer *nr, integer *sqre, real *d, real *alpha, real *beta, real *u, integer *ldu, real *vt, integer *ldvt, integer *idxq, integer *iwork, real *work, integer *info);
-
-static VALUE
-rb_slasd1(int argc, VALUE *argv, VALUE self){
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- real *d;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_beta;
- real beta;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_u_out__;
- real *u_out__;
- VALUE rb_vt_out__;
- real *vt_out__;
- integer *iwork;
- real *work;
-
- integer ldu;
- integer n;
- integer ldvt;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.slasd1( nl, nr, sqre, d, alpha, beta, u, vt)\n or\n NumRu::Lapack.slasd1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n* where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.\n*\n* A related subroutine SLASD7 handles the case in which the singular\n* values (and the singular vectors in factored form) are desired.\n*\n* SLASD1 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The left singular vectors of the original matrix are stored in U, and\n* the transpose of the right singular vectors are stored in VT, and the\n* singular values are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or when there are zeros in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLASD2.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the square roots of the\n* roots of the secular equation via the routine SLASD4 (as called\n* by SLASD3). This routine also calculates the singular vectors of\n* the current problem.\n*\n* The final stage consists of computing the updated singular vectors\n* directly using the updated singular values. The singular vectors\n* for the current problem are multiplied with the singular vectors\n* from the overall problem.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) REAL array, dimension (NL+NR+1).\n* N = NL+NR+1\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block; and D(NL+2:N) contains the singular values of\n* the lower block. On exit D(1:N) contains the singular values\n* of the modified matrix.\n*\n* ALPHA (input/output) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) REAL array, dimension (LDU,N)\n* On entry U(1:NL, 1:NL) contains the left singular vectors of\n* the upper block; U(NL+2:N, NL+2:N) contains the left singular\n* vectors of the lower block. On exit U contains the left\n* singular vectors of the bidiagonal matrix.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max( 1, N ).\n*\n* VT (input/output) REAL array, dimension (LDVT,M)\n* where M = N + SQRE.\n* On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n* the right singular vectors of the lower block. On exit\n* VT' contains the right singular vectors of the\n* bidiagonal matrix.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= max( 1, M ).\n*\n* IDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* WORK (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_nl = argv[0];
- rb_nr = argv[1];
- rb_sqre = argv[2];
- rb_d = argv[3];
- rb_alpha = argv[4];
- rb_beta = argv[5];
- rb_u = argv[6];
- rb_vt = argv[7];
-
- alpha = (real)NUM2DBL(rb_alpha);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (7th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_u);
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_SFLOAT)
- rb_u = na_change_type(rb_u, NA_SFLOAT);
- u = NA_PTR_TYPE(rb_u, real*);
- nr = NUM2INT(rb_nr);
- beta = (real)NUM2DBL(rb_beta);
- nl = NUM2INT(rb_nl);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vt);
- if (m != (n + sqre))
- rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", n + sqre);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_SFLOAT)
- rb_vt = na_change_type(rb_vt, NA_SFLOAT);
- vt = NA_PTR_TYPE(rb_vt, real*);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (nl+nr+1))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- m = n + sqre;
- {
- int shape[1];
- shape[0] = n;
- rb_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- {
- int shape[1];
- shape[0] = nl+nr+1;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, real*);
- MEMCPY(u_out__, u, real, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, real*);
- MEMCPY(vt_out__, vt, real, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- iwork = ALLOC_N(integer, (4*n));
- work = ALLOC_N(real, (3*pow(m,2)+2*m));
-
- slasd1_(&nl, &nr, &sqre, d, &alpha, &beta, u, &ldu, vt, &ldvt, idxq, iwork, work, &info);
-
- free(iwork);
- free(work);
- rb_info = INT2NUM(info);
- rb_alpha = rb_float_new((double)alpha);
- rb_beta = rb_float_new((double)beta);
- return rb_ary_new3(7, rb_idxq, rb_info, rb_d, rb_alpha, rb_beta, rb_u, rb_vt);
-}
-
-void
-init_lapack_slasd1(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd1", rb_slasd1, -1);
-}
diff --git a/slasd2.c b/slasd2.c
deleted file mode 100644
index 0d8966e..0000000
--- a/slasd2.c
+++ /dev/null
@@ -1,209 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd2_(integer *nl, integer *nr, integer *sqre, integer *k, real *d, real *z, real *alpha, real *beta, real *u, integer *ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2, real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc, integer *idxq, integer *coltyp, integer *info);
-
-static VALUE
-rb_slasd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- real *d;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_beta;
- real beta;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_k;
- integer k;
- VALUE rb_z;
- real *z;
- VALUE rb_dsigma;
- real *dsigma;
- VALUE rb_u2;
- real *u2;
- VALUE rb_vt2;
- real *vt2;
- VALUE rb_idxc;
- integer *idxc;
- VALUE rb_coltyp;
- integer *coltyp;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_u_out__;
- real *u_out__;
- VALUE rb_vt_out__;
- real *vt_out__;
- VALUE rb_idxq_out__;
- integer *idxq_out__;
- integer *idxp;
- integer *idx;
-
- integer n;
- integer ldu;
- integer ldvt;
- integer m;
- integer ldu2;
- integer ldvt2;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.slasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq)\n or\n NumRu::Lapack.slasd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n* Purpose\n* =======\n*\n* SLASD2 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* singular values are close together or if there is a tiny entry in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n* SLASD2 is called from SLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) REAL array, dimension (N)\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ALPHA (input) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* U (input/output) REAL array, dimension (LDU,N)\n* On entry U contains the left singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL, NL), and (NL+2, NL+2), (N,N).\n* On exit U contains the trailing (N-K) updated left singular\n* vectors (those which were deflated) in its last N-K columns.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* VT (input/output) REAL array, dimension (LDVT,M)\n* On entry VT' contains the right singular vectors of two\n* submatrices in the two square blocks with corners at (1,1),\n* (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n* On exit VT' contains the trailing (N-K) updated right singular\n* vectors (those which were deflated) in its last N-K columns.\n* In case SQRE =1, the last row of VT spans the right null\n* space.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= M.\n*\n* DSIGMA (output) REAL array, dimension (N)\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* U2 (output) REAL array, dimension (LDU2,N)\n* Contains a copy of the first K-1 left singular vectors which\n* will be used by SLASD3 in a matrix multiply (SGEMM) to solve\n* for the new left singular vectors. U2 is arranged into four\n* blocks. The first block contains a column with 1 at NL+1 and\n* zero everywhere else; the second block contains non-zero\n* entries only at and above NL; the third contains non-zero\n* entries only below NL+1; and the fourth is dense.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT2 (output) REAL array, dimension (LDVT2,N)\n* VT2' contains a copy of the first K right singular vectors\n* which will be used by SLASD3 in a matrix multiply (SGEMM) to\n* solve for the new right singular vectors. VT2 is arranged into\n* three blocks. The first block contains a row that corresponds\n* to the special 0 diagonal element in SIGMA; the second block\n* contains non-zeros only at and before NL +1; the third block\n* contains non-zeros only at and after NL +2.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= M.\n*\n* IDXP (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDX (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXC (output) INTEGER array, dimension (N)\n* This will contain the permutation used to arrange the columns\n* of the deflated U matrix into three groups: the first group\n* contains non-zero entries only at and above NL, the second\n* contains non-zero entries only below NL+2, and the third is\n* dense.\n*\n* IDXQ (input/output) INTEGER array, dimension (N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first hlaf of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* COLTYP (workspace/output) INTEGER array, dimension (N)\n* As workspace, this will contain a label which will indicate\n* which of the following types a column in the U2 matrix or a\n* row in the VT2 matrix is:\n* 1 : non-zero in the upper half only\n* 2 : non-zero in the lower half only\n* 3 : dense\n* 4 : deflated\n*\n* On exit, it is an array of dimension 4, with COLTYP(I) being\n* the dimension of the I-th type columns.\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* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_nl = argv[0];
- rb_nr = argv[1];
- rb_sqre = argv[2];
- rb_d = argv[3];
- rb_alpha = argv[4];
- rb_beta = argv[5];
- rb_u = argv[6];
- rb_vt = argv[7];
- rb_idxq = argv[8];
-
- if (!NA_IsNArray(rb_idxq))
- rb_raise(rb_eArgError, "idxq (9th argument) must be NArray");
- if (NA_RANK(rb_idxq) != 1)
- rb_raise(rb_eArgError, "rank of idxq (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_idxq);
- if (NA_TYPE(rb_idxq) != NA_LINT)
- rb_idxq = na_change_type(rb_idxq, NA_LINT);
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (7th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of idxq");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_SFLOAT)
- rb_u = na_change_type(rb_u, NA_SFLOAT);
- u = NA_PTR_TYPE(rb_u, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of idxq");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- nr = NUM2INT(rb_nr);
- beta = (real)NUM2DBL(rb_beta);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_SFLOAT)
- rb_vt = na_change_type(rb_vt, NA_SFLOAT);
- vt = NA_PTR_TYPE(rb_vt, real*);
- alpha = (real)NUM2DBL(rb_alpha);
- ldu2 = n;
- ldvt2 = m;
- {
- int shape[1];
- shape[0] = n;
- rb_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dsigma = NA_PTR_TYPE(rb_dsigma, real*);
- {
- int shape[2];
- shape[0] = ldu2;
- shape[1] = n;
- rb_u2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u2 = NA_PTR_TYPE(rb_u2, real*);
- {
- int shape[2];
- shape[0] = ldvt2;
- shape[1] = n;
- rb_vt2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt2 = NA_PTR_TYPE(rb_vt2, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_idxc = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxc = NA_PTR_TYPE(rb_idxc, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- coltyp = NA_PTR_TYPE(rb_coltyp, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, real*);
- MEMCPY(u_out__, u, real, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, real*);
- MEMCPY(vt_out__, vt, real, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_idxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxq_out__ = NA_PTR_TYPE(rb_idxq_out__, integer*);
- MEMCPY(idxq_out__, idxq, integer, NA_TOTAL(rb_idxq));
- rb_idxq = rb_idxq_out__;
- idxq = idxq_out__;
- idxp = ALLOC_N(integer, (n));
- idx = ALLOC_N(integer, (n));
-
- slasd2_(&nl, &nr, &sqre, &k, d, z, &alpha, &beta, u, &ldu, vt, &ldvt, dsigma, u2, &ldu2, vt2, &ldvt2, idxp, idx, idxc, idxq, coltyp, &info);
-
- free(idxp);
- free(idx);
- rb_k = INT2NUM(k);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_k, rb_z, rb_dsigma, rb_u2, rb_vt2, rb_idxc, rb_coltyp, rb_info, rb_d, rb_u, rb_vt, rb_idxq);
-}
-
-void
-init_lapack_slasd2(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd2", rb_slasd2, -1);
-}
diff --git a/slasd3.c b/slasd3.c
deleted file mode 100644
index b958b36..0000000
--- a/slasd3.c
+++ /dev/null
@@ -1,197 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd3_(integer *nl, integer *nr, integer *sqre, integer *k, real *d, real *q, integer *ldq, real *dsigma, real *u, integer *ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2, integer *ldvt2, integer *idxc, integer *ctot, real *z, integer *info);
-
-static VALUE
-rb_slasd3(int argc, VALUE *argv, VALUE self){
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_dsigma;
- real *dsigma;
- VALUE rb_u2;
- real *u2;
- VALUE rb_vt2;
- real *vt2;
- VALUE rb_idxc;
- integer *idxc;
- VALUE rb_ctot;
- integer *ctot;
- VALUE rb_z;
- real *z;
- VALUE rb_d;
- real *d;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_info;
- integer info;
- VALUE rb_dsigma_out__;
- real *dsigma_out__;
- VALUE rb_vt2_out__;
- real *vt2_out__;
- VALUE rb_z_out__;
- real *z_out__;
- real *q;
-
- integer k;
- integer ldu2;
- integer n;
- integer ldvt2;
- integer ldu;
- integer ldvt;
- integer m;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, u, vt, info, dsigma, vt2, z = NumRu::Lapack.slasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z)\n or\n NumRu::Lapack.slasd3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n* Purpose\n* =======\n*\n* SLASD3 finds all the square roots of the roots of the secular\n* equation, as defined by the values in D and Z. It makes the\n* appropriate calls to SLASD4 and then updates the singular\n* vectors by matrix multiplication.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* SLASD3 is called from SLASD1.\n*\n\n* Arguments\n* =========\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (input) INTEGER\n* The size of the secular equation, 1 =< K = < N.\n*\n* D (output) REAL array, dimension(K)\n* On exit the square roots of the roots of the secular equation,\n* in ascending order.\n*\n* Q (workspace) REAL array,\n* dimension at least (LDQ,K).\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= K.\n*\n* DSIGMA (input/output) REAL array, dimension(K)\n* The first K elements of this array contain the old roots\n* of the deflated updating problem. These are the poles\n* of the secular equation.\n*\n* U (output) REAL array, dimension (LDU, N)\n* The last N - K columns of this matrix contain the deflated\n* left singular vectors.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= N.\n*\n* U2 (input) REAL array, dimension (LDU2, N)\n* The first K columns of this matrix contain the non-deflated\n* left singular vectors for the split problem.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2. LDU2 >= N.\n*\n* VT (output) REAL array, dimension (LDVT, M)\n* The last M - K columns of VT' contain the deflated\n* right singular vectors.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= N.\n*\n* VT2 (input/output) REAL array, dimension (LDVT2, N)\n* The first K columns of VT2' contain the non-deflated\n* right singular vectors for the split problem.\n*\n* LDVT2 (input) INTEGER\n* The leading dimension of the array VT2. LDVT2 >= N.\n*\n* IDXC (input) INTEGER array, dimension (N)\n* The permutation used to arrange the columns of U (and rows of\n* VT) into three groups: the first group contains non-zero\n* entries only at and above (or before) NL +1; the second\n* contains non-zero entries only at and below (or after) NL+2;\n* and the third is dense. The first column of U and the row of\n* VT are treated separately, however.\n*\n* The rows of the singular vectors found by SLASD4\n* must be likewise permuted before the matrix multiplies can\n* take place.\n*\n* CTOT (input) INTEGER array, dimension (4)\n* A count of the total number of the various types of columns\n* in U (or rows in VT), as described in IDXC. The fourth column\n* type is any column which has been deflated.\n*\n* Z (input/output) REAL array, dimension (K)\n* The first K elements of this array contain the components\n* of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_nl = argv[0];
- rb_nr = argv[1];
- rb_sqre = argv[2];
- rb_dsigma = argv[3];
- rb_u2 = argv[4];
- rb_vt2 = argv[5];
- rb_idxc = argv[6];
- rb_ctot = argv[7];
- rb_z = argv[8];
-
- if (!NA_IsNArray(rb_ctot))
- rb_raise(rb_eArgError, "ctot (8th argument) must be NArray");
- if (NA_RANK(rb_ctot) != 1)
- rb_raise(rb_eArgError, "rank of ctot (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ctot) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
- if (NA_TYPE(rb_ctot) != NA_LINT)
- rb_ctot = na_change_type(rb_ctot, NA_LINT);
- ctot = NA_PTR_TYPE(rb_ctot, integer*);
- if (!NA_IsNArray(rb_vt2))
- rb_raise(rb_eArgError, "vt2 (6th argument) must be NArray");
- if (NA_RANK(rb_vt2) != 2)
- rb_raise(rb_eArgError, "rank of vt2 (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_vt2);
- if (n != (nl + nr + 1))
- rb_raise(rb_eRuntimeError, "shape 1 of vt2 must be %d", nl + nr + 1);
- ldvt2 = NA_SHAPE0(rb_vt2);
- if (ldvt2 != (n))
- rb_raise(rb_eRuntimeError, "shape 0 of vt2 must be %d", n);
- n = ldvt2;
- if (NA_TYPE(rb_vt2) != NA_SFLOAT)
- rb_vt2 = na_change_type(rb_vt2, NA_SFLOAT);
- vt2 = NA_PTR_TYPE(rb_vt2, real*);
- nl = NUM2INT(rb_nl);
- if (!NA_IsNArray(rb_idxc))
- rb_raise(rb_eArgError, "idxc (7th argument) must be NArray");
- if (NA_RANK(rb_idxc) != 1)
- rb_raise(rb_eArgError, "rank of idxc (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_idxc) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of idxc must be n");
- if (NA_TYPE(rb_idxc) != NA_LINT)
- rb_idxc = na_change_type(rb_idxc, NA_LINT);
- idxc = NA_PTR_TYPE(rb_idxc, integer*);
- if (!NA_IsNArray(rb_u2))
- rb_raise(rb_eArgError, "u2 (5th argument) must be NArray");
- if (NA_RANK(rb_u2) != 2)
- rb_raise(rb_eArgError, "rank of u2 (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u2) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u2 must be n");
- ldu2 = NA_SHAPE0(rb_u2);
- if (ldu2 != (n))
- rb_raise(rb_eRuntimeError, "shape 0 of u2 must be %d", n);
- n = ldu2;
- if (NA_TYPE(rb_u2) != NA_SFLOAT)
- rb_u2 = na_change_type(rb_u2, NA_SFLOAT);
- u2 = NA_PTR_TYPE(rb_u2, real*);
- if (!NA_IsNArray(rb_dsigma))
- rb_raise(rb_eArgError, "dsigma (4th argument) must be NArray");
- if (NA_RANK(rb_dsigma) != 1)
- rb_raise(rb_eArgError, "rank of dsigma (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_dsigma);
- if (NA_TYPE(rb_dsigma) != NA_SFLOAT)
- rb_dsigma = na_change_type(rb_dsigma, NA_SFLOAT);
- dsigma = NA_PTR_TYPE(rb_dsigma, real*);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of dsigma");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- nr = NUM2INT(rb_nr);
- ldu2 = n;
- ldu = n;
- ldvt = n;
- ldvt2 = n;
- ldq = k;
- m = n+sqre;
- {
- int shape[1];
- shape[0] = k;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = m;
- rb_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, real*);
- {
- int shape[1];
- shape[0] = k;
- rb_dsigma_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dsigma_out__ = NA_PTR_TYPE(rb_dsigma_out__, real*);
- MEMCPY(dsigma_out__, dsigma, real, NA_TOTAL(rb_dsigma));
- rb_dsigma = rb_dsigma_out__;
- dsigma = dsigma_out__;
- {
- int shape[2];
- shape[0] = ldvt2;
- shape[1] = n;
- rb_vt2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt2_out__ = NA_PTR_TYPE(rb_vt2_out__, real*);
- MEMCPY(vt2_out__, vt2, real, NA_TOTAL(rb_vt2));
- rb_vt2 = rb_vt2_out__;
- vt2 = vt2_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- q = ALLOC_N(real, (ldq)*(k));
-
- slasd3_(&nl, &nr, &sqre, &k, d, q, &ldq, dsigma, u, &ldu, u2, &ldu2, vt, &ldvt, vt2, &ldvt2, idxc, ctot, z, &info);
-
- free(q);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_u, rb_vt, rb_info, rb_dsigma, rb_vt2, rb_z);
-}
-
-void
-init_lapack_slasd3(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd3", rb_slasd3, -1);
-}
diff --git a/slasd4.c b/slasd4.c
deleted file mode 100644
index 727eef6..0000000
--- a/slasd4.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd4_(integer *n, integer *i, real *d, real *z, real *delta, real *rho, real *sigma, real *work, integer *info);
-
-static VALUE
-rb_slasd4(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- real *d;
- VALUE rb_z;
- real *z;
- VALUE rb_rho;
- real rho;
- VALUE rb_delta;
- real *delta;
- VALUE rb_sigma;
- real sigma;
- VALUE rb_info;
- integer info;
- real *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, sigma, info = NumRu::Lapack.slasd4( i, d, z, rho)\n or\n NumRu::Lapack.slasd4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th updated\n* eigenvalue of a positive symmetric rank-one modification to\n* a positive diagonal matrix whose entries are given as the squares\n* of the corresponding entries in the array d, and that\n*\n* 0 <= D(i) < D(j) for i < j\n*\n* and that RHO > 0. This is arranged by the calling routine, and is\n* no loss in generality. The rank-one modified system is thus\n*\n* diag( D ) * diag( D ) + RHO * Z * Z_transpose.\n*\n* where we assume the Euclidean norm of Z is 1.\n*\n* The method consists of approximating the rational functions in the\n* secular equation by simpler interpolating rational functions.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of all arrays.\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. 1 <= I <= N.\n*\n* D (input) REAL array, dimension ( N )\n* The original eigenvalues. It is assumed that they are in\n* order, 0 <= D(I) < D(J) for I < J.\n*\n* Z (input) REAL array, dimension (N)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (N)\n* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th\n* component. If N = 1, then DELTA(1) = 1. The vector DELTA\n* contains the information necessary to construct the\n* (singular) eigenvectors.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* SIGMA (output) REAL\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) REAL array, dimension (N)\n* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th\n* component. If N = 1, then WORK( 1 ) = 1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = 1, the updating process failed.\n*\n* Internal Parameters\n* ===================\n*\n* Logical variable ORGATI (origin-at-i?) is used for distinguishing\n* whether D(i) or D(i+1) is treated as the origin.\n*\n* ORGATI = .true. origin at i\n* ORGATI = .false. origin at i+1\n*\n* Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n* if we are working with THREE poles!\n*\n* MAXIT is the maximum number of iterations allowed for each\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = n;
- rb_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, real*);
- work = ALLOC_N(real, (n));
-
- slasd4_(&n, &i, d, z, delta, &rho, &sigma, work, &info);
-
- free(work);
- rb_sigma = rb_float_new((double)sigma);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_delta, rb_sigma, rb_info);
-}
-
-void
-init_lapack_slasd4(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd4", rb_slasd4, -1);
-}
diff --git a/slasd5.c b/slasd5.c
deleted file mode 100644
index 82d5444..0000000
--- a/slasd5.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd5_(integer *i, real *d, real *z, real *delta, real *rho, real *dsigma, real *work);
-
-static VALUE
-rb_slasd5(int argc, VALUE *argv, VALUE self){
- VALUE rb_i;
- integer i;
- VALUE rb_d;
- real *d;
- VALUE rb_z;
- real *z;
- VALUE rb_rho;
- real rho;
- VALUE rb_delta;
- real *delta;
- VALUE rb_dsigma;
- real dsigma;
- real *work;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n delta, dsigma = NumRu::Lapack.slasd5( i, d, z, rho)\n or\n NumRu::Lapack.slasd5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n* Purpose\n* =======\n*\n* This subroutine computes the square root of the I-th eigenvalue\n* of a positive symmetric rank-one modification of a 2-by-2 diagonal\n* matrix\n*\n* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .\n*\n* The diagonal entries in the array D are assumed to satisfy\n*\n* 0 <= D(i) < D(j) for i < j .\n*\n* We also assume RHO > 0 and that the Euclidean norm of the vector\n* Z is one.\n*\n\n* Arguments\n* =========\n*\n* I (input) INTEGER\n* The index of the eigenvalue to be computed. I = 1 or I = 2.\n*\n* D (input) REAL array, dimension (2)\n* The original eigenvalues. We assume 0 <= D(1) < D(2).\n*\n* Z (input) REAL array, dimension (2)\n* The components of the updating vector.\n*\n* DELTA (output) REAL array, dimension (2)\n* Contains (D(j) - sigma_I) in its j-th component.\n* The vector DELTA contains the information necessary\n* to construct the eigenvectors.\n*\n* RHO (input) REAL\n* The scalar in the symmetric updating formula.\n*\n* DSIGMA (output) REAL\n* The computed sigma_I, the I-th updated eigenvalue.\n*\n* WORK (workspace) REAL array, dimension (2)\n* WORK contains (D(j) + sigma_I) in its j-th component.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ren-Cang Li, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i = argv[0];
- rb_d = argv[1];
- rb_z = argv[2];
- rb_rho = argv[3];
-
- rho = (real)NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- i = NUM2INT(rb_i);
- {
- int shape[1];
- shape[0] = 2;
- rb_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- delta = NA_PTR_TYPE(rb_delta, real*);
- work = ALLOC_N(real, (2));
-
- slasd5_(&i, d, z, delta, &rho, &dsigma, work);
-
- free(work);
- rb_dsigma = rb_float_new((double)dsigma);
- return rb_ary_new3(2, rb_delta, rb_dsigma);
-}
-
-void
-init_lapack_slasd5(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd5", rb_slasd5, -1);
-}
diff --git a/slasd6.c b/slasd6.c
deleted file mode 100644
index bed19c3..0000000
--- a/slasd6.c
+++ /dev/null
@@ -1,218 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd6_(integer *icompq, integer *nl, integer *nr, integer *sqre, real *d, real *vf, real *vl, real *alpha, real *beta, integer *idxq, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *difl, real *difr, real *z, integer *k, real *c, real *s, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slasd6(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- real *d;
- VALUE rb_vf;
- real *vf;
- VALUE rb_vl;
- real *vl;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_beta;
- real beta;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_poles;
- real *poles;
- VALUE rb_difl;
- real *difl;
- VALUE rb_difr;
- real *difr;
- VALUE rb_z;
- real *z;
- VALUE rb_k;
- integer k;
- VALUE rb_c;
- real c;
- VALUE rb_s;
- real s;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_vf_out__;
- real *vf_out__;
- VALUE rb_vl_out__;
- real *vl_out__;
- real *work;
- integer *iwork;
-
- integer m;
- integer n;
- integer ldgcol;
- integer ldgnum;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta)\n or\n NumRu::Lapack.slasd6 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASD6 computes the SVD of an updated upper bidiagonal matrix B\n* obtained by merging two smaller ones by appending a row. This\n* routine is used only for the problem which requires all singular\n* values and optionally singular vector matrices in factored form.\n* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n* A related subroutine, SLASD1, handles the case in which all singular\n* values and singular vectors of the bidiagonal matrix are desired.\n*\n* SLASD6 computes the SVD as follows:\n*\n* ( D1(in) 0 0 0 )\n* B = U(in) * ( Z1' a Z2' b ) * VT(in)\n* ( 0 0 D2(in) 0 )\n*\n* = U(out) * ( D(out) 0) * VT(out)\n*\n* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n* elsewhere; and the entry b is empty if SQRE = 0.\n*\n* The singular values of B can be computed using D1, D2, the first\n* components of all the right singular vectors of the lower block, and\n* the last components of all the right singular vectors of the upper\n* block. These components are stored and updated in VF and VL,\n* respectively, in SLASD6. Hence U and VT are not explicitly\n* referenced.\n*\n* The singular values are stored in D. The algorithm consists of two\n* stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple singular values or if there is a zero\n* in the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine SLASD7.\n*\n* The second stage consists of calculating the updated\n* singular values. This is done by finding the roots of the\n* secular equation via the routine SLASD4 (as called by SLASD8).\n* This routine also updates VF and VL and computes the distances\n* between the updated singular values and the old singular\n* values.\n*\n* SLASD6 is called from SLASDA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* D (input/output) REAL array, dimension (NL+NR+1).\n* On entry D(1:NL,1:NL) contains the singular values of the\n* upper block, and D(NL+2:N) contains the singular values\n* of the lower block. On exit D(1:N) contains the singular\n* values of the modified matrix.\n*\n* VF (input/output) REAL array, dimension (M)\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VL (input/output) REAL array, dimension (M)\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors of\n* the lower block. On exit, VL contains the last components of\n* all right singular vectors of the bidiagonal matrix.\n*\n* ALPHA (input/output) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input/output) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* IDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order, i.e.\n* D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM and POLES, must be at least N.\n*\n* POLES (output) REAL array, dimension ( LDGNUM, 2 )\n* On exit, POLES(1,*) is an array containing the new singular\n* values obtained from solving the secular equation, and\n* POLES(2,*) is an array containing the poles in the secular\n* equation. Not referenced if ICOMPQ = 0.\n*\n* DIFL (output) REAL array, dimension ( N )\n* On exit, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (output) REAL array,\n* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* On exit, DIFR(I, 1) is the distance between I-th updated\n* (undeflated) singular value and the I+1-th (undeflated) old\n* singular value.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* See SLASD8 for details on DIFL and DIFR.\n*\n* Z (output) REAL array, dimension ( M )\n* The first elements of this array contain the components\n* of the deflation-adjusted updating row vector.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (output) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* WORK (workspace) REAL array, dimension ( 4 * M )\n*\n* IWORK (workspace) INTEGER array, dimension ( 3 * N )\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_d = argv[4];
- rb_vf = argv[5];
- rb_vl = argv[6];
- rb_alpha = argv[7];
- rb_beta = argv[8];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
- if (NA_RANK(rb_vl) != 1)
- rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
- m = NA_SHAPE0(rb_vl);
- if (m != (n + sqre))
- rb_raise(rb_eRuntimeError, "shape 0 of vl must be %d", n + sqre);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- alpha = (real)NUM2DBL(rb_alpha);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- nr = NUM2INT(rb_nr);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_vf))
- rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
- if (NA_RANK(rb_vf) != 1)
- rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vf) != m)
- rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
- if (NA_TYPE(rb_vf) != NA_SFLOAT)
- rb_vf = na_change_type(rb_vf, NA_SFLOAT);
- vf = NA_PTR_TYPE(rb_vf, real*);
- beta = (real)NUM2DBL(rb_beta);
- n = nl + nr + 1;
- ldgnum = n;
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != (nl+nr+1))
- rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- ldgcol = n;
- m = n + sqre;
- {
- int shape[1];
- shape[0] = n;
- rb_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = 2;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldgnum;
- shape[1] = 2;
- rb_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- {
- int shape[2];
- shape[0] = ldgnum;
- shape[1] = 2;
- rb_poles = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- poles = NA_PTR_TYPE(rb_poles, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- difl = NA_PTR_TYPE(rb_difl, real*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? ldgnum : icompq == 0 ? n : 0;
- shape[1] = icompq == 1 ? 2 : 0;
- rb_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- difr = NA_PTR_TYPE(rb_difr, real*);
- {
- int shape[1];
- shape[0] = m;
- rb_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = nl+nr+1;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vf_out__ = NA_PTR_TYPE(rb_vf_out__, real*);
- MEMCPY(vf_out__, vf, real, NA_TOTAL(rb_vf));
- rb_vf = rb_vf_out__;
- vf = vf_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, real*);
- MEMCPY(vl_out__, vl, real, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- work = ALLOC_N(real, (4 * m));
- iwork = ALLOC_N(integer, (3 * n));
-
- slasd6_(&icompq, &nl, &nr, &sqre, d, vf, vl, &alpha, &beta, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_givptr = INT2NUM(givptr);
- rb_k = INT2NUM(k);
- rb_c = rb_float_new((double)c);
- rb_s = rb_float_new((double)s);
- rb_info = INT2NUM(info);
- rb_alpha = rb_float_new((double)alpha);
- rb_beta = rb_float_new((double)beta);
- return rb_ary_new3(18, rb_idxq, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_poles, rb_difl, rb_difr, rb_z, rb_k, rb_c, rb_s, rb_info, rb_d, rb_vf, rb_vl, rb_alpha, rb_beta);
-}
-
-void
-init_lapack_slasd6(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd6", rb_slasd6, -1);
-}
diff --git a/slasd7.c b/slasd7.c
deleted file mode 100644
index 2a7af93..0000000
--- a/slasd7.c
+++ /dev/null
@@ -1,206 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd7_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *k, real *d, real *z, real *zw, real *vf, real *vfw, real *vl, real *vlw, real *alpha, real *beta, real *dsigma, integer *idx, integer *idxp, integer *idxq, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, real *givnum, integer *ldgnum, real *c, real *s, integer *info);
-
-static VALUE
-rb_slasd7(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- real *d;
- VALUE rb_vf;
- real *vf;
- VALUE rb_vl;
- real *vl;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_beta;
- real beta;
- VALUE rb_idxq;
- integer *idxq;
- VALUE rb_k;
- integer k;
- VALUE rb_z;
- real *z;
- VALUE rb_dsigma;
- real *dsigma;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_c;
- real c;
- VALUE rb_s;
- real s;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_vf_out__;
- real *vf_out__;
- VALUE rb_vl_out__;
- real *vl_out__;
- real *zw;
- real *vfw;
- real *vlw;
- integer *idx;
- integer *idxp;
-
- integer n;
- integer m;
- integer ldgcol;
- integer ldgnum;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.slasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq)\n or\n NumRu::Lapack.slasd7 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n* Purpose\n* =======\n*\n* SLASD7 merges the two sets of singular values together into a single\n* sorted set. Then it tries to deflate the size of the problem. There\n* are two ways in which deflation can occur: when two or more singular\n* values are close together or if there is a tiny entry in the Z\n* vector. For each such occurrence the order of the related\n* secular equation problem is reduced by one.\n*\n* SLASD7 is called from SLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper\n* bidiagonal matrix in compact form.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* K (output) INTEGER\n* Contains the dimension of the non-deflated matrix, this is\n* the order of the related secular equation. 1 <= K <=N.\n*\n* D (input/output) REAL array, dimension ( N )\n* On entry D contains the singular values of the two submatrices\n* to be combined. On exit D contains the trailing (N-K) updated\n* singular values (those which were deflated) sorted into\n* increasing order.\n*\n* Z (output) REAL array, dimension ( M )\n* On exit Z contains the updating row vector in the secular\n* equation.\n*\n* ZW (workspace) REAL array, dimension ( M )\n* Workspace for Z.\n*\n* VF (input/output) REAL array, dimension ( M )\n* On entry, VF(1:NL+1) contains the first components of all\n* right singular vectors of the upper block; and VF(NL+2:M)\n* contains the first components of all right singular vectors\n* of the lower block. On exit, VF contains the first components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VFW (workspace) REAL array, dimension ( M )\n* Workspace for VF.\n*\n* VL (input/output) REAL array, dimension ( M )\n* On entry, VL(1:NL+1) contains the last components of all\n* right singular vectors of the upper block; and VL(NL+2:M)\n* contains the last components of all right singular vectors\n* of the lower block. On exit, VL contains the last components\n* of all right singular vectors of the bidiagonal matrix.\n*\n* VLW (workspace) REAL array, dimension ( M )\n* Workspace for VL.\n*\n* ALPHA (input) REAL\n* Contains the diagonal element associated with the added row.\n*\n* BETA (input) REAL\n* Contains the off-diagonal element associated with the added\n* row.\n*\n* DSIGMA (output) REAL array, dimension ( N )\n* Contains a copy of the diagonal elements (K-1 singular values\n* and one zero) in the secular equation.\n*\n* IDX (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* IDXP (workspace) INTEGER array, dimension ( N )\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output IDXP(2:K)\n* points to the nondeflated D-values and IDXP(K+1:N)\n* points to the deflated singular values.\n*\n* IDXQ (input) INTEGER array, dimension ( N )\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that entries in\n* the first half of this permutation must first be moved one\n* position backward; and entries in the second half\n* must first have NL+1 added to their values.\n*\n* PERM (output) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) to be applied\n* to each singular block. Not referenced if ICOMPQ = 0.\n*\n* GIVPTR (output) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem. Not referenced if ICOMPQ = 0.\n*\n* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value to be used in the\n* corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of GIVNUM, must be at least N.\n*\n* C (output) REAL\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (output) REAL\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_d = argv[4];
- rb_vf = argv[5];
- rb_vl = argv[6];
- rb_alpha = argv[7];
- rb_beta = argv[8];
- rb_idxq = argv[9];
-
- if (!NA_IsNArray(rb_idxq))
- rb_raise(rb_eArgError, "idxq (10th argument) must be NArray");
- if (NA_RANK(rb_idxq) != 1)
- rb_raise(rb_eArgError, "rank of idxq (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_idxq);
- if (NA_TYPE(rb_idxq) != NA_LINT)
- rb_idxq = na_change_type(rb_idxq, NA_LINT);
- idxq = NA_PTR_TYPE(rb_idxq, integer*);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
- if (NA_RANK(rb_vl) != 1)
- rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
- m = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (5th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of idxq");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- nr = NUM2INT(rb_nr);
- alpha = (real)NUM2DBL(rb_alpha);
- beta = (real)NUM2DBL(rb_beta);
- nl = NUM2INT(rb_nl);
- icompq = NUM2INT(rb_icompq);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_vf))
- rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
- if (NA_RANK(rb_vf) != 1)
- rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vf) != m)
- rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
- if (NA_TYPE(rb_vf) != NA_SFLOAT)
- rb_vf = na_change_type(rb_vf, NA_SFLOAT);
- vf = NA_PTR_TYPE(rb_vf, real*);
- ldgcol = n;
- ldgnum = n;
- {
- int shape[1];
- shape[0] = m;
- rb_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dsigma = NA_PTR_TYPE(rb_dsigma, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = 2;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldgnum;
- shape[1] = 2;
- rb_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vf_out__ = NA_PTR_TYPE(rb_vf_out__, real*);
- MEMCPY(vf_out__, vf, real, NA_TOTAL(rb_vf));
- rb_vf = rb_vf_out__;
- vf = vf_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, real*);
- MEMCPY(vl_out__, vl, real, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- zw = ALLOC_N(real, (m));
- vfw = ALLOC_N(real, (m));
- vlw = ALLOC_N(real, (m));
- idx = ALLOC_N(integer, (n));
- idxp = ALLOC_N(integer, (n));
-
- slasd7_(&icompq, &nl, &nr, &sqre, &k, d, z, zw, vf, vfw, vl, vlw, &alpha, &beta, dsigma, idx, idxp, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, &c, &s, &info);
-
- free(zw);
- free(vfw);
- free(vlw);
- free(idx);
- free(idxp);
- rb_k = INT2NUM(k);
- rb_givptr = INT2NUM(givptr);
- rb_c = rb_float_new((double)c);
- rb_s = rb_float_new((double)s);
- rb_info = INT2NUM(info);
- return rb_ary_new3(13, rb_k, rb_z, rb_dsigma, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_c, rb_s, rb_info, rb_d, rb_vf, rb_vl);
-}
-
-void
-init_lapack_slasd7(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd7", rb_slasd7, -1);
-}
diff --git a/slasd8.c b/slasd8.c
deleted file mode 100644
index 94a4aa0..0000000
--- a/slasd8.c
+++ /dev/null
@@ -1,156 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasd8_(integer *icompq, integer *k, real *d, real *z, real *vf, real *vl, real *difl, real *difr, integer *lddifr, real *dsigma, real *work, integer *info);
-
-static VALUE
-rb_slasd8(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_z;
- real *z;
- VALUE rb_vf;
- real *vf;
- VALUE rb_vl;
- real *vl;
- VALUE rb_lddifr;
- integer lddifr;
- VALUE rb_dsigma;
- real *dsigma;
- VALUE rb_d;
- real *d;
- VALUE rb_difl;
- real *difl;
- VALUE rb_difr;
- real *difr;
- VALUE rb_info;
- integer info;
- VALUE rb_z_out__;
- real *z_out__;
- VALUE rb_vf_out__;
- real *vf_out__;
- VALUE rb_vl_out__;
- real *vl_out__;
- VALUE rb_dsigma_out__;
- real *dsigma_out__;
- real *work;
-
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.slasd8( icompq, z, vf, vl, lddifr, dsigma)\n or\n NumRu::Lapack.slasd8 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASD8 finds the square roots of the roots of the secular equation,\n* as defined by the values in DSIGMA and Z. It makes the appropriate\n* calls to SLASD4, and stores, for each element in D, the distance\n* to its two nearest poles (elements in DSIGMA). It also updates\n* the arrays VF and VL, the first and last components of all the\n* right singular vectors of the original bidiagonal matrix.\n*\n* SLASD8 is called from SLASD6.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form in the calling routine:\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors in factored form as well.\n*\n* K (input) INTEGER\n* The number of terms in the rational function to be solved\n* by SLASD4. K >= 1.\n*\n* D (output) REAL array, dimension ( K )\n* On output, D contains the updated singular values.\n*\n* Z (input/output) REAL array, dimension ( K )\n* On entry, the first K elements of this array contain the\n* components of the deflation-adjusted updating row vector.\n* On exit, Z is updated.\n*\n* VF (input/output) REAL array, dimension ( K )\n* On entry, VF contains information passed through DBEDE8.\n* On exit, VF contains the first K components of the first\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* VL (input/output) REAL array, dimension ( K )\n* On entry, VL contains information passed through DBEDE8.\n* On exit, VL contains the first K components of the last\n* components of all right singular vectors of the bidiagonal\n* matrix.\n*\n* DIFL (output) REAL array, dimension ( K )\n* On exit, DIFL(I) = D(I) - DSIGMA(I).\n*\n* DIFR (output) REAL array,\n* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n* dimension ( K ) if ICOMPQ = 0.\n* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n* defined and will not be referenced.\n*\n* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n* normalizing factors for the right singular vector matrix.\n*\n* LDDIFR (input) INTEGER\n* The leading dimension of DIFR, must be at least K.\n*\n* DSIGMA (input/output) REAL array, dimension ( K )\n* On entry, the first K elements of this array contain the old\n* roots of the deflated updating problem. These are the poles\n* of the secular equation.\n* On exit, the elements of DSIGMA may be very slightly altered\n* in value.\n*\n* WORK (workspace) REAL array, dimension at least 3 * K\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 = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_icompq = argv[0];
- rb_z = argv[1];
- rb_vf = argv[2];
- rb_vl = argv[3];
- rb_lddifr = argv[4];
- rb_dsigma = argv[5];
-
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (4th argument) must be NArray");
- if (NA_RANK(rb_vl) != 1)
- rb_raise(rb_eArgError, "rank of vl (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- if (!NA_IsNArray(rb_dsigma))
- rb_raise(rb_eArgError, "dsigma (6th argument) must be NArray");
- if (NA_RANK(rb_dsigma) != 1)
- rb_raise(rb_eArgError, "rank of dsigma (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dsigma) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of vl");
- if (NA_TYPE(rb_dsigma) != NA_SFLOAT)
- rb_dsigma = na_change_type(rb_dsigma, NA_SFLOAT);
- dsigma = NA_PTR_TYPE(rb_dsigma, real*);
- if (!NA_IsNArray(rb_vf))
- rb_raise(rb_eArgError, "vf (3th argument) must be NArray");
- if (NA_RANK(rb_vf) != 1)
- rb_raise(rb_eArgError, "rank of vf (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vf) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
- if (NA_TYPE(rb_vf) != NA_SFLOAT)
- rb_vf = na_change_type(rb_vf, NA_SFLOAT);
- vf = NA_PTR_TYPE(rb_vf, real*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of vl");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- lddifr = k;
- {
- int shape[1];
- shape[0] = k;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = k;
- rb_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- difl = NA_PTR_TYPE(rb_difl, real*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? lddifr : icompq == 0 ? k : 0;
- shape[1] = icompq == 1 ? 2 : 0;
- rb_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- difr = NA_PTR_TYPE(rb_difr, real*);
- {
- int shape[1];
- shape[0] = k;
- rb_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vf_out__ = NA_PTR_TYPE(rb_vf_out__, real*);
- MEMCPY(vf_out__, vf, real, NA_TOTAL(rb_vf));
- rb_vf = rb_vf_out__;
- vf = vf_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, real*);
- MEMCPY(vl_out__, vl, real, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[1];
- shape[0] = k;
- rb_dsigma_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dsigma_out__ = NA_PTR_TYPE(rb_dsigma_out__, real*);
- MEMCPY(dsigma_out__, dsigma, real, NA_TOTAL(rb_dsigma));
- rb_dsigma = rb_dsigma_out__;
- dsigma = dsigma_out__;
- work = ALLOC_N(real, (3 * k));
-
- slasd8_(&icompq, &k, d, z, vf, vl, difl, difr, &lddifr, dsigma, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_d, rb_difl, rb_difr, rb_info, rb_z, rb_vf, rb_vl, rb_dsigma);
-}
-
-void
-init_lapack_slasd8(VALUE mLapack){
- rb_define_module_function(mLapack, "slasd8", rb_slasd8, -1);
-}
diff --git a/slasda.c b/slasda.c
deleted file mode 100644
index 8cd27cb..0000000
--- a/slasda.c
+++ /dev/null
@@ -1,202 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasda_(integer *icompq, integer *smlsiz, integer *n, integer *sqre, real *d, real *e, real *u, integer *ldu, real *vt, integer *k, real *difl, real *difr, real *z, real *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum, real *c, real *s, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_slasda(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_u;
- real *u;
- VALUE rb_vt;
- real *vt;
- VALUE rb_k;
- integer *k;
- VALUE rb_difl;
- real *difl;
- VALUE rb_difr;
- real *difr;
- VALUE rb_z;
- real *z;
- VALUE rb_poles;
- real *poles;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givnum;
- real *givnum;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- real *s;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldu;
- integer nlvl;
- integer ldgcol;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.slasda( icompq, smlsiz, sqre, d, e)\n or\n NumRu::Lapack.slasda # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using a divide and conquer approach, SLASDA computes the singular\n* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n* B with diagonal D and offdiagonal E, where M = N + SQRE. The\n* algorithm computes the singular values in the SVD B = U * S * VT.\n* The orthogonal matrices U and VT are optionally computed in\n* compact form.\n*\n* A related subroutine, SLASD0, computes the singular values and\n* the singular vectors in explicit form.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed\n* in compact form, as follows\n* = 0: Compute singular values only.\n* = 1: Compute singular vectors of upper bidiagonal\n* matrix in compact form.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row dimension of the upper bidiagonal matrix. This is\n* also the dimension of the main diagonal array D.\n*\n* SQRE (input) INTEGER\n* Specifies the column dimension of the bidiagonal matrix.\n* = 0: The bidiagonal matrix has column dimension M = N;\n* = 1: The bidiagonal matrix has column dimension M = N + 1.\n*\n* D (input/output) REAL array, dimension ( N )\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit D, if INFO = 0, contains its singular values.\n*\n* E (input) REAL array, dimension ( M-1 )\n* Contains the subdiagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* U (output) REAL array,\n* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n* GIVNUM, and Z.\n*\n* VT (output) REAL array,\n* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n* singular vector matrices of all subproblems at the bottom\n* level.\n*\n* K (output) INTEGER array, dimension ( N ) \n* if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n* secular equation on the computation tree.\n*\n* DIFL (output) REAL array, dimension ( LDU, NLVL ),\n* where NLVL = floor(log_2 (N/SMLSIZ))).\n*\n* DIFR (output) REAL array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n* record distances between singular values on the I-th\n* level and singular values on the (I -1)-th level, and\n* DIFR(1:N, 2 * I ) contains the normalizing factors for\n* the right singular vector matrix. See SLASD8 for details.\n*\n* Z (output) REAL array,\n* dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n* dimension ( N ) if ICOMPQ = 0.\n* The first K elements of Z(1, I) contain the components of\n* the deflation-adjusted updating row vector for subproblems\n* on the I-th level.\n*\n* POLES (output) REAL array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n* POLES(1, 2*I) contain the new and old singular values\n* involved in the secular equations on the I-th level.\n*\n* GIVPTR (output) INTEGER array,\n* dimension ( N ) if ICOMPQ = 1, and not referenced if\n* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n* the number of Givens rotations performed on the I-th\n* problem on the computation tree.\n*\n* GIVCOL (output) INTEGER array,\n* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n* of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (output) INTEGER array, dimension ( LDGCOL, NLVL ) \n* if ICOMPQ = 1, and not referenced\n* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n* permutations done on the I-th level of the computation tree.\n*\n* GIVNUM (output) REAL array,\n* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not\n* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n* values of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* C (output) REAL array,\n* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (output) REAL array, dimension ( N ) if\n* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n* and the I-th subproblem is not square, on exit, S( I )\n* contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* WORK (workspace) REAL array, dimension\n* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n*\n* IWORK (workspace) INTEGER array, dimension (7*N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, a singular value did not converge\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_icompq = argv[0];
- rb_smlsiz = argv[1];
- rb_sqre = argv[2];
- rb_d = argv[3];
- rb_e = argv[4];
-
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- smlsiz = NUM2INT(rb_smlsiz);
- icompq = NUM2INT(rb_icompq);
- m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
- ldu = n;
- nlvl = floor(1.0/log(2.0)*log((double)n/smlsiz));
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (5th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- ldgcol = n;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = MAX(1,smlsiz);
- rb_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = smlsiz+1;
- rb_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, real*);
- {
- int shape[1];
- shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
- rb_k = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k = NA_PTR_TYPE(rb_k, integer*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = nlvl;
- rb_difl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- difl = NA_PTR_TYPE(rb_difl, real*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
- shape[1] = icompq == 1 ? 2 * nlvl : 0;
- rb_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- difr = NA_PTR_TYPE(rb_difr, real*);
- {
- int shape[2];
- shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
- shape[1] = icompq == 1 ? nlvl : 0;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = 2 * nlvl;
- rb_poles = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- poles = NA_PTR_TYPE(rb_poles, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_givptr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = 2 * nlvl;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldgcol;
- shape[1] = nlvl;
- rb_perm = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = 2 * nlvl;
- rb_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, real*);
- {
- int shape[1];
- shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
- rb_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, real*);
- {
- int shape[1];
- shape[0] = icompq==1 ? n : icompq==0 ? 1 : 0;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- work = ALLOC_N(real, (6 * n + (smlsiz + 1)*(smlsiz + 1)));
- iwork = ALLOC_N(integer, (7*n));
-
- slasda_(&icompq, &smlsiz, &n, &sqre, d, e, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(15, rb_u, rb_vt, rb_k, rb_difl, rb_difr, rb_z, rb_poles, rb_givptr, rb_givcol, rb_perm, rb_givnum, rb_c, rb_s, rb_info, rb_d);
-}
-
-void
-init_lapack_slasda(VALUE mLapack){
- rb_define_module_function(mLapack, "slasda", rb_slasda, -1);
-}
diff --git a/slasdq.c b/slasdq.c
deleted file mode 100644
index 02bb62e..0000000
--- a/slasdq.c
+++ /dev/null
@@ -1,167 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasdq_(char *uplo, integer *sqre, integer *n, integer *ncvt, integer *nru, integer *ncc, real *d, real *e, real *vt, integer *ldvt, real *u, integer *ldu, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_slasdq(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_nru;
- integer nru;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vt;
- real *vt;
- VALUE rb_u;
- real *u;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_vt_out__;
- real *vt_out__;
- VALUE rb_u_out__;
- real *u_out__;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer n;
- integer ldvt;
- integer ncvt;
- integer ldu;
- integer ldc;
- integer ncc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.slasdq( uplo, sqre, nru, d, e, vt, u, c)\n or\n NumRu::Lapack.slasdq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASDQ computes the singular value decomposition (SVD) of a real\n* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n* E, accumulating the transformations if desired. Letting B denote\n* the input bidiagonal matrix, the algorithm computes orthogonal\n* matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n* of P). The singular values S are overwritten on D.\n*\n* The input matrix U is changed to U * Q if desired.\n* The input matrix VT is changed to P' * VT if desired.\n* The input matrix C is changed to Q' * C if desired.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3, for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the input bidiagonal matrix\n* is upper or lower bidiagonal, and wether it is square are\n* not.\n* UPLO = 'U' or 'u' B is upper bidiagonal.\n* UPLO = 'L' or 'l' B is lower bidiagonal.\n*\n* SQRE (input) INTEGER\n* = 0: then the input matrix is N-by-N.\n* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n* (N+1)-by-N if UPLU = 'L'.\n*\n* The bidiagonal matrix has\n* N = NL + NR + 1 rows and\n* M = N + SQRE >= N columns.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of rows and columns\n* in the matrix. N must be at least 0.\n*\n* NCVT (input) INTEGER\n* On entry, NCVT specifies the number of columns of\n* the matrix VT. NCVT must be at least 0.\n*\n* NRU (input) INTEGER\n* On entry, NRU specifies the number of rows of\n* the matrix U. NRU must be at least 0.\n*\n* NCC (input) INTEGER\n* On entry, NCC specifies the number of columns of\n* the matrix C. NCC must be at least 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the diagonal entries of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in ascending order.\n*\n* E (input/output) REAL array.\n* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n* On entry, the entries of E contain the offdiagonal entries\n* of the bidiagonal matrix whose SVD is desired. On normal\n* exit, E will contain 0. If the algorithm does not converge,\n* D and E will contain the diagonal and superdiagonal entries\n* of a bidiagonal matrix orthogonally equivalent to the one\n* given as input.\n*\n* VT (input/output) REAL array, dimension (LDVT, NCVT)\n* On entry, contains a matrix which on exit has been\n* premultiplied by P', dimension N-by-NCVT if SQRE = 0\n* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n*\n* LDVT (input) INTEGER\n* On entry, LDVT specifies the leading dimension of VT as\n* declared in the calling (sub) program. LDVT must be at\n* least 1. If NCVT is nonzero LDVT must also be at least N.\n*\n* U (input/output) REAL array, dimension (LDU, N)\n* On entry, contains a matrix which on exit has been\n* postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n*\n* LDU (input) INTEGER\n* On entry, LDU specifies the leading dimension of U as\n* declared in the calling (sub) program. LDU must be at\n* least max( 1, NRU ) .\n*\n* C (input/output) REAL array, dimension (LDC, NCC)\n* On entry, contains an N-by-NCC matrix which on exit\n* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0\n* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n*\n* LDC (input) INTEGER\n* On entry, LDC specifies the leading dimension of C as\n* declared in the calling (sub) program. LDC must be at\n* least 1. If NCC is nonzero, LDC must also be at least N.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n* Workspace. Only referenced if one of NCVT, NRU, or NCC is\n* nonzero, and if N is at least 2.\n*\n* INFO (output) INTEGER\n* On exit, a value of 0 indicates a successful exit.\n* If INFO < 0, argument number -INFO is illegal.\n* If INFO > 0, the algorithm did not converge, and INFO\n* specifies how many superdiagonals did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_sqre = argv[1];
- rb_nru = argv[2];
- rb_d = argv[3];
- rb_e = argv[4];
- rb_vt = argv[5];
- rb_u = argv[6];
- rb_c = argv[7];
-
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- nru = NUM2INT(rb_nru);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (7th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_SFLOAT)
- rb_u = na_change_type(rb_u, NA_SFLOAT);
- u = NA_PTR_TYPE(rb_u, real*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (6th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (6th argument) must be %d", 2);
- ncvt = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_SFLOAT)
- rb_vt = na_change_type(rb_vt, NA_SFLOAT);
- vt = NA_PTR_TYPE(rb_vt, real*);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (5th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (sqre==0 ? n-1 : sqre==1 ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", sqre==0 ? n-1 : sqre==1 ? n : 0);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = sqre==0 ? n-1 : sqre==1 ? n : 0;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = ncvt;
- rb_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, real*);
- MEMCPY(vt_out__, vt, real, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, real*);
- MEMCPY(u_out__, u, real, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (4*n));
-
- slasdq_(&uplo, &sqre, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_info, rb_d, rb_e, rb_vt, rb_u, rb_c);
-}
-
-void
-init_lapack_slasdq(VALUE mLapack){
- rb_define_module_function(mLapack, "slasdq", rb_slasdq, -1);
-}
diff --git a/slasdt.c b/slasdt.c
deleted file mode 100644
index 0d5958e..0000000
--- a/slasdt.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasdt_(integer *n, integer *lvl, integer *nd, integer *inode, integer *ndiml, integer *ndimr, integer *msub);
-
-static VALUE
-rb_slasdt(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_msub;
- integer msub;
- VALUE rb_lvl;
- integer lvl;
- VALUE rb_nd;
- integer nd;
- VALUE rb_inode;
- integer *inode;
- VALUE rb_ndiml;
- integer *ndiml;
- VALUE rb_ndimr;
- integer *ndimr;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.slasdt( n, msub)\n or\n NumRu::Lapack.slasdt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n* Purpose\n* =======\n*\n* SLASDT creates a tree of subproblems for bidiagonal divide and\n* conquer.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* On entry, the number of diagonal elements of the\n* bidiagonal matrix.\n*\n* LVL (output) INTEGER\n* On exit, the number of levels on the computation tree.\n*\n* ND (output) INTEGER\n* On exit, the number of nodes on the tree.\n*\n* INODE (output) INTEGER array, dimension ( N )\n* On exit, centers of subproblems.\n*\n* NDIML (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of left children.\n*\n* NDIMR (output) INTEGER array, dimension ( N )\n* On exit, row dimensions of right children.\n*\n* MSUB (input) INTEGER\n* On entry, the maximum row dimension each subproblem at the\n* bottom of the tree can be of.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_n = argv[0];
- rb_msub = argv[1];
-
- n = NUM2INT(rb_n);
- msub = NUM2INT(rb_msub);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_inode = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- inode = NA_PTR_TYPE(rb_inode, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_ndiml = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ndiml = NA_PTR_TYPE(rb_ndiml, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_ndimr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ndimr = NA_PTR_TYPE(rb_ndimr, integer*);
-
- slasdt_(&n, &lvl, &nd, inode, ndiml, ndimr, &msub);
-
- rb_lvl = INT2NUM(lvl);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(5, rb_lvl, rb_nd, rb_inode, rb_ndiml, rb_ndimr);
-}
-
-void
-init_lapack_slasdt(VALUE mLapack){
- rb_define_module_function(mLapack, "slasdt", rb_slasdt, -1);
-}
diff --git a/slaset.c b/slaset.c
deleted file mode 100644
index 1d26036..0000000
--- a/slaset.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaset_(char *uplo, integer *m, integer *n, real *alpha, real *beta, real *a, integer *lda);
-
-static VALUE
-rb_slaset(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_beta;
- real beta;
- VALUE rb_a;
- real *a;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.slaset( uplo, m, alpha, beta, a)\n or\n NumRu::Lapack.slaset # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* SLASET initializes an m-by-n matrix A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set; the strictly lower\n* triangular part of A is not changed.\n* = 'L': Lower triangular part is set; the strictly upper\n* triangular part of A is not changed.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* ALPHA (input) REAL\n* The constant to which the offdiagonal elements are to be set.\n*\n* BETA (input) REAL\n* The constant to which the diagonal elements are to be set.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On exit, the leading m-by-n submatrix of A is set as follows:\n*\n* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n*\n* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_beta = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- beta = (real)NUM2DBL(rb_beta);
- alpha = (real)NUM2DBL(rb_alpha);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_slaset(VALUE mLapack){
- rb_define_module_function(mLapack, "slaset", rb_slaset, -1);
-}
diff --git a/slasq1.c b/slasq1.c
deleted file mode 100644
index 8abc35a..0000000
--- a/slasq1.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasq1_(integer *n, real *d, real *e, real *work, integer *info);
-
-static VALUE
-rb_slasq1(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- real *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.slasq1( d, e)\n or\n NumRu::Lapack.slasq1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ1( N, D, E, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SLASQ1 computes the singular values of a real N-by-N bidiagonal\n* matrix with diagonal D and off-diagonal E. The singular values\n* are computed to high relative accuracy, in the absence of\n* denormalization, underflow and overflow. The algorithm was first\n* presented in\n*\n* \"Accurate singular values and differential qd algorithms\" by K. V.\n* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n* 1994,\n*\n* and the present implementation is described in \"An implementation of\n* the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, D contains the diagonal elements of the\n* bidiagonal matrix whose SVD is desired. On normal exit,\n* D contains the singular values in decreasing order.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, elements E(1:N-1) contain the off-diagonal elements\n* of the bidiagonal matrix whose SVD is desired.\n* On exit, E is overwritten.\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(real, (4*n));
-
- slasq1_(&n, d, e, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_slasq1(VALUE mLapack){
- rb_define_module_function(mLapack, "slasq1", rb_slasq1, -1);
-}
diff --git a/slasq2.c b/slasq2.c
deleted file mode 100644
index 7cbc1f6..0000000
--- a/slasq2.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasq2_(integer *n, real *z, integer *info);
-
-static VALUE
-rb_slasq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_z_out__;
- real *z_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, z = NumRu::Lapack.slasq2( n, z)\n or\n NumRu::Lapack.slasq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ2( N, Z, INFO )\n\n* Purpose\n* =======\n*\n* SLASQ2 computes all the eigenvalues of the symmetric positive \n* definite tridiagonal matrix associated with the qd array Z to high\n* relative accuracy are computed to high relative accuracy, in the\n* absence of denormalization, underflow and overflow.\n*\n* To see the relation of Z to the tridiagonal matrix, let L be a\n* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n* let U be an upper bidiagonal matrix with 1's above and diagonal\n* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n* symmetric tridiagonal to which it is similar.\n*\n* Note : SLASQ2 defines a logical variable, IEEE, which is true\n* on machines which follow ieee-754 floating-point standard in their\n* handling of infinities and NaNs, and false otherwise. This variable\n* is passed to SLASQ3.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows and columns in the matrix. N >= 0.\n*\n* Z (input/output) REAL array, dimension ( 4*N )\n* On entry Z holds the qd array. On exit, entries 1 to N hold\n* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n* shifts that failed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if the i-th argument is a scalar and had an illegal\n* value, then INFO = -i, if the i-th argument is an\n* array and the j-entry had an illegal value, then\n* INFO = -(i*100+j)\n* > 0: the algorithm failed\n* = 1, a split was marked by a positive value in E\n* = 2, current block of Z not diagonalized after 30*N\n* iterations (in inner while loop)\n* = 3, termination criterion of outer while loop not met \n* (program created more than N unreduced blocks)\n*\n\n* Further Details\n* ===============\n* Local Variables: I0:N0 defines a current unreduced segment of Z.\n* The shifts are accumulated in SIGMA. Iteration count is in ITER.\n* Ping-pong is controlled by PP (alternates between 0 and 1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_n = argv[0];
- rb_z = argv[1];
-
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = 4*n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- slasq2_(&n, z, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_z);
-}
-
-void
-init_lapack_slasq2(VALUE mLapack){
- rb_define_module_function(mLapack, "slasq2", rb_slasq2, -1);
-}
diff --git a/slasq3.c b/slasq3.c
deleted file mode 100644
index 336eea2..0000000
--- a/slasq3.c
+++ /dev/null
@@ -1,119 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasq3_(integer *i0, integer *n0, real *z, integer *pp, real *dmin, real *sigma, real *desig, real *qmax, integer *nfail, integer *iter, integer *ndiv, logical *ieee, integer *ttype, real *dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real *tau);
-
-static VALUE
-rb_slasq3(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- real *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_desig;
- real desig;
- VALUE rb_qmax;
- real qmax;
- VALUE rb_ieee;
- logical ieee;
- VALUE rb_ttype;
- integer ttype;
- VALUE rb_dmin1;
- real dmin1;
- VALUE rb_dmin2;
- real dmin2;
- VALUE rb_dn;
- real dn;
- VALUE rb_dn1;
- real dn1;
- VALUE rb_dn2;
- real dn2;
- VALUE rb_g;
- real g;
- VALUE rb_tau;
- real tau;
- VALUE rb_dmin;
- real dmin;
- VALUE rb_sigma;
- real sigma;
- VALUE rb_nfail;
- integer nfail;
- VALUE rb_iter;
- integer iter;
- VALUE rb_ndiv;
- integer ndiv;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.slasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau)\n or\n NumRu::Lapack.slasq3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n* Purpose\n* =======\n*\n* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n* In case of failure it changes shifts, and tries again until output\n* is positive.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input/output) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input/output) INTEGER\n* PP=0 for ping, PP=1 for pong.\n* PP=2 indicates that flipping was applied to the Z array \n* and that the initial tests for deflation should not be \n* performed.\n*\n* DMIN (output) REAL\n* Minimum value of d.\n*\n* SIGMA (output) REAL\n* Sum of shifts used in current segment.\n*\n* DESIG (input/output) REAL\n* Lower order part of SIGMA\n*\n* QMAX (input) REAL\n* Maximum value of q.\n*\n* NFAIL (output) INTEGER\n* Number of times shift was too big.\n*\n* ITER (output) INTEGER\n* Number of iterations.\n*\n* NDIV (output) INTEGER\n* Number of divisions.\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).\n*\n* TTYPE (input/output) INTEGER\n* Shift type.\n*\n* DMIN1 (input/output) REAL\n*\n* DMIN2 (input/output) REAL\n*\n* DN (input/output) REAL\n*\n* DN1 (input/output) REAL\n*\n* DN2 (input/output) REAL\n*\n* G (input/output) REAL\n*\n* TAU (input/output) REAL\n*\n* These are passed as arguments in order to save their values\n* between calls to SLASQ3.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
- rb_desig = argv[4];
- rb_qmax = argv[5];
- rb_ieee = argv[6];
- rb_ttype = argv[7];
- rb_dmin1 = argv[8];
- rb_dmin2 = argv[9];
- rb_dn = argv[10];
- rb_dn1 = argv[11];
- rb_dn2 = argv[12];
- rb_g = argv[13];
- rb_tau = argv[14];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- ttype = NUM2INT(rb_ttype);
- qmax = (real)NUM2DBL(rb_qmax);
- dmin1 = (real)NUM2DBL(rb_dmin1);
- desig = (real)NUM2DBL(rb_desig);
- dmin2 = (real)NUM2DBL(rb_dmin2);
- dn = (real)NUM2DBL(rb_dn);
- dn1 = (real)NUM2DBL(rb_dn1);
- i0 = NUM2INT(rb_i0);
- tau = (real)NUM2DBL(rb_tau);
- dn2 = (real)NUM2DBL(rb_dn2);
- ieee = (rb_ieee == Qtrue);
- g = (real)NUM2DBL(rb_g);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
-
- slasq3_(&i0, &n0, z, &pp, &dmin, &sigma, &desig, &qmax, &nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau);
-
- rb_dmin = rb_float_new((double)dmin);
- rb_sigma = rb_float_new((double)sigma);
- rb_nfail = INT2NUM(nfail);
- rb_iter = INT2NUM(iter);
- rb_ndiv = INT2NUM(ndiv);
- rb_n0 = INT2NUM(n0);
- rb_pp = INT2NUM(pp);
- rb_desig = rb_float_new((double)desig);
- rb_ttype = INT2NUM(ttype);
- rb_dmin1 = rb_float_new((double)dmin1);
- rb_dmin2 = rb_float_new((double)dmin2);
- rb_dn = rb_float_new((double)dn);
- rb_dn1 = rb_float_new((double)dn1);
- rb_dn2 = rb_float_new((double)dn2);
- rb_g = rb_float_new((double)g);
- rb_tau = rb_float_new((double)tau);
- return rb_ary_new3(16, rb_dmin, rb_sigma, rb_nfail, rb_iter, rb_ndiv, rb_n0, rb_pp, rb_desig, rb_ttype, rb_dmin1, rb_dmin2, rb_dn, rb_dn1, rb_dn2, rb_g, rb_tau);
-}
-
-void
-init_lapack_slasq3(VALUE mLapack){
- rb_define_module_function(mLapack, "slasq3", rb_slasq3, -1);
-}
diff --git a/slasq4.c b/slasq4.c
deleted file mode 100644
index a21085a..0000000
--- a/slasq4.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasq4_(integer *i0, integer *n0, real *z, integer *pp, integer *n0in, real *dmin, real *dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *tau, integer *ttype, real *g);
-
-static VALUE
-rb_slasq4(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- real *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_n0in;
- integer n0in;
- VALUE rb_dmin;
- real dmin;
- VALUE rb_dmin1;
- real dmin1;
- VALUE rb_dmin2;
- real dmin2;
- VALUE rb_dn;
- real dn;
- VALUE rb_dn1;
- real dn1;
- VALUE rb_dn2;
- real dn2;
- VALUE rb_g;
- real g;
- VALUE rb_tau;
- real tau;
- VALUE rb_ttype;
- integer ttype;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, ttype, g = NumRu::Lapack.slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g)\n or\n NumRu::Lapack.slasq4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n* Purpose\n* =======\n*\n* SLASQ4 computes an approximation TAU to the smallest eigenvalue\n* using values of d from the previous transform.\n*\n\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* NOIN (input) INTEGER\n* The value of N0 at start of EIGTEST.\n*\n* DMIN (input) REAL\n* Minimum value of d.\n*\n* DMIN1 (input) REAL\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (input) REAL\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (input) REAL\n* d(N)\n*\n* DN1 (input) REAL\n* d(N-1)\n*\n* DN2 (input) REAL\n* d(N-2)\n*\n* TAU (output) REAL\n* This is the shift.\n*\n* TTYPE (output) INTEGER\n* Shift type.\n*\n* G (input/output) REAL\n* G is passed as an argument in order to save its value between\n* calls to SLASQ4.\n*\n\n* Further Details\n* ===============\n* CNST1 = 9/16\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
- rb_n0in = argv[4];
- rb_dmin = argv[5];
- rb_dmin1 = argv[6];
- rb_dmin2 = argv[7];
- rb_dn = argv[8];
- rb_dn1 = argv[9];
- rb_dn2 = argv[10];
- rb_g = argv[11];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- dn = (real)NUM2DBL(rb_dn);
- dmin1 = (real)NUM2DBL(rb_dmin1);
- dmin = (real)NUM2DBL(rb_dmin);
- dmin2 = (real)NUM2DBL(rb_dmin2);
- dn2 = (real)NUM2DBL(rb_dn2);
- dn1 = (real)NUM2DBL(rb_dn1);
- n0in = NUM2INT(rb_n0in);
- i0 = NUM2INT(rb_i0);
- g = (real)NUM2DBL(rb_g);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
-
- slasq4_(&i0, &n0, z, &pp, &n0in, &dmin, &dmin1, &dmin2, &dn, &dn1, &dn2, &tau, &ttype, &g);
-
- rb_tau = rb_float_new((double)tau);
- rb_ttype = INT2NUM(ttype);
- rb_g = rb_float_new((double)g);
- return rb_ary_new3(3, rb_tau, rb_ttype, rb_g);
-}
-
-void
-init_lapack_slasq4(VALUE mLapack){
- rb_define_module_function(mLapack, "slasq4", rb_slasq4, -1);
-}
diff --git a/slasq5.c b/slasq5.c
deleted file mode 100644
index 43caad4..0000000
--- a/slasq5.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasq5_(integer *i0, integer *n0, real *z, integer *pp, real *tau, real *dmin, real *dmin1, real *dmin2, real *dn, real *dnm1, real *dnm2, logical *ieee);
-
-static VALUE
-rb_slasq5(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- real *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_tau;
- real tau;
- VALUE rb_ieee;
- logical ieee;
- VALUE rb_dmin;
- real dmin;
- VALUE rb_dmin1;
- real dmin1;
- VALUE rb_dmin2;
- real dmin2;
- VALUE rb_dn;
- real dn;
- VALUE rb_dnm1;
- real dnm1;
- VALUE rb_dnm2;
- real dnm2;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq5( i0, n0, z, pp, tau, ieee)\n or\n NumRu::Lapack.slasq5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n* Purpose\n* =======\n*\n* SLASQ5 computes one dqds transform in ping-pong form, one\n* version for IEEE machines another for non IEEE machines.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* TAU (input) REAL\n* This is the shift.\n*\n* DMIN (output) REAL\n* Minimum value of d.\n*\n* DMIN1 (output) REAL\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) REAL\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) REAL\n* d(N0), the last value of d.\n*\n* DNM1 (output) REAL\n* d(N0-1).\n*\n* DNM2 (output) REAL\n* d(N0-2).\n*\n* IEEE (input) LOGICAL\n* Flag for IEEE or non IEEE arithmetic.\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n REAL ZERO\n PARAMETER ( ZERO = 0.0E0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n REAL D, EMIN, TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
- rb_tau = argv[4];
- rb_ieee = argv[5];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- tau = (real)NUM2DBL(rb_tau);
- ieee = (rb_ieee == Qtrue);
- i0 = NUM2INT(rb_i0);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
-
- slasq5_(&i0, &n0, z, &pp, &tau, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2, &ieee);
-
- rb_dmin = rb_float_new((double)dmin);
- rb_dmin1 = rb_float_new((double)dmin1);
- rb_dmin2 = rb_float_new((double)dmin2);
- rb_dn = rb_float_new((double)dn);
- rb_dnm1 = rb_float_new((double)dnm1);
- rb_dnm2 = rb_float_new((double)dnm2);
- return rb_ary_new3(6, rb_dmin, rb_dmin1, rb_dmin2, rb_dn, rb_dnm1, rb_dnm2);
-}
-
-void
-init_lapack_slasq5(VALUE mLapack){
- rb_define_module_function(mLapack, "slasq5", rb_slasq5, -1);
-}
diff --git a/slasq6.c b/slasq6.c
deleted file mode 100644
index 3438fb0..0000000
--- a/slasq6.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasq6_(integer *i0, integer *n0, real *z, integer *pp, real *dmin, real *dmin1, real *dmin2, real *dn, real *dnm1, real *dnm2);
-
-static VALUE
-rb_slasq6(int argc, VALUE *argv, VALUE self){
- VALUE rb_i0;
- integer i0;
- VALUE rb_n0;
- integer n0;
- VALUE rb_z;
- real *z;
- VALUE rb_pp;
- integer pp;
- VALUE rb_dmin;
- real dmin;
- VALUE rb_dmin1;
- real dmin1;
- VALUE rb_dmin2;
- real dmin2;
- VALUE rb_dn;
- real dn;
- VALUE rb_dnm1;
- real dnm1;
- VALUE rb_dnm2;
- real dnm2;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq6( i0, n0, z, pp)\n or\n NumRu::Lapack.slasq6 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n* Purpose\n* =======\n*\n* SLASQ6 computes one dqd (shift equal to zero) transform in\n* ping-pong form, with protection against underflow and overflow.\n*\n\n* Arguments\n* =========\n*\n* I0 (input) INTEGER\n* First index.\n*\n* N0 (input) INTEGER\n* Last index.\n*\n* Z (input) REAL array, dimension ( 4*N )\n* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n* an extra argument.\n*\n* PP (input) INTEGER\n* PP=0 for ping, PP=1 for pong.\n*\n* DMIN (output) REAL\n* Minimum value of d.\n*\n* DMIN1 (output) REAL\n* Minimum value of d, excluding D( N0 ).\n*\n* DMIN2 (output) REAL\n* Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n* DN (output) REAL\n* d(N0), the last value of d.\n*\n* DNM1 (output) REAL\n* d(N0-1).\n*\n* DNM2 (output) REAL\n* d(N0-2).\n*\n\n* =====================================================================\n*\n* .. Parameter ..\n REAL ZERO\n PARAMETER ( ZERO = 0.0E0 )\n* ..\n* .. Local Scalars ..\n INTEGER J4, J4P2\n REAL D, EMIN, SAFMIN, TEMP\n* ..\n* .. External Function ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_i0 = argv[0];
- rb_n0 = argv[1];
- rb_z = argv[2];
- rb_pp = argv[3];
-
- pp = NUM2INT(rb_pp);
- n0 = NUM2INT(rb_n0);
- i0 = NUM2INT(rb_i0);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (3th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (4*n0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
-
- slasq6_(&i0, &n0, z, &pp, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2);
-
- rb_dmin = rb_float_new((double)dmin);
- rb_dmin1 = rb_float_new((double)dmin1);
- rb_dmin2 = rb_float_new((double)dmin2);
- rb_dn = rb_float_new((double)dn);
- rb_dnm1 = rb_float_new((double)dnm1);
- rb_dnm2 = rb_float_new((double)dnm2);
- return rb_ary_new3(6, rb_dmin, rb_dmin1, rb_dmin2, rb_dn, rb_dnm1, rb_dnm2);
-}
-
-void
-init_lapack_slasq6(VALUE mLapack){
- rb_define_module_function(mLapack, "slasq6", rb_slasq6, -1);
-}
diff --git a/slasr.c b/slasr.c
deleted file mode 100644
index bfcf59f..0000000
--- a/slasr.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasr_(char *side, char *pivot, char *direct, integer *m, integer *n, real *c, real *s, real *a, integer *lda);
-
-static VALUE
-rb_slasr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_pivot;
- char pivot;
- VALUE rb_direct;
- char direct;
- VALUE rb_m;
- integer m;
- VALUE rb_c;
- real *c;
- VALUE rb_s;
- real *s;
- VALUE rb_a;
- real *a;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.slasr( side, pivot, direct, m, c, s, a)\n or\n NumRu::Lapack.slasr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* SLASR applies a sequence of plane rotations to a real matrix A,\n* from either the left or the right.\n* \n* When SIDE = 'L', the transformation takes the form\n* \n* A := P*A\n* \n* and when SIDE = 'R', the transformation takes the form\n* \n* A := A*P**T\n* \n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_pivot = argv[1];
- rb_direct = argv[2];
- rb_m = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
- rb_a = argv[6];
-
- direct = StringValueCStr(rb_direct)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- pivot = StringValueCStr(rb_pivot)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_slasr(VALUE mLapack){
- rb_define_module_function(mLapack, "slasr", rb_slasr, -1);
-}
diff --git a/slasrt.c b/slasrt.c
deleted file mode 100644
index 23abb30..0000000
--- a/slasrt.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasrt_(char *id, integer *n, real *d, integer *info);
-
-static VALUE
-rb_slasrt(int argc, VALUE *argv, VALUE self){
- VALUE rb_id;
- char id;
- VALUE rb_d;
- real *d;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d = NumRu::Lapack.slasrt( id, d)\n or\n NumRu::Lapack.slasrt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASRT( ID, N, D, INFO )\n\n* Purpose\n* =======\n*\n* Sort the numbers in D in increasing order (if ID = 'I') or\n* in decreasing order (if ID = 'D' ).\n*\n* Use Quick Sort, reverting to Insertion sort on arrays of\n* size <= 20. Dimension of STACK limits N to about 2**32.\n*\n\n* Arguments\n* =========\n*\n* ID (input) CHARACTER*1\n* = 'I': sort D in increasing order;\n* = 'D': sort D in decreasing order.\n*\n* N (input) INTEGER\n* The length of the array D.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the array to be sorted.\n* On exit, D has been sorted into increasing order\n* (D(1) <= ... <= D(N) ) or into decreasing order\n* (D(1) >= ... >= D(N) ), depending on ID.\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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_id = argv[0];
- rb_d = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- id = StringValueCStr(rb_id)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- slasrt_(&id, &n, d, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_d);
-}
-
-void
-init_lapack_slasrt(VALUE mLapack){
- rb_define_module_function(mLapack, "slasrt", rb_slasrt, -1);
-}
diff --git a/slassq.c b/slassq.c
deleted file mode 100644
index c9ab154..0000000
--- a/slassq.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slassq_(integer *n, real *x, integer *incx, real *scale, real *sumsq);
-
-static VALUE
-rb_slassq(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- real *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_scale;
- real scale;
- VALUE rb_sumsq;
- real sumsq;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.slassq( x, incx, scale, sumsq)\n or\n NumRu::Lapack.slassq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* SLASSQ returns the values scl and smsq such that\n*\n* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is\n* assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( x( i ) ) ).\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ and\n* scl and smsq are overwritten on SCALE and SUMSQ respectively.\n*\n* The routine makes only one pass through the vector x.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) REAL array, dimension (N)\n* The vector for which a scaled sum of squares is computed.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) REAL\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with scl , the scaling factor\n* for the sum of squares.\n*\n* SUMSQ (input/output) REAL\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with smsq , the basic sum of\n* squares from which scl has been factored out.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_incx = argv[1];
- rb_scale = argv[2];
- rb_sumsq = argv[3];
-
- scale = (real)NUM2DBL(rb_scale);
- sumsq = (real)NUM2DBL(rb_sumsq);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- incx = NUM2INT(rb_incx);
-
- slassq_(&n, x, &incx, &scale, &sumsq);
-
- rb_scale = rb_float_new((double)scale);
- rb_sumsq = rb_float_new((double)sumsq);
- return rb_ary_new3(2, rb_scale, rb_sumsq);
-}
-
-void
-init_lapack_slassq(VALUE mLapack){
- rb_define_module_function(mLapack, "slassq", rb_slassq, -1);
-}
diff --git a/slasv2.c b/slasv2.c
deleted file mode 100644
index 93a7a69..0000000
--- a/slasv2.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasv2_(real *f, real *g, real *h, real *ssmin, real *ssmax, real *snr, real *csr, real *snl, real *csl);
-
-static VALUE
-rb_slasv2(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- real f;
- VALUE rb_g;
- real g;
- VALUE rb_h;
- real h;
- VALUE rb_ssmin;
- real ssmin;
- VALUE rb_ssmax;
- real ssmax;
- VALUE rb_snr;
- real snr;
- VALUE rb_csr;
- real csr;
- VALUE rb_snl;
- real snl;
- VALUE rb_csl;
- real csl;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.slasv2( f, g, h)\n or\n NumRu::Lapack.slasv2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n* Purpose\n* =======\n*\n* SLASV2 computes the singular value decomposition of a 2-by-2\n* triangular matrix\n* [ F G ]\n* [ 0 H ].\n* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n* right singular vectors for abs(SSMAX), giving the decomposition\n*\n* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]\n* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].\n*\n\n* Arguments\n* =========\n*\n* F (input) REAL\n* The (1,1) element of the 2-by-2 matrix.\n*\n* G (input) REAL\n* The (1,2) element of the 2-by-2 matrix.\n*\n* H (input) REAL\n* The (2,2) element of the 2-by-2 matrix.\n*\n* SSMIN (output) REAL\n* abs(SSMIN) is the smaller singular value.\n*\n* SSMAX (output) REAL\n* abs(SSMAX) is the larger singular value.\n*\n* SNL (output) REAL\n* CSL (output) REAL\n* The vector (CSL, SNL) is a unit left singular vector for the\n* singular value abs(SSMAX).\n*\n* SNR (output) REAL\n* CSR (output) REAL\n* The vector (CSR, SNR) is a unit right singular vector for the\n* singular value abs(SSMAX).\n*\n\n* Further Details\n* ===============\n*\n* Any input parameter may be aliased with any output parameter.\n*\n* Barring over/underflow and assuming a guard digit in subtraction, all\n* output quantities are correct to within a few units in the last\n* place (ulps).\n*\n* In IEEE arithmetic, the code works correctly if one matrix element is\n* infinite.\n*\n* Overflow will not occur unless the largest singular value itself\n* overflows or is within a few ulps of overflow. (On machines with\n* partial overflow, like the Cray, overflow may occur if the largest\n* singular value is within a factor of 2 of overflow.)\n*\n* Underflow is harmless if underflow is gradual. Otherwise, results\n* may correspond to a matrix modified by perturbations of size near\n* the underflow threshold.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
- rb_h = argv[2];
-
- f = (real)NUM2DBL(rb_f);
- g = (real)NUM2DBL(rb_g);
- h = (real)NUM2DBL(rb_h);
-
- slasv2_(&f, &g, &h, &ssmin, &ssmax, &snr, &csr, &snl, &csl);
-
- rb_ssmin = rb_float_new((double)ssmin);
- rb_ssmax = rb_float_new((double)ssmax);
- rb_snr = rb_float_new((double)snr);
- rb_csr = rb_float_new((double)csr);
- rb_snl = rb_float_new((double)snl);
- rb_csl = rb_float_new((double)csl);
- return rb_ary_new3(6, rb_ssmin, rb_ssmax, rb_snr, rb_csr, rb_snl, rb_csl);
-}
-
-void
-init_lapack_slasv2(VALUE mLapack){
- rb_define_module_function(mLapack, "slasv2", rb_slasv2, -1);
-}
diff --git a/slaswp.c b/slaswp.c
deleted file mode 100644
index 53fee67..0000000
--- a/slaswp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slaswp_(integer *n, real *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx);
-
-static VALUE
-rb_slaswp(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_k1;
- integer k1;
- VALUE rb_k2;
- integer k2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_incx;
- integer incx;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.slaswp( a, k1, k2, ipiv, incx)\n or\n NumRu::Lapack.slaswp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* SLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n REAL TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_k1 = argv[1];
- rb_k2 = argv[2];
- rb_ipiv = argv[3];
- rb_incx = argv[4];
-
- k2 = NUM2INT(rb_k2);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- k1 = NUM2INT(rb_k1);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != (k2*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
-
- return rb_a;
-}
-
-void
-init_lapack_slaswp(VALUE mLapack){
- rb_define_module_function(mLapack, "slaswp", rb_slaswp, -1);
-}
diff --git a/slasy2.c b/slasy2.c
deleted file mode 100644
index a57a96b..0000000
--- a/slasy2.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasy2_(logical *ltranl, logical *ltranr, integer *isgn, integer *n1, integer *n2, real *tl, integer *ldtl, real *tr, integer *ldtr, real *b, integer *ldb, real *scale, real *x, integer *ldx, real *xnorm, integer *info);
-
-static VALUE
-rb_slasy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ltranl;
- logical ltranl;
- VALUE rb_ltranr;
- logical ltranr;
- VALUE rb_isgn;
- integer isgn;
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_tl;
- real *tl;
- VALUE rb_tr;
- real *tr;
- VALUE rb_b;
- real *b;
- VALUE rb_scale;
- real scale;
- VALUE rb_x;
- real *x;
- VALUE rb_xnorm;
- real xnorm;
- VALUE rb_info;
- integer info;
-
- integer ldtl;
- integer ldtr;
- integer ldb;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, x, xnorm, info = NumRu::Lapack.slasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b)\n or\n NumRu::Lapack.slasy2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n*\n* op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n*\n* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n* -1. op(T) = T or T', where T' denotes the transpose of T.\n*\n\n* Arguments\n* =========\n*\n* LTRANL (input) LOGICAL\n* On entry, LTRANL specifies the op(TL):\n* = .FALSE., op(TL) = TL,\n* = .TRUE., op(TL) = TL'.\n*\n* LTRANR (input) LOGICAL\n* On entry, LTRANR specifies the op(TR):\n* = .FALSE., op(TR) = TR,\n* = .TRUE., op(TR) = TR'.\n*\n* ISGN (input) INTEGER\n* On entry, ISGN specifies the sign of the equation\n* as described before. ISGN may only be 1 or -1.\n*\n* N1 (input) INTEGER\n* On entry, N1 specifies the order of matrix TL.\n* N1 may only be 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* On entry, N2 specifies the order of matrix TR.\n* N2 may only be 0, 1 or 2.\n*\n* TL (input) REAL array, dimension (LDTL,2)\n* On entry, TL contains an N1 by N1 matrix.\n*\n* LDTL (input) INTEGER\n* The leading dimension of the matrix TL. LDTL >= max(1,N1).\n*\n* TR (input) REAL array, dimension (LDTR,2)\n* On entry, TR contains an N2 by N2 matrix.\n*\n* LDTR (input) INTEGER\n* The leading dimension of the matrix TR. LDTR >= max(1,N2).\n*\n* B (input) REAL array, dimension (LDB,2)\n* On entry, the N1 by N2 matrix B contains the right-hand\n* side of the equation.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1,N1).\n*\n* SCALE (output) REAL\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* less than or equal to 1 to prevent the solution overflowing.\n*\n* X (output) REAL array, dimension (LDX,2)\n* On exit, X contains the N1 by N2 solution.\n*\n* LDX (input) INTEGER\n* The leading dimension of the matrix X. LDX >= max(1,N1).\n*\n* XNORM (output) REAL\n* On exit, XNORM is the infinity-norm of the solution.\n*\n* INFO (output) INTEGER\n* On exit, INFO is set to\n* 0: successful exit.\n* 1: TL and TR have too close eigenvalues, so TL or\n* TR is perturbed to get a nonsingular equation.\n* NOTE: In the interests of speed, this routine does not\n* check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_ltranl = argv[0];
- rb_ltranr = argv[1];
- rb_isgn = argv[2];
- rb_n1 = argv[3];
- rb_n2 = argv[4];
- rb_tl = argv[5];
- rb_tr = argv[6];
- rb_b = argv[7];
-
- ltranl = (rb_ltranl == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_tl))
- rb_raise(rb_eArgError, "tl (6th argument) must be NArray");
- if (NA_RANK(rb_tl) != 2)
- rb_raise(rb_eArgError, "rank of tl (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_tl) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of tl must be %d", 2);
- ldtl = NA_SHAPE0(rb_tl);
- if (NA_TYPE(rb_tl) != NA_SFLOAT)
- rb_tl = na_change_type(rb_tl, NA_SFLOAT);
- tl = NA_PTR_TYPE(rb_tl, real*);
- n1 = NUM2INT(rb_n1);
- isgn = NUM2INT(rb_isgn);
- ltranr = (rb_ltranr == Qtrue);
- if (!NA_IsNArray(rb_tr))
- rb_raise(rb_eArgError, "tr (7th argument) must be NArray");
- if (NA_RANK(rb_tr) != 2)
- rb_raise(rb_eArgError, "rank of tr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_tr) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of tr must be %d", 2);
- ldtr = NA_SHAPE0(rb_tr);
- if (NA_TYPE(rb_tr) != NA_SFLOAT)
- rb_tr = na_change_type(rb_tr, NA_SFLOAT);
- tr = NA_PTR_TYPE(rb_tr, real*);
- n2 = NUM2INT(rb_n2);
- ldx = MAX(1,n1);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = 2;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
-
- slasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &ldtl, tr, &ldtr, b, &ldb, &scale, x, &ldx, &xnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_xnorm = rb_float_new((double)xnorm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_x, rb_xnorm, rb_info);
-}
-
-void
-init_lapack_slasy2(VALUE mLapack){
- rb_define_module_function(mLapack, "slasy2", rb_slasy2, -1);
-}
diff --git a/slasyf.c b/slasyf.c
deleted file mode 100644
index 476b38c..0000000
--- a/slasyf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slasyf_(char *uplo, integer *n, integer *nb, integer *kb, real *a, integer *lda, integer *ipiv, real *w, integer *ldw, integer *info);
-
-static VALUE
-rb_slasyf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- real *a;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *w;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.slasyf( uplo, nb, a)\n or\n NumRu::Lapack.slasyf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* SLASYF computes a partial factorization of a real symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n*\n* SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) REAL 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) REAL array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- w = ALLOC_N(real, (ldw)*(MAX(1,nb)));
-
- slasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
-
- free(w);
- rb_kb = INT2NUM(kb);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_kb, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_slasyf(VALUE mLapack){
- rb_define_module_function(mLapack, "slasyf", rb_slasyf, -1);
-}
diff --git a/slatbs.c b/slatbs.c
deleted file mode 100644
index bbfd331..0000000
--- a/slatbs.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slatbs_(char *uplo, char *trans, char *diag, char *normin, integer *n, integer *kd, real *ab, integer *ldab, real *x, real *scale, real *cnorm, integer *info);
-
-static VALUE
-rb_slatbs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_x;
- real *x;
- VALUE rb_cnorm;
- real *cnorm;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_cnorm_out__;
- real *cnorm_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.slatbs( uplo, trans, diag, normin, kd, ab, x, cnorm)\n or\n NumRu::Lapack.slatbs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLATBS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine STBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) REAL array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, STBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_kd = argv[4];
- rb_ab = argv[5];
- rb_x = argv[6];
- rb_cnorm = argv[7];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_SFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_SFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, real*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of cnorm");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, real*);
- MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- slatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_slatbs(VALUE mLapack){
- rb_define_module_function(mLapack, "slatbs", rb_slatbs, -1);
-}
diff --git a/slatdf.c b/slatdf.c
deleted file mode 100644
index 06d6771..0000000
--- a/slatdf.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slatdf_(integer *ijob, integer *n, real *z, integer *ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer *jpiv);
-
-static VALUE
-rb_slatdf(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_z;
- real *z;
- VALUE rb_rhs;
- real *rhs;
- VALUE rb_rdsum;
- real rdsum;
- VALUE rb_rdscal;
- real rdscal;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_rhs_out__;
- real *rhs_out__;
-
- integer ldz;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.slatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv)\n or\n NumRu::Lapack.slatdf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* SLATDF uses the LU factorization of the n-by-n matrix Z computed by\n* SGETC2 and computes a contribution to the reciprocal Dif-estimate\n* by solving Z * x = b for x, and choosing the r.h.s. b such that\n* the norm of x is as large as possible. On entry RHS = b holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,\n* where P and Q are permutation matrices. L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using SGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value\n* of 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where all entries of\n* the r.h.s. b is choosen as either +1 or -1 (Default).\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) REAL array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by SGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) REAL array, dimension N.\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries acoording to the value of IJOB (see above).\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by STGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when STGSY2 is called by\n* STGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report IMINF-95.05, Departement of\n* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_ijob = argv[0];
- rb_z = argv[1];
- rb_rhs = argv[2];
- rb_rdsum = argv[3];
- rb_rdscal = argv[4];
- rb_ipiv = argv[5];
- rb_jpiv = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- rdscal = (real)NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of ipiv");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- rdsum = (real)NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_SFLOAT)
- rb_rhs = na_change_type(rb_rhs, NA_SFLOAT);
- rhs = NA_PTR_TYPE(rb_rhs, real*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, real*);
- MEMCPY(rhs_out__, rhs, real, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- slatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
-
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(3, rb_rhs, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_slatdf(VALUE mLapack){
- rb_define_module_function(mLapack, "slatdf", rb_slatdf, -1);
-}
diff --git a/slatps.c b/slatps.c
deleted file mode 100644
index 34aa70a..0000000
--- a/slatps.c
+++ /dev/null
@@ -1,105 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slatps_(char *uplo, char *trans, char *diag, char *normin, integer *n, real *ap, real *x, real *scale, real *cnorm, integer *info);
-
-static VALUE
-rb_slatps(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_ap;
- real *ap;
- VALUE rb_x;
- real *x;
- VALUE rb_cnorm;
- real *cnorm;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_cnorm_out__;
- real *cnorm_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.slatps( uplo, trans, diag, normin, ap, x, cnorm)\n or\n NumRu::Lapack.slatps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLATPS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A' denotes the\n* transpose of A, x and b are n-element vectors, and s is a scaling\n* factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\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*\n* X (input/output) REAL array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, STPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_ap = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_SFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_SFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- normin = StringValueCStr(rb_normin)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, real*);
- MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- slatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_slatps(VALUE mLapack){
- rb_define_module_function(mLapack, "slatps", rb_slatps, -1);
-}
diff --git a/slatrd.c b/slatrd.c
deleted file mode 100644
index f0083c3..0000000
--- a/slatrd.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slatrd_(char *uplo, integer *n, integer *nb, real *a, integer *lda, real *e, real *tau, real *w, integer *ldw);
-
-static VALUE
-rb_slatrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- real *a;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- real *tau;
- VALUE rb_w;
- real *w;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.slatrd( uplo, nb, a)\n or\n NumRu::Lapack.slatrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* SLATRD reduces NB rows and columns of a real symmetric matrix A to\n* symmetric tridiagonal form by an orthogonal similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', SLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', SLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by SSYTRD.\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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) REAL 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the orthogonal matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= (1,N).\n*\n* E (output) REAL array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) REAL array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a symmetric rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = ldw;
- shape[1] = MAX(n,nb);
- rb_w = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
-
- return rb_ary_new3(4, rb_e, rb_tau, rb_w, rb_a);
-}
-
-void
-init_lapack_slatrd(VALUE mLapack){
- rb_define_module_function(mLapack, "slatrd", rb_slatrd, -1);
-}
diff --git a/slatrs.c b/slatrs.c
deleted file mode 100644
index 7d69dcb..0000000
--- a/slatrs.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slatrs_(char *uplo, char *trans, char *diag, char *normin, integer *n, real *a, integer *lda, real *x, real *scale, real *cnorm, integer *info);
-
-static VALUE
-rb_slatrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_a;
- real *a;
- VALUE rb_x;
- real *x;
- VALUE rb_cnorm;
- real *cnorm;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_cnorm_out__;
- real *cnorm_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.slatrs( uplo, trans, diag, normin, a, x, cnorm)\n or\n NumRu::Lapack.slatrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* SLATRS solves one of the triangular systems\n*\n* A *x = s*b or A'*x = s*b\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A' denotes the transpose of A, x and b are\n* n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine STRSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A'* x = s*b (Transpose)\n* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) REAL array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) REAL\n* The scaling factor s for the triangular system\n* A * x = s*b or A'* x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) REAL array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, STRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n* algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_a = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_SFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_SFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, real*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of cnorm");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- diag = StringValueCStr(rb_diag)[0];
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, real*);
- MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- slatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_slatrs(VALUE mLapack){
- rb_define_module_function(mLapack, "slatrs", rb_slatrs, -1);
-}
diff --git a/slatrz.c b/slatrz.c
deleted file mode 100644
index 4b7d74c..0000000
--- a/slatrz.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slatrz_(integer *m, integer *n, integer *l, real *a, integer *lda, real *tau, real *work);
-
-static VALUE
-rb_slatrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.slatrz( l, a)\n or\n NumRu::Lapack.slatrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means\n* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) REAL array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_l = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- l = NUM2INT(rb_l);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (m));
-
- slatrz_(&m, &n, &l, a, &lda, tau, work);
-
- free(work);
- return rb_ary_new3(2, rb_tau, rb_a);
-}
-
-void
-init_lapack_slatrz(VALUE mLapack){
- rb_define_module_function(mLapack, "slatrz", rb_slatrz, -1);
-}
diff --git a/slatzm.c b/slatzm.c
deleted file mode 100644
index fe990fb..0000000
--- a/slatzm.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slatzm_(char *side, integer *m, integer *n, real *v, integer *incv, real *tau, real *c1, real *c2, integer *ldc, real *work);
-
-static VALUE
-rb_slatzm(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- real *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- real tau;
- VALUE rb_c1;
- real *c1;
- VALUE rb_c2;
- real *c2;
- VALUE rb_c1_out__;
- real *c1_out__;
- VALUE rb_c2_out__;
- real *c2_out__;
- real *work;
-
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.slatzm( side, m, n, v, incv, tau, c1, c2)\n or\n NumRu::Lapack.slatzm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine SORMRZ.\n*\n* SLATZM applies a Householder matrix generated by STZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) REAL array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) REAL\n* The value tau in the representation of P.\n*\n* C1 (input/output) REAL array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) REAL array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n*\n* WORK (workspace) REAL array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c1 = argv[6];
- rb_c2 = argv[7];
-
- tau = (real)NUM2DBL(rb_tau);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_c2))
- rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
- if (NA_RANK(rb_c2) != 2)
- rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
- ldc = NA_SHAPE0(rb_c2);
- if (NA_TYPE(rb_c2) != NA_SFLOAT)
- rb_c2 = na_change_type(rb_c2, NA_SFLOAT);
- c2 = NA_PTR_TYPE(rb_c2, real*);
- if (!NA_IsNArray(rb_c1))
- rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
- if (NA_RANK(rb_c1) != 2)
- rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
- if (NA_SHAPE0(rb_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
- if (NA_TYPE(rb_c1) != NA_SFLOAT)
- rb_c1 = na_change_type(rb_c1, NA_SFLOAT);
- c1 = NA_PTR_TYPE(rb_c1, real*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- {
- int shape[2];
- shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
- rb_c1_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c1_out__ = NA_PTR_TYPE(rb_c1_out__, real*);
- MEMCPY(c1_out__, c1, real, NA_TOTAL(rb_c1));
- rb_c1 = rb_c1_out__;
- c1 = c1_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
- rb_c2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c2_out__ = NA_PTR_TYPE(rb_c2_out__, real*);
- MEMCPY(c2_out__, c2, real, NA_TOTAL(rb_c2));
- rb_c2 = rb_c2_out__;
- c2 = c2_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- slatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
-
- free(work);
- return rb_ary_new3(2, rb_c1, rb_c2);
-}
-
-void
-init_lapack_slatzm(VALUE mLapack){
- rb_define_module_function(mLapack, "slatzm", rb_slatzm, -1);
-}
diff --git a/slauu2.c b/slauu2.c
deleted file mode 100644
index 74db16b..0000000
--- a/slauu2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slauu2_(char *uplo, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_slauu2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.slauu2( uplo, a)\n or\n NumRu::Lapack.slauu2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLAUU2 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) REAL 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slauu2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_slauu2(VALUE mLapack){
- rb_define_module_function(mLapack, "slauu2", rb_slauu2, -1);
-}
diff --git a/slauum.c b/slauum.c
deleted file mode 100644
index 1e7a57d..0000000
--- a/slauum.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID slauum_(char *uplo, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_slauum(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.slauum( uplo, a)\n or\n NumRu::Lapack.slauum # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SLAUUM 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) REAL 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- slauum_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_slauum(VALUE mLapack){
- rb_define_module_function(mLapack, "slauum", rb_slauum, -1);
-}
diff --git a/sopgtr.c b/sopgtr.c
deleted file mode 100644
index e759bbc..0000000
--- a/sopgtr.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sopgtr_(char *uplo, integer *n, real *ap, real *tau, real *q, integer *ldq, real *work, integer *info);
-
-static VALUE
-rb_sopgtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_tau;
- real *tau;
- VALUE rb_q;
- real *q;
- VALUE rb_info;
- integer info;
- real *work;
-
- integer ldap;
- integer ldtau;
- integer ldq;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, info = NumRu::Lapack.sopgtr( uplo, ap, tau)\n or\n NumRu::Lapack.sopgtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SOPGTR 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* SSPTRD 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 SSPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to SSPTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* AP (input) REAL array, dimension (N*(N+1)/2)\n* The vectors which define the elementary reflectors, as\n* returned by SSPTRD.\n*\n* TAU (input) REAL array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SSPTRD.\n*\n* Q (output) REAL 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) REAL 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_tau = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- ldtau = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ldtau+1;
- ldq = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- work = ALLOC_N(real, (n-1));
-
- sopgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_q, rb_info);
-}
-
-void
-init_lapack_sopgtr(VALUE mLapack){
- rb_define_module_function(mLapack, "sopgtr", rb_sopgtr, -1);
-}
diff --git a/sopmtr.c b/sopmtr.c
deleted file mode 100644
index f280aae..0000000
--- a/sopmtr.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sopmtr_(char *side, char *uplo, char *trans, integer *m, integer *n, real *ap, real *tau, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sopmtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_ap;
- real *ap;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.sopmtr( side, uplo, trans, m, ap, tau, c)\n or\n NumRu::Lapack.sopmtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SOPMTR 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 SSPTRD 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 SSPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to SSPTRD.\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) REAL 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 SSPTRD. AP is modified by the routine but\n* restored on exit.\n*\n* TAU (input) REAL 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 SSPTRD.\n*\n* C (input/output) REAL 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) REAL 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_ap = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (m*(m+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- sopmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_sopmtr(VALUE mLapack){
- rb_define_module_function(mLapack, "sopmtr", rb_sopmtr, -1);
-}
diff --git a/sorbdb.c b/sorbdb.c
deleted file mode 100644
index e9c004d..0000000
--- a/sorbdb.c
+++ /dev/null
@@ -1,216 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorbdb_(char *trans, char *signs, integer *m, integer *p, integer *q, real *x11, integer *ldx11, real *x12, integer *ldx12, real *x21, integer *ldx21, real *x22, integer *ldx22, real *theta, real *phi, real *taup1, real *taup2, real *tauq1, real *tauq2, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorbdb(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- real *x11;
- VALUE rb_x12;
- real *x12;
- VALUE rb_x21;
- real *x21;
- VALUE rb_x22;
- real *x22;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_theta;
- real *theta;
- VALUE rb_phi;
- real *phi;
- VALUE rb_taup1;
- real *taup1;
- VALUE rb_taup2;
- real *taup2;
- VALUE rb_tauq1;
- real *tauq1;
- VALUE rb_tauq2;
- real *tauq2;
- VALUE rb_info;
- integer info;
- VALUE rb_x11_out__;
- real *x11_out__;
- VALUE rb_x12_out__;
- real *x12_out__;
- VALUE rb_x21_out__;
- real *x21_out__;
- VALUE rb_x22_out__;
- real *x22_out__;
- real *work;
-
- integer ldx11;
- integer q;
- integer ldx12;
- integer ldx21;
- integer ldx22;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.sorbdb( trans, signs, m, x11, x12, x21, x22, lwork)\n or\n NumRu::Lapack.sorbdb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORBDB( 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* SORBDB 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 SORCSD\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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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) REAL array, dimension (P)\n* The scalar factors of the elementary reflectors that define\n* P1.\n*\n* TAUP2 (output) REAL array, dimension (M-P)\n* The scalar factors of the elementary reflectors that define\n* P2.\n*\n* TAUQ1 (output) REAL array, dimension (Q)\n* The scalar factors of the elementary reflectors that define\n* Q1.\n*\n* TAUQ2 (output) REAL array, dimension (M-Q)\n* The scalar factors of the elementary reflectors that define\n* Q2.\n*\n* WORK (workspace) REAL 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 SORCSD for details.\n*\n* P1, P2, Q1, and Q2 are represented as products of elementary\n* reflectors. See SORCSD for details on generating P1, P2, Q1, and Q2\n* using SORGQR and SORGLQ.\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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_signs = argv[1];
- rb_m = argv[2];
- rb_x11 = argv[3];
- rb_x12 = argv[4];
- rb_x21 = argv[5];
- rb_x22 = argv[6];
- rb_lwork = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- signs = StringValueCStr(rb_signs)[0];
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- ldx21 = NA_SHAPE0(rb_x21);
- if (ldx21 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x21 must be %d", p);
- p = ldx21;
- if (NA_TYPE(rb_x21) != NA_SFLOAT)
- rb_x21 = na_change_type(rb_x21, NA_SFLOAT);
- x21 = NA_PTR_TYPE(rb_x21, real*);
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- ldx11 = NA_SHAPE0(rb_x11);
- if (ldx11 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x11 must be %d", p);
- p = ldx11;
- if (NA_TYPE(rb_x11) != NA_SFLOAT)
- rb_x11 = na_change_type(rb_x11, NA_SFLOAT);
- x11 = NA_PTR_TYPE(rb_x11, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- ldx22 = NA_SHAPE0(rb_x22);
- if (ldx22 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be %d", p);
- p = ldx22;
- if (NA_TYPE(rb_x22) != NA_SFLOAT)
- rb_x22 = na_change_type(rb_x22, NA_SFLOAT);
- x22 = NA_PTR_TYPE(rb_x22, real*);
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- ldx12 = NA_SHAPE0(rb_x12);
- if (ldx12 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be %d", p);
- p = ldx12;
- if (NA_TYPE(rb_x12) != NA_SFLOAT)
- rb_x12 = na_change_type(rb_x12, NA_SFLOAT);
- x12 = NA_PTR_TYPE(rb_x12, real*);
- ldx12 = p;
- ldx22 = p;
- ldx21 = p;
- ldx11 = p;
- {
- int shape[1];
- shape[0] = q;
- rb_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, real*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- phi = NA_PTR_TYPE(rb_phi, real*);
- {
- int shape[1];
- shape[0] = p;
- rb_taup1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taup1 = NA_PTR_TYPE(rb_taup1, real*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_taup2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- taup2 = NA_PTR_TYPE(rb_taup2, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_tauq1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tauq1 = NA_PTR_TYPE(rb_tauq1, real*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_tauq2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tauq2 = NA_PTR_TYPE(rb_tauq2, real*);
- {
- int shape[2];
- shape[0] = ldx11;
- shape[1] = q;
- rb_x11_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x11_out__ = NA_PTR_TYPE(rb_x11_out__, real*);
- MEMCPY(x11_out__, x11, real, NA_TOTAL(rb_x11));
- rb_x11 = rb_x11_out__;
- x11 = x11_out__;
- {
- int shape[2];
- shape[0] = ldx12;
- shape[1] = m-q;
- rb_x12_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x12_out__ = NA_PTR_TYPE(rb_x12_out__, real*);
- MEMCPY(x12_out__, x12, real, NA_TOTAL(rb_x12));
- rb_x12 = rb_x12_out__;
- x12 = x12_out__;
- {
- int shape[2];
- shape[0] = ldx21;
- shape[1] = q;
- rb_x21_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x21_out__ = NA_PTR_TYPE(rb_x21_out__, real*);
- MEMCPY(x21_out__, x21, real, NA_TOTAL(rb_x21));
- rb_x21 = rb_x21_out__;
- x21 = x21_out__;
- {
- int shape[2];
- shape[0] = ldx22;
- shape[1] = m-q;
- rb_x22_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x22_out__ = NA_PTR_TYPE(rb_x22_out__, real*);
- MEMCPY(x22_out__, x22, real, NA_TOTAL(rb_x22));
- rb_x22 = rb_x22_out__;
- x22 = x22_out__;
- work = ALLOC_N(real, (MAX(1,lwork)));
-
- sorbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_theta, rb_phi, rb_taup1, rb_taup2, rb_tauq1, rb_tauq2, rb_info, rb_x11, rb_x12, rb_x21, rb_x22);
-}
-
-void
-init_lapack_sorbdb(VALUE mLapack){
- rb_define_module_function(mLapack, "sorbdb", rb_sorbdb, -1);
-}
diff --git a/sorcsd.c b/sorcsd.c
deleted file mode 100644
index da5d186..0000000
--- a/sorcsd.c
+++ /dev/null
@@ -1,195 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, char *signs, integer *m, integer *p, integer *q, real *x11, integer *ldx11, real *x12, integer *ldx12, real *x21, integer *ldx21, real *x22, integer *ldx22, real *theta, real *u1, integer *ldu1, real *u2, integer *ldu2, real *v1t, integer *ldv1t, real *v2t, integer *ldv2t, real *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_sorcsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- real *x11;
- VALUE rb_x12;
- real *x12;
- VALUE rb_x21;
- real *x21;
- VALUE rb_x22;
- real *x22;
- VALUE rb_ldu1;
- integer ldu1;
- VALUE rb_ldu2;
- integer ldu2;
- VALUE rb_ldv1t;
- integer ldv1t;
- VALUE rb_ldv2t;
- integer ldv2t;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_theta;
- real *theta;
- VALUE rb_u1;
- real *u1;
- VALUE rb_u2;
- real *u2;
- VALUE rb_v1t;
- real *v1t;
- VALUE rb_v2t;
- real *v2t;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldx11;
- integer q;
- integer ldx12;
- integer ldx21;
- integer ldx22;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, ldu1, ldu2, ldv1t, ldv2t, lwork)\n or\n NumRu::Lapack.sorcsd # print help\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORCSD computes the CS decomposition of an M-by-M partitioned\n* orthogonal matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) REAL array, dimension (LDX,M)\n* On entry, the orthogonal matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) REAL array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) REAL array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) REAL array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) REAL array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n* matrix V1**T.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) REAL array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n* matrix V2**T.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n* If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\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-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: SBBCSD did not converge. See the description of WORK\n* above for details.\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\n");
- return Qnil;
- }
- if (argc != 16)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_signs = argv[5];
- rb_m = argv[6];
- rb_x11 = argv[7];
- rb_x12 = argv[8];
- rb_x21 = argv[9];
- rb_x22 = argv[10];
- rb_ldu1 = argv[11];
- rb_ldu2 = argv[12];
- rb_ldv1t = argv[13];
- rb_ldv2t = argv[14];
- rb_lwork = argv[15];
-
- trans = StringValueCStr(rb_trans)[0];
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- lwork = NUM2INT(rb_lwork);
- signs = StringValueCStr(rb_signs)[0];
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- ldx21 = NA_SHAPE0(rb_x21);
- if (ldx21 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x21 must be %d", p);
- p = ldx21;
- if (NA_TYPE(rb_x21) != NA_SFLOAT)
- rb_x21 = na_change_type(rb_x21, NA_SFLOAT);
- x21 = NA_PTR_TYPE(rb_x21, real*);
- jobu1 = StringValueCStr(rb_jobu1)[0];
- jobu2 = StringValueCStr(rb_jobu2)[0];
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- ldx11 = NA_SHAPE0(rb_x11);
- if (ldx11 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x11 must be %d", p);
- p = ldx11;
- if (NA_TYPE(rb_x11) != NA_SFLOAT)
- rb_x11 = na_change_type(rb_x11, NA_SFLOAT);
- x11 = NA_PTR_TYPE(rb_x11, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- ldx22 = NA_SHAPE0(rb_x22);
- if (ldx22 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be %d", p);
- p = ldx22;
- if (NA_TYPE(rb_x22) != NA_SFLOAT)
- rb_x22 = na_change_type(rb_x22, NA_SFLOAT);
- x22 = NA_PTR_TYPE(rb_x22, real*);
- ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
- ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- ldx12 = NA_SHAPE0(rb_x12);
- if (ldx12 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be %d", p);
- p = ldx12;
- if (NA_TYPE(rb_x12) != NA_SFLOAT)
- rb_x12 = na_change_type(rb_x12, NA_SFLOAT);
- x12 = NA_PTR_TYPE(rb_x12, real*);
- ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
- ldx12 = p;
- ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
- ldx22 = p;
- ldx21 = p;
- ldx11 = p;
- {
- int shape[1];
- shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
- rb_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, real*);
- {
- int shape[1];
- shape[0] = p;
- rb_u1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- u1 = NA_PTR_TYPE(rb_u1, real*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_u2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- u2 = NA_PTR_TYPE(rb_u2, real*);
- {
- int shape[1];
- shape[0] = q;
- rb_v1t = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- v1t = NA_PTR_TYPE(rb_v1t, real*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_v2t = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- v2t = NA_PTR_TYPE(rb_v2t, real*);
- work = ALLOC_N(real, (MAX(1,lwork)));
- iwork = ALLOC_N(integer, (m-q));
-
- sorcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t, rb_info);
-}
-
-void
-init_lapack_sorcsd(VALUE mLapack){
- rb_define_module_function(mLapack, "sorcsd", rb_sorcsd, -1);
-}
diff --git a/sorg2l.c b/sorg2l.c
deleted file mode 100644
index 82b58e9..0000000
--- a/sorg2l.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorg2l_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sorg2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.sorg2l( m, a, tau)\n or\n NumRu::Lapack.sorg2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORG2L generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n));
-
- sorg2l_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_sorg2l(VALUE mLapack){
- rb_define_module_function(mLapack, "sorg2l", rb_sorg2l, -1);
-}
diff --git a/sorg2r.c b/sorg2r.c
deleted file mode 100644
index 2e3e31f..0000000
--- a/sorg2r.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorg2r_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sorg2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.sorg2r( m, a, tau)\n or\n NumRu::Lapack.sorg2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORG2R generates an m by n real matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n));
-
- sorg2r_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_sorg2r(VALUE mLapack){
- rb_define_module_function(mLapack, "sorg2r", rb_sorg2r, -1);
-}
diff --git a/sorgbr.c b/sorgbr.c
deleted file mode 100644
index 6f5f05b..0000000
--- a/sorgbr.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorgbr_(char *vect, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorgbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgbr( vect, m, k, a, tau, lwork)\n or\n NumRu::Lapack.sorgbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGBR generates one of the real orthogonal matrices Q or P**T\n* determined by SGEBRD when reducing a real matrix A to bidiagonal\n* form: A = Q * B * P**T. Q and P**T are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n* is of order N:\n* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m\n* rows of P**T, where n >= m >= k;\n* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**T is\n* required, as defined in the transformation applied by SGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**T.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**T to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**T to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by SGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by SGEBRD.\n* K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by SGEBRD.\n* On exit, the M-by-N matrix Q or P**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**T, as\n* returned by SGEBRD in its array argument TAUQ or TAUP.\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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_m = argv[1];
- rb_k = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_lwork = argv[5];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(m,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sorgbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sorgbr(VALUE mLapack){
- rb_define_module_function(mLapack, "sorgbr", rb_sorgbr, -1);
-}
diff --git a/sorghr.c b/sorghr.c
deleted file mode 100644
index 4fca170..0000000
--- a/sorghr.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorghr_(integer *n, integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorghr(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorghr( ilo, ihi, a, tau, lwork)\n or\n NumRu::Lapack.sorghr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGHR generates a real orthogonal matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* SGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of SGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by SGEHRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEHRD.\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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sorghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sorghr(VALUE mLapack){
- rb_define_module_function(mLapack, "sorghr", rb_sorghr, -1);
-}
diff --git a/sorgl2.c b/sorgl2.c
deleted file mode 100644
index cfb7417..0000000
--- a/sorgl2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorgl2_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sorgl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.sorgl2( a, tau)\n or\n NumRu::Lapack.sorgl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGL2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by SGELQF in the first k rows of its array argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\n*\n* WORK (workspace) REAL array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (m));
-
- sorgl2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_sorgl2(VALUE mLapack){
- rb_define_module_function(mLapack, "sorgl2", rb_sorgl2, -1);
-}
diff --git a/sorglq.c b/sorglq.c
deleted file mode 100644
index f3111ca..0000000
--- a/sorglq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorglq_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorglq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorglq( m, a, tau, lwork)\n or\n NumRu::Lapack.sorglq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by SGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sorglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sorglq(VALUE mLapack){
- rb_define_module_function(mLapack, "sorglq", rb_sorglq, -1);
-}
diff --git a/sorgql.c b/sorgql.c
deleted file mode 100644
index f9cf017..0000000
--- a/sorgql.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorgql_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorgql(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgql( m, a, tau, lwork)\n or\n NumRu::Lapack.sorgql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGQL generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sorgql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sorgql(VALUE mLapack){
- rb_define_module_function(mLapack, "sorgql", rb_sorgql, -1);
-}
diff --git a/sorgqr.c b/sorgqr.c
deleted file mode 100644
index 8c560b3..0000000
--- a/sorgqr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorgqr_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorgqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgqr( m, a, tau, lwork)\n or\n NumRu::Lapack.sorgqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGQR generates an M-by-N real matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sorgqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sorgqr(VALUE mLapack){
- rb_define_module_function(mLapack, "sorgqr", rb_sorgqr, -1);
-}
diff --git a/sorgr2.c b/sorgr2.c
deleted file mode 100644
index fcae2ff..0000000
--- a/sorgr2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorgr2_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *info);
-
-static VALUE
-rb_sorgr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.sorgr2( a, tau)\n or\n NumRu::Lapack.sorgr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGR2 generates an m by n real matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGERQF in the last k rows of its array argument\n* A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\n*\n* WORK (workspace) REAL array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (m));
-
- sorgr2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_sorgr2(VALUE mLapack){
- rb_define_module_function(mLapack, "sorgr2", rb_sorgr2, -1);
-}
diff --git a/sorgrq.c b/sorgrq.c
deleted file mode 100644
index b5483bb..0000000
--- a/sorgrq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorgrq_(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorgrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgrq( m, a, tau, lwork)\n or\n NumRu::Lapack.sorgrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by SGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sorgrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sorgrq(VALUE mLapack){
- rb_define_module_function(mLapack, "sorgrq", rb_sorgrq, -1);
-}
diff --git a/sorgtr.c b/sorgtr.c
deleted file mode 100644
index 0b882a2..0000000
--- a/sorgtr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorgtr_(char *uplo, integer *n, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sorgtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.sorgtr( uplo, a, tau, lwork)\n or\n NumRu::Lapack.sorgtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORGTR generates a real orthogonal matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* SSYTRD:\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 triangle of A contains elementary reflectors\n* from SSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from SSYTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by SSYTRD.\n* On exit, the N-by-N orthogonal matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SSYTRD.\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 >= max(1,N-1).\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- sorgtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_sorgtr(VALUE mLapack){
- rb_define_module_function(mLapack, "sorgtr", rb_sorgtr, -1);
-}
diff --git a/sorm2l.c b/sorm2l.c
deleted file mode 100644
index bc474c4..0000000
--- a/sorm2l.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorm2l_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sorm2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.sorm2l( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.sorm2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORM2L overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- sorm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_sorm2l(VALUE mLapack){
- rb_define_module_function(mLapack, "sorm2l", rb_sorm2l, -1);
-}
diff --git a/sorm2r.c b/sorm2r.c
deleted file mode 100644
index 5f2896b..0000000
--- a/sorm2r.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorm2r_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sorm2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.sorm2r( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.sorm2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORM2R overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- sorm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_sorm2r(VALUE mLapack){
- rb_define_module_function(mLapack, "sorm2r", rb_sorm2r, -1);
-}
diff --git a/sormbr.c b/sormbr.c
deleted file mode 100644
index 837994e..0000000
--- a/sormbr.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormbr_(char *vect, char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer ldc;
- integer n;
- integer nq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormbr( vect, side, trans, m, k, a, tau, c, lwork)\n or\n NumRu::Lapack.sormbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'T': Q**T * C C * Q**T\n*\n* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'T': P**T * C C * P**T\n*\n* Here Q and P**T are the orthogonal matrices determined by SGEBRD when\n* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n* P**T are defined as products of elementary reflectors H(i) and G(i)\n* respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the orthogonal matrix Q or P**T that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**T;\n* = 'P': apply P or P**T.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**T, P or P**T from the Left;\n* = 'R': apply Q, Q**T, P or P**T from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'T': Transpose, apply Q**T or P**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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by SGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by SGEBRD.\n* K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by SGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) REAL array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by SGEBRD in the array argument TAUQ or TAUP.\n*\n* C (input/output) REAL 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* or P*C or P**T*C or C*P or C*P**T.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SORMLQ, SORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_vect = argv[0];
- rb_side = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_k = argv[4];
- rb_a = argv[5];
- rb_tau = argv[6];
- rb_c = argv[7];
- rb_lwork = argv[8];
-
- k = NUM2INT(rb_k);
- lwork = NUM2INT(rb_lwork);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- trans = StringValueCStr(rb_trans)[0];
- nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormbr(VALUE mLapack){
- rb_define_module_function(mLapack, "sormbr", rb_sormbr, -1);
-}
diff --git a/sormhr.c b/sormhr.c
deleted file mode 100644
index e80e756..0000000
--- a/sormhr.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormhr_(char *side, char *trans, integer *m, integer *n, integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormhr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormhr( side, trans, ilo, ihi, a, tau, c, lwork)\n or\n NumRu::Lapack.sormhr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMHR 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* IHI-ILO elementary reflectors, as returned by SGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-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* 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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of SGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by SGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEHRD.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
- rb_lwork = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- ihi = NUM2INT(rb_ihi);
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormhr(VALUE mLapack){
- rb_define_module_function(mLapack, "sormhr", rb_sormhr, -1);
-}
diff --git a/sorml2.c b/sorml2.c
deleted file mode 100644
index 6d5e2bb..0000000
--- a/sorml2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sorml2_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sorml2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.sorml2( side, trans, a, tau, c)\n or\n NumRu::Lapack.sorml2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORML2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- sorml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_sorml2(VALUE mLapack){
- rb_define_module_function(mLapack, "sorml2", rb_sorml2, -1);
-}
diff --git a/sormlq.c b/sormlq.c
deleted file mode 100644
index 82d0062..0000000
--- a/sormlq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormlq_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormlq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormlq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.sormlq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMLQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGELQF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormlq(VALUE mLapack){
- rb_define_module_function(mLapack, "sormlq", rb_sormlq, -1);
-}
diff --git a/sormql.c b/sormql.c
deleted file mode 100644
index f46e430..0000000
--- a/sormql.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormql_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormql(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormql( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.sormql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMQL 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQLF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormql(VALUE mLapack){
- rb_define_module_function(mLapack, "sormql", rb_sormql, -1);
-}
diff --git a/sormqr.c b/sormqr.c
deleted file mode 100644
index 010a5b4..0000000
--- a/sormqr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormqr_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormqr( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.sormqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMQR 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGEQRF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormqr(VALUE mLapack){
- rb_define_module_function(mLapack, "sormqr", rb_sormqr, -1);
-}
diff --git a/sormr2.c b/sormr2.c
deleted file mode 100644
index b809f25..0000000
--- a/sormr2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormr2_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sormr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.sormr2( side, trans, a, tau, c)\n or\n NumRu::Lapack.sormr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMR2 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- sormr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_sormr2(VALUE mLapack){
- rb_define_module_function(mLapack, "sormr2", rb_sormr2, -1);
-}
diff --git a/sormr3.c b/sormr3.c
deleted file mode 100644
index 7b1abf0..0000000
--- a/sormr3.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormr3_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *info);
-
-static VALUE
-rb_sormr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- real *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.sormr3( side, trans, l, a, tau, c)\n or\n NumRu::Lapack.sormr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMR3 overwrites the general real m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'T', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n* where Q is a real orthogonal matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by STZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'T': apply Q' (Transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* STZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by STZRZF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLARZ, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- sormr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_sormr3(VALUE mLapack){
- rb_define_module_function(mLapack, "sormr3", rb_sormr3, -1);
-}
diff --git a/sormrq.c b/sormrq.c
deleted file mode 100644
index 4487127..0000000
--- a/sormrq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormrq_(char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormrq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.sormrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMRQ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by SGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* SGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SGERQF.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormrq(VALUE mLapack){
- rb_define_module_function(mLapack, "sormrq", rb_sormrq, -1);
-}
diff --git a/sormrz.c b/sormrz.c
deleted file mode 100644
index ac54431..0000000
--- a/sormrz.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormrz( side, trans, l, a, tau, c, lwork)\n or\n NumRu::Lapack.sormrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMRZ 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 defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\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* 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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* STZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) REAL array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by STZRZF.\n*\n* C (input/output) REAL array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormrz(VALUE mLapack){
- rb_define_module_function(mLapack, "sormrz", rb_sormrz, -1);
-}
diff --git a/sormtr.c b/sormtr.c
deleted file mode 100644
index 0120bf3..0000000
--- a/sormtr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sormtr_(char *side, char *uplo, char *trans, integer *m, integer *n, real *a, integer *lda, real *tau, real *c, integer *ldc, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_sormtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_c;
- real *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.sormtr( side, uplo, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.sormtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SORMTR 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 SSYTRD:\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 triangle of A contains elementary reflectors\n* from SSYTRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from SSYTRD.\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* A (input) REAL array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by SSYTRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) REAL array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by SSYTRD.\n*\n* C (input/output) REAL 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/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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SORMQL, SORMQR, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_SFLOAT)
- rb_tau = na_change_type(rb_tau, NA_SFLOAT);
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- sormtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_sormtr(VALUE mLapack){
- rb_define_module_function(mLapack, "sormtr", rb_sormtr, -1);
-}
diff --git a/spbcon.c b/spbcon.c
deleted file mode 100644
index 50ae7ad..0000000
--- a/spbcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbcon_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *anorm, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_spbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.spbcon( uplo, kd, ab, anorm)\n or\n NumRu::Lapack.spbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite band matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the symmetric band 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 (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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- spbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_spbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "spbcon", rb_spbcon, -1);
-}
diff --git a/spbequ.c b/spbequ.c
deleted file mode 100644
index 8cf386c..0000000
--- a/spbequ.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbequ_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_spbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.spbequ( uplo, kd, ab)\n or\n NumRu::Lapack.spbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPBEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- spbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_spbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "spbequ", rb_spbequ, -1);
-}
diff --git a/spbrfs.c b/spbrfs.c
deleted file mode 100644
index 4cef99a..0000000
--- a/spbrfs.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbrfs_(char *uplo, integer *n, integer *kd, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_spbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.spbrfs( uplo, kd, ab, afb, b, x)\n or\n NumRu::Lapack.spbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) REAL array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A as computed by\n* SPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+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/output) REAL array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by SPBTRS.\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_afb = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- spbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_spbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "spbrfs", rb_spbrfs, -1);
-}
diff --git a/spbstf.c b/spbstf.c
deleted file mode 100644
index 2efd192..0000000
--- a/spbstf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbstf_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_spbstf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.spbstf( uplo, kd, ab)\n or\n NumRu::Lapack.spbstf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* SPBSTF computes a split Cholesky factorization of a real\n* symmetric positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with SSBGST.\n*\n* The factorization has the form A = S**T*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**T*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- spbstf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_spbstf(VALUE mLapack){
- rb_define_module_function(mLapack, "spbstf", rb_spbstf, -1);
-}
diff --git a/spbsv.c b/spbsv.c
deleted file mode 100644
index 714e049..0000000
--- a/spbsv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbsv_(char *uplo, integer *n, integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_spbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.spbsv( uplo, kd, ab, b)\n or\n NumRu::Lapack.spbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPBSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPBTRF, SPBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- spbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_spbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "spbsv", rb_spbsv, -1);
-}
diff --git a/spbsvx.c b/spbsvx.c
deleted file mode 100644
index 088ad9c..0000000
--- a/spbsvx.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbsvx_(char *fact, char *uplo, integer *n, integer *kd, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_spbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_afb;
- real *afb;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_afb_out__;
- real *afb_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.spbsvx( fact, uplo, kd, ab, afb, equed, s, b)\n or\n NumRu::Lapack.spbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) REAL array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- kd = NUM2INT(rb_kd);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_SFLOAT)
- rb_afb = na_change_type(rb_afb, NA_SFLOAT);
- afb = NA_PTR_TYPE(rb_afb, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, real*);
- MEMCPY(afb_out__, afb, real, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- spbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ab, rb_afb, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_spbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "spbsvx", rb_spbsvx, -1);
-}
diff --git a/spbtf2.c b/spbtf2.c
deleted file mode 100644
index 7a0db4c..0000000
--- a/spbtf2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbtf2_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_spbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.spbtf2( uplo, kd, ab)\n or\n NumRu::Lapack.spbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* SPBTF2 computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the transpose of U, and\n* L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- spbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_spbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "spbtf2", rb_spbtf2, -1);
-}
diff --git a/spbtrf.c b/spbtrf.c
deleted file mode 100644
index f478ebd..0000000
--- a/spbtrf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbtrf_(char *uplo, integer *n, integer *kd, real *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_spbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.spbtrf( uplo, kd, ab)\n or\n NumRu::Lapack.spbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* SPBTRF computes the Cholesky factorization of a real symmetric\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- spbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_spbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "spbtrf", rb_spbtrf, -1);
-}
diff --git a/spbtrs.c b/spbtrs.c
deleted file mode 100644
index 2761145..0000000
--- a/spbtrs.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spbtrs_(char *uplo, integer *n, integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_spbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spbtrs( uplo, kd, ab, b)\n or\n NumRu::Lapack.spbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPBTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite band matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by SPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL STBSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- spbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_spbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "spbtrs", rb_spbtrs, -1);
-}
diff --git a/spftrf.c b/spftrf.c
deleted file mode 100644
index 407c135..0000000
--- a/spftrf.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spftrf_(char *transr, char *uplo, integer *n, real *a, integer *info);
-
-static VALUE
-rb_spftrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spftrf( transr, uplo, n, a)\n or\n NumRu::Lapack.spftrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* SPFTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension ( N*(N+1)/2 );\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the NT elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**T*U or RFP A = L*L**T.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- spftrf_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_spftrf(VALUE mLapack){
- rb_define_module_function(mLapack, "spftrf", rb_spftrf, -1);
-}
diff --git a/spftri.c b/spftri.c
deleted file mode 100644
index 87c3bad..0000000
--- a/spftri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spftri_(char *transr, char *uplo, integer *n, real *a, integer *info);
-
-static VALUE
-rb_spftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spftri( transr, uplo, n, a)\n or\n NumRu::Lapack.spftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* SPFTRI computes the inverse of a real (symmetric) positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by SPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension ( N*(N+1)/2 )\n* On entry, the symmetric matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the symmetric inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- spftri_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_spftri(VALUE mLapack){
- rb_define_module_function(mLapack, "spftri", rb_spftri, -1);
-}
diff --git a/spftrs.c b/spftrs.c
deleted file mode 100644
index 4d5b7ed..0000000
--- a/spftrs.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spftrs_(char *transr, char *uplo, integer *n, integer *nrhs, real *a, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_spftrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spftrs( transr, uplo, n, a, b)\n or\n NumRu::Lapack.spftrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPFTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by SPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) REAL array, dimension ( N*(N+1)/2 )\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**H*U or RFP A = L*L**T, as computed by SPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- spftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_spftrs(VALUE mLapack){
- rb_define_module_function(mLapack, "spftrs", rb_spftrs, -1);
-}
diff --git a/spocon.c b/spocon.c
deleted file mode 100644
index 45790fe..0000000
--- a/spocon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spocon_(char *uplo, integer *n, real *a, integer *lda, real *anorm, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_spocon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.spocon( uplo, a, anorm)\n or\n NumRu::Lapack.spocon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPOCON estimates the reciprocal of the condition number (in the \n* 1-norm) of a real symmetric positive definite matrix using the\n* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the symmetric 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 (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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- spocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_spocon(VALUE mLapack){
- rb_define_module_function(mLapack, "spocon", rb_spocon, -1);
-}
diff --git a/spoequ.c b/spoequ.c
deleted file mode 100644
index 377e449..0000000
--- a/spoequ.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spoequ_(integer *n, real *a, integer *lda, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_spoequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.spoequ( a)\n or\n NumRu::Lapack.spoequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- spoequ_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_spoequ(VALUE mLapack){
- rb_define_module_function(mLapack, "spoequ", rb_spoequ, -1);
-}
diff --git a/spoequb.c b/spoequb.c
deleted file mode 100644
index 46dac60..0000000
--- a/spoequb.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spoequb_(integer *n, real *a, integer *lda, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_spoequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.spoequb( a)\n or\n NumRu::Lapack.spoequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPOEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- spoequb_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_spoequb(VALUE mLapack){
- rb_define_module_function(mLapack, "spoequb", rb_spoequb, -1);
-}
diff --git a/sporfs.c b/sporfs.c
deleted file mode 100644
index 415f944..0000000
--- a/sporfs.c
+++ /dev/null
@@ -1,122 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sporfs_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sporfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.sporfs( uplo, a, af, b, x)\n or\n NumRu::Lapack.sporfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\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 SPOTRS.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_sporfs(VALUE mLapack){
- rb_define_module_function(mLapack, "sporfs", rb_sporfs, -1);
-}
diff --git a/sporfsx.c b/sporfsx.c
deleted file mode 100644
index d3b2b4c..0000000
--- a/sporfsx.c
+++ /dev/null
@@ -1,187 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sporfsx_(char *uplo, char *equed, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sporfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.sporfsx( uplo, equed, a, af, s, b, x, params)\n or\n NumRu::Lapack.sporfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_s = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
- rb_params = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (5th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- sporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_sporfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "sporfsx", rb_sporfsx, -1);
-}
diff --git a/sposv.c b/sposv.c
deleted file mode 100644
index 0c0f080..0000000
--- a/sposv.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sposv_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sposv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.sposv( uplo, a, b)\n or\n NumRu::Lapack.sposv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPOSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPOTRF, SPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_sposv(VALUE mLapack){
- rb_define_module_function(mLapack, "sposv", rb_sposv, -1);
-}
diff --git a/sposvx.c b/sposvx.c
deleted file mode 100644
index a55fd81..0000000
--- a/sposvx.c
+++ /dev/null
@@ -1,178 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sposvx_(char *fact, char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sposvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_af_out__;
- real *af_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.sposvx( fact, uplo, a, af, equed, s, b)\n or\n NumRu::Lapack.sposvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, real*);
- MEMCPY(af_out__, af, real, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_sposvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sposvx", rb_sposvx, -1);
-}
diff --git a/sposvxx.c b/sposvxx.c
deleted file mode 100644
index d04df73..0000000
--- a/sposvxx.c
+++ /dev/null
@@ -1,216 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sposvxx_(char *fact, char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sposvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- real *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_af_out__;
- real *af_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.sposvxx( fact, uplo, a, af, equed, s, b, params)\n or\n NumRu::Lapack.sposvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a real system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_params = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- n_err_bnds = 3;
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, real*);
- MEMCPY(af_out__, af, real, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- sposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_sposvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "sposvxx", rb_sposvxx, -1);
-}
diff --git a/spotf2.c b/spotf2.c
deleted file mode 100644
index d02001a..0000000
--- a/spotf2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spotf2_(char *uplo, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_spotf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spotf2( uplo, a)\n or\n NumRu::Lapack.spotf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SPOTF2 computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- spotf2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_spotf2(VALUE mLapack){
- rb_define_module_function(mLapack, "spotf2", rb_spotf2, -1);
-}
diff --git a/spotrf.c b/spotrf.c
deleted file mode 100644
index 3e28ded..0000000
--- a/spotrf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spotrf_(char *uplo, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_spotrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spotrf( uplo, a)\n or\n NumRu::Lapack.spotrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SPOTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- spotrf_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_spotrf(VALUE mLapack){
- rb_define_module_function(mLapack, "spotrf", rb_spotrf, -1);
-}
diff --git a/spotri.c b/spotri.c
deleted file mode 100644
index d35cf55..0000000
--- a/spotri.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spotri_(char *uplo, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_spotri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.spotri( uplo, a)\n or\n NumRu::Lapack.spotri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* SPOTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, as computed by\n* SPOTRF.\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SLAUUM, STRTRI, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- spotri_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_spotri(VALUE mLapack){
- rb_define_module_function(mLapack, "spotri", rb_spotri, -1);
-}
diff --git a/spotrs.c b/spotrs.c
deleted file mode 100644
index 7fc2893..0000000
--- a/spotrs.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spotrs_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_spotrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spotrs( uplo, a, b)\n or\n NumRu::Lapack.spotrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPOTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A using the Cholesky factorization\n* A = U**T*U or A = L*L**T computed by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) REAL array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- spotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_spotrs(VALUE mLapack){
- rb_define_module_function(mLapack, "spotrs", rb_spotrs, -1);
-}
diff --git a/sppcon.c b/sppcon.c
deleted file mode 100644
index bc36cbb..0000000
--- a/sppcon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sppcon_(char *uplo, integer *n, real *ap, real *anorm, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sppcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.sppcon( uplo, ap, anorm)\n or\n NumRu::Lapack.sppcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite packed matrix using\n* the Cholesky factorization A = U**T*U or A = L*L**T computed by\n* SPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) REAL\n* The 1-norm (or infinity-norm) of the symmetric 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 (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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sppcon_(&uplo, &n, ap, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_sppcon(VALUE mLapack){
- rb_define_module_function(mLapack, "sppcon", rb_sppcon, -1);
-}
diff --git a/sppequ.c b/sppequ.c
deleted file mode 100644
index cb48454..0000000
--- a/sppequ.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sppequ_(char *uplo, integer *n, real *ap, real *s, real *scond, real *amax, integer *info);
-
-static VALUE
-rb_sppequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.sppequ( uplo, ap)\n or\n NumRu::Lapack.sppequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* SPPEQU computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
-
- sppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_sppequ(VALUE mLapack){
- rb_define_module_function(mLapack, "sppequ", rb_sppequ, -1);
-}
diff --git a/spprfs.c b/spprfs.c
deleted file mode 100644
index fa8e0fe..0000000
--- a/spprfs.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spprfs_(char *uplo, integer *n, integer *nrhs, real *ap, real *afp, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_spprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_afp;
- real *afp;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.spprfs( uplo, ap, afp, b, x)\n or\n NumRu::Lapack.spprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) REAL array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\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 SPPTRS.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SFLOAT)
- rb_afp = na_change_type(rb_afp, NA_SFLOAT);
- afp = NA_PTR_TYPE(rb_afp, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- spprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_spprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "spprfs", rb_spprfs, -1);
-}
diff --git a/sppsv.c b/sppsv.c
deleted file mode 100644
index 4dc2d5f..0000000
--- a/sppsv.c
+++ /dev/null
@@ -1,85 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sppsv_(char *uplo, integer *n, integer *nrhs, real *ap, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sppsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.sppsv( uplo, n, ap, b)\n or\n NumRu::Lapack.sppsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. \n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPPTRF, SPPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_sppsv(VALUE mLapack){
- rb_define_module_function(mLapack, "sppsv", rb_sppsv, -1);
-}
diff --git a/sppsvx.c b/sppsvx.c
deleted file mode 100644
index e0777a9..0000000
--- a/sppsvx.c
+++ /dev/null
@@ -1,172 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sppsvx_(char *fact, char *uplo, integer *n, integer *nrhs, real *ap, real *afp, char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sppsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_afp;
- real *afp;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- VALUE rb_afp_out__;
- real *afp_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.sppsvx( fact, uplo, ap, afp, equed, s, b)\n or\n NumRu::Lapack.sppsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n* compute the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) REAL array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L', in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the original matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U'*U or A = L*L' of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SFLOAT)
- rb_afp = na_change_type(rb_afp, NA_SFLOAT);
- afp = NA_PTR_TYPE(rb_afp, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, real*);
- MEMCPY(afp_out__, afp, real, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ap, rb_afp, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_sppsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sppsvx", rb_sppsvx, -1);
-}
diff --git a/spptrf.c b/spptrf.c
deleted file mode 100644
index a48d196..0000000
--- a/spptrf.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spptrf_(char *uplo, integer *n, real *ap, integer *info);
-
-static VALUE
-rb_spptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.spptrf( uplo, n, ap)\n or\n NumRu::Lapack.spptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* SPPTRF computes the Cholesky factorization of a real symmetric\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**T * U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**T*U or A = L*L**T, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ======= =======\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- spptrf_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_spptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "spptrf", rb_spptrf, -1);
-}
diff --git a/spptri.c b/spptri.c
deleted file mode 100644
index 34b4d32..0000000
--- a/spptri.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spptri_(char *uplo, integer *n, real *ap, integer *info);
-
-static VALUE
-rb_spptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.spptri( uplo, n, ap)\n or\n NumRu::Lapack.spptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* SPPTRI computes the inverse of a real symmetric positive definite\n* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n* computed by SPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\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 triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (symmetric)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- spptri_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_spptri(VALUE mLapack){
- rb_define_module_function(mLapack, "spptri", rb_spptri, -1);
-}
diff --git a/spptrs.c b/spptrs.c
deleted file mode 100644
index a039f23..0000000
--- a/spptrs.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spptrs_(char *uplo, integer *n, integer *nrhs, real *ap, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_spptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spptrs( uplo, n, ap, b)\n or\n NumRu::Lapack.spptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPPTRS solves a system of linear equations A*X = B with a symmetric\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**T*U or A = L*L**T computed by SPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) REAL array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL STPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- spptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_spptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "spptrs", rb_spptrs, -1);
-}
diff --git a/spstf2.c b/spstf2.c
deleted file mode 100644
index e3a3f48..0000000
--- a/spstf2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spstf2_(char *uplo, integer *n, real *a, integer *lda, integer *piv, integer *rank, real *tol, real *work, integer *info);
-
-static VALUE
-rb_spstf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_tol;
- real tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.spstf2( uplo, a, tol)\n or\n NumRu::Lapack.spstf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPSTF2 computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- tol = (real)NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (2*n));
-
- spstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_spstf2(VALUE mLapack){
- rb_define_module_function(mLapack, "spstf2", rb_spstf2, -1);
-}
diff --git a/spstrf.c b/spstrf.c
deleted file mode 100644
index 685652f..0000000
--- a/spstrf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spstrf_(char *uplo, integer *n, real *a, integer *lda, integer *piv, integer *rank, real *tol, real *work, integer *info);
-
-static VALUE
-rb_spstrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_tol;
- real tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.spstrf( uplo, a, tol)\n or\n NumRu::Lapack.spstrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPSTRF computes the Cholesky factorization with complete\n* pivoting of a real symmetric positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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) REAL 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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) REAL\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- tol = (real)NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (2*n));
-
- spstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_spstrf(VALUE mLapack){
- rb_define_module_function(mLapack, "spstrf", rb_spstrf, -1);
-}
diff --git a/sptcon.c b/sptcon.c
deleted file mode 100644
index ac44e14..0000000
--- a/sptcon.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sptcon_(integer *n, real *d, real *e, real *anorm, real *rcond, real *work, integer *info);
-
-static VALUE
-rb_sptcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.sptcon( d, e, anorm)\n or\n NumRu::Lapack.sptcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric positive definite tridiagonal matrix\n* using the factorization A = L*D*L**T or A = U**T*D*U computed by\n* SPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by SPTTRF.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by SPTTRF.\n*\n* ANORM (input) REAL\n* The 1-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 the\n* 1-norm of inv(A) computed in this routine.\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_anorm = argv[2];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- work = ALLOC_N(real, (n));
-
- sptcon_(&n, d, e, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_sptcon(VALUE mLapack){
- rb_define_module_function(mLapack, "sptcon", rb_sptcon, -1);
-}
diff --git a/spteqr.c b/spteqr.c
deleted file mode 100644
index a7cb71c..0000000
--- a/spteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spteqr_(char *compz, integer *n, real *d, real *e, real *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_spteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_z_out__;
- real *z_out__;
- real *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.spteqr( compz, d, e, z)\n or\n NumRu::Lapack.spteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using SPTTRF, and then calling SBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band symmetric positive definite matrix\n* can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n* form, however, may preclude the possibility of obtaining high\n* relative accuracy in the small eigenvalues of the original matrix, if\n* these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original symmetric\n* matrix also. Array Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal\n* matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the orthogonal matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original symmetric matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(real, (4*n));
-
- spteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_spteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "spteqr", rb_spteqr, -1);
-}
diff --git a/sptrfs.c b/sptrfs.c
deleted file mode 100644
index b1a84d1..0000000
--- a/sptrfs.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sptrfs_(integer *n, integer *nrhs, real *d, real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *info);
-
-static VALUE
-rb_sptrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_df;
- real *df;
- VALUE rb_ef;
- real *ef;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.sptrfs( d, e, df, ef, b, x)\n or\n NumRu::Lapack.sptrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization computed by SPTTRF.\n*\n* EF (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the factorization computed by SPTTRF.\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 SPTTRS.\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 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).\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 (2*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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_df = argv[2];
- rb_ef = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (3th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_df);
- if (NA_TYPE(rb_df) != NA_SFLOAT)
- rb_df = na_change_type(rb_df, NA_SFLOAT);
- df = NA_PTR_TYPE(rb_df, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (4th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_SFLOAT)
- rb_ef = na_change_type(rb_ef, NA_SFLOAT);
- ef = NA_PTR_TYPE(rb_ef, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (2*n));
-
- sptrfs_(&n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_sptrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "sptrfs", rb_sptrfs, -1);
-}
diff --git a/sptsv.c b/sptsv.c
deleted file mode 100644
index 5e3c80c..0000000
--- a/sptsv.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sptsv_(integer *n, integer *nrhs, real *d, real *e, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sptsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.sptsv( d, e, b)\n or\n NumRu::Lapack.sptsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPTSV computes the solution to a real system of linear equations\n* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**T, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**T.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**T factorization of\n* A. (E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**T*D*U factorization of A.)\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL SPTTRF, SPTTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sptsv_(&n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_sptsv(VALUE mLapack){
- rb_define_module_function(mLapack, "sptsv", rb_sptsv, -1);
-}
diff --git a/sptsvx.c b/sptsvx.c
deleted file mode 100644
index 5a519b2..0000000
--- a/sptsvx.c
+++ /dev/null
@@ -1,149 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sptsvx_(char *fact, integer *n, integer *nrhs, real *d, real *e, real *df, real *ef, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *info);
-
-static VALUE
-rb_sptsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_df;
- real *df;
- VALUE rb_ef;
- real *ef;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_df_out__;
- real *df_out__;
- VALUE rb_ef_out__;
- real *ef_out__;
- real *work;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.sptsvx( fact, d, e, df, ef, b)\n or\n NumRu::Lapack.sptsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SPTSVX uses the factorization A = L*D*L**T to compute the solution\n* to a real system of linear equations A*X = B, where A is an N-by-N\n* symmetric positive definite tridiagonal matrix and X and B are\n* N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**T*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) REAL array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**T factorization of A.\n*\n* EF (input or output) REAL array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**T factorization of A.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) REAL array, dimension (NRHS)\n* The 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).\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 any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) REAL array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_df = argv[3];
- rb_ef = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (4th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_df);
- if (NA_TYPE(rb_df) != NA_SFLOAT)
- rb_df = na_change_type(rb_df, NA_SFLOAT);
- df = NA_PTR_TYPE(rb_df, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_SFLOAT)
- rb_ef = na_change_type(rb_ef, NA_SFLOAT);
- ef = NA_PTR_TYPE(rb_ef, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, real*);
- MEMCPY(df_out__, df, real, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_ef_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ef_out__ = NA_PTR_TYPE(rb_ef_out__, real*);
- MEMCPY(ef_out__, ef, real, NA_TOTAL(rb_ef));
- rb_ef = rb_ef_out__;
- ef = ef_out__;
- work = ALLOC_N(real, (2*n));
-
- sptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_df, rb_ef);
-}
-
-void
-init_lapack_sptsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sptsvx", rb_sptsvx, -1);
-}
diff --git a/spttrf.c b/spttrf.c
deleted file mode 100644
index 2a7229b..0000000
--- a/spttrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spttrf_(integer *n, real *d, real *e, integer *info);
-
-static VALUE
-rb_spttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.spttrf( d, e)\n or\n NumRu::Lapack.spttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* SPTTRF computes the L*D*L' factorization of a real symmetric\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- spttrf_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_spttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "spttrf", rb_spttrf, -1);
-}
diff --git a/spttrs.c b/spttrs.c
deleted file mode 100644
index de2c4a0..0000000
--- a/spttrs.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID spttrs_(integer *n, integer *nrhs, real *d, real *e, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_spttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.spttrs( d, e, b)\n or\n NumRu::Lapack.spttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by SPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n INTEGER J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SPTTS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- spttrs_(&n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_spttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "spttrs", rb_spttrs, -1);
-}
diff --git a/sptts2.c b/sptts2.c
deleted file mode 100644
index 2ee753e..0000000
--- a/sptts2.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sptts2_(integer *n, integer *nrhs, real *d, real *e, real *b, integer *ldb);
-
-static VALUE
-rb_sptts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_b;
- real *b;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.sptts2( d, e, b)\n or\n NumRu::Lapack.sptts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* SPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the L*D*L' factorization of A computed by SPTTRF. D is a\n* diagonal matrix specified in the vector D, L is a unit bidiagonal\n* matrix whose subdiagonal is specified in the vector E, and X and B\n* are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) REAL array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* L*D*L' factorization of A.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the unit bidiagonal factor\n* L from the L*D*L' factorization of A. E can also be regarded\n* as the superdiagonal of the unit bidiagonal factor U from the\n* factorization A = U'*D*U.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL SSCAL\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sptts2_(&n, &nrhs, d, e, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_sptts2(VALUE mLapack){
- rb_define_module_function(mLapack, "sptts2", rb_sptts2, -1);
-}
diff --git a/srscl.c b/srscl.c
deleted file mode 100644
index 77db90d..0000000
--- a/srscl.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID srscl_(integer *n, real *sa, real *sx, integer *incx);
-
-static VALUE
-rb_srscl(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_sa;
- real sa;
- VALUE rb_sx;
- real *sx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_sx_out__;
- real *sx_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sx = NumRu::Lapack.srscl( n, sa, sx, incx)\n or\n NumRu::Lapack.srscl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* SRSCL multiplies an n-element real vector x by the real scalar 1/a.\n* This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) REAL\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) REAL array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_sa = argv[1];
- rb_sx = argv[2];
- rb_incx = argv[3];
-
- sa = (real)NUM2DBL(rb_sa);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_sx))
- rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
- if (NA_RANK(rb_sx) != 1)
- rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sx) != (1+(n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
- if (NA_TYPE(rb_sx) != NA_SFLOAT)
- rb_sx = na_change_type(rb_sx, NA_SFLOAT);
- sx = NA_PTR_TYPE(rb_sx, real*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*abs(incx);
- rb_sx_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sx_out__ = NA_PTR_TYPE(rb_sx_out__, real*);
- MEMCPY(sx_out__, sx, real, NA_TOTAL(rb_sx));
- rb_sx = rb_sx_out__;
- sx = sx_out__;
-
- srscl_(&n, &sa, sx, &incx);
-
- return rb_sx;
-}
-
-void
-init_lapack_srscl(VALUE mLapack){
- rb_define_module_function(mLapack, "srscl", rb_srscl, -1);
-}
diff --git a/ssbev.c b/ssbev.c
deleted file mode 100644
index f15f187..0000000
--- a/ssbev.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbev_(char *jobz, char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *w, real *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_ssbev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- real *work;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.ssbev( jobz, uplo, kd, ab)\n or\n NumRu::Lapack.ssbev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(real, (MAX(1,3*n-2)));
-
- ssbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ab);
-}
-
-void
-init_lapack_ssbev(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbev", rb_ssbev, -1);
-}
diff --git a/ssbevd.c b/ssbevd.c
deleted file mode 100644
index 7b0c4fe..0000000
--- a/ssbevd.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbevd_(char *jobz, char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *w, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_ssbevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab = NumRu::Lapack.ssbevd( jobz, uplo, kd, ab, lwork, liwork)\n or\n NumRu::Lapack.ssbevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a real symmetric band matrix A. If eigenvectors are desired, it uses\n* a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array,\n* dimension (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.\n* IF N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 2, LWORK must be at least\n* ( 1 + 5*N + 2*N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array LIWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_lwork = argv[4];
- rb_liwork = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- liwork = NUM2INT(rb_liwork);
- jobz = StringValueCStr(rb_jobz)[0];
- lwork = NUM2INT(rb_lwork);
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- ssbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ab);
-}
-
-void
-init_lapack_ssbevd(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbevd", rb_ssbevd, -1);
-}
diff --git a/ssbevx.c b/ssbevx.c
deleted file mode 100644
index e2bce68..0000000
--- a/ssbevx.c
+++ /dev/null
@@ -1,138 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbevx_(char *jobz, char *range, char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *q, integer *ldq, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_ssbevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_q;
- real *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.ssbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.ssbevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric band matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) REAL array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_vl = argv[5];
- rb_vu = argv[6];
- rb_il = argv[7];
- rb_iu = argv[8];
- rb_abstol = argv[9];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(real, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- ssbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_q, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ab);
-}
-
-void
-init_lapack_ssbevx(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbevx", rb_ssbevx, -1);
-}
diff --git a/ssbgst.c b/ssbgst.c
deleted file mode 100644
index 786b343..0000000
--- a/ssbgst.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbgst_(char *vect, char *uplo, integer *n, integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *x, integer *ldx, real *work, integer *info);
-
-static VALUE
-rb_ssbgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- real *ab;
- VALUE rb_bb;
- real *bb;
- VALUE rb_x;
- real *x;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- real *work;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, info, ab = NumRu::Lapack.ssbgst( vect, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.ssbgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBGST reduces a real symmetric-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**T*S by SPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**T*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) REAL array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by SPBSTF, stored in the first KB+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) REAL array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) REAL array, dimension (2*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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SFLOAT)
- rb_bb = na_change_type(rb_bb, NA_SFLOAT);
- bb = NA_PTR_TYPE(rb_bb, real*);
- ka = NUM2INT(rb_ka);
- vect = StringValueCStr(rb_vect)[0];
- kb = NUM2INT(rb_kb);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(real, (2*n));
-
- ssbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_x, rb_info, rb_ab);
-}
-
-void
-init_lapack_ssbgst(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbgst", rb_ssbgst, -1);
-}
diff --git a/ssbgv.c b/ssbgv.c
deleted file mode 100644
index 8ddf189..0000000
--- a/ssbgv.c
+++ /dev/null
@@ -1,118 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbgv_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *w, real *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_ssbgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- real *ab;
- VALUE rb_bb;
- real *bb;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_bb_out__;
- real *bb_out__;
- real *work;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.ssbgv( jobz, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.ssbgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) REAL array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by SPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SFLOAT)
- rb_bb = na_change_type(rb_bb, NA_SFLOAT);
- bb = NA_PTR_TYPE(rb_bb, real*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- kb = NUM2INT(rb_kb);
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, real*);
- MEMCPY(bb_out__, bb, real, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
- work = ALLOC_N(real, (3*n));
-
- ssbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_ssbgv(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbgv", rb_ssbgv, -1);
-}
diff --git a/ssbgvd.c b/ssbgvd.c
deleted file mode 100644
index 9a2f0d5..0000000
--- a/ssbgvd.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbgvd_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *w, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_ssbgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- real *ab;
- VALUE rb_bb;
- real *bb;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_bb_out__;
- real *bb_out__;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ab, bb = NumRu::Lapack.ssbgvd( jobz, uplo, ka, kb, ab, bb, lwork, liwork)\n or\n NumRu::Lapack.ssbgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of the\n* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and\n* banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) REAL array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by SPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
- rb_lwork = argv[6];
- rb_liwork = argv[7];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SFLOAT)
- rb_bb = na_change_type(rb_bb, NA_SFLOAT);
- bb = NA_PTR_TYPE(rb_bb, real*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kb = NUM2INT(rb_kb);
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, real*);
- MEMCPY(bb_out__, bb, real, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
-
- ssbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_ssbgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbgvd", rb_ssbgvd, -1);
-}
diff --git a/ssbgvx.c b/ssbgvx.c
deleted file mode 100644
index 177930a..0000000
--- a/ssbgvx.c
+++ /dev/null
@@ -1,178 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbgvx_(char *jobz, char *range, char *uplo, integer *n, integer *ka, integer *kb, real *ab, integer *ldab, real *bb, integer *ldbb, real *q, integer *ldq, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_ssbgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- real *ab;
- VALUE rb_bb;
- real *bb;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_q;
- real *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_bb_out__;
- real *bb_out__;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.ssbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.ssbgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSBGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) REAL array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**T*S, as returned by SPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) REAL array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so Z**T*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array, dimension (7N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (5N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvalues that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0 : successful exit\n* < 0 : if INFO = -i, the i-th argument had an illegal value\n* <= N: if INFO = i, then i eigenvectors failed to converge.\n* Their indices are stored in IFAIL.\n* > N : SPBSTF returned an error code; i.e.,\n* if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ka = argv[3];
- rb_kb = argv[4];
- rb_ab = argv[5];
- rb_bb = argv[6];
- rb_vl = argv[7];
- rb_vu = argv[8];
- rb_il = argv[9];
- rb_iu = argv[10];
- rb_abstol = argv[11];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_SFLOAT)
- rb_bb = na_change_type(rb_bb, NA_SFLOAT);
- bb = NA_PTR_TYPE(rb_bb, real*);
- ka = NUM2INT(rb_ka);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- kb = NUM2INT(rb_kb);
- range = StringValueCStr(rb_range)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- uplo = StringValueCStr(rb_uplo)[0];
- ldq = 1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = 7*n;
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = 5*n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = m;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, real*);
- MEMCPY(bb_out__, bb, real, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
-
- ssbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_q, rb_m, rb_w, rb_z, rb_work, rb_iwork, rb_ifail, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_ssbgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbgvx", rb_ssbgvx, -1);
-}
diff --git a/ssbtrd.c b/ssbtrd.c
deleted file mode 100644
index 48d718d..0000000
--- a/ssbtrd.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssbtrd_(char *vect, char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *d, real *e, real *q, integer *ldq, real *work, integer *info);
-
-static VALUE
-rb_ssbtrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_q;
- real *q;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- real *ab_out__;
- VALUE rb_q_out__;
- real *q_out__;
- real *work;
-
- integer ldab;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.ssbtrd( vect, uplo, kd, ab, q)\n or\n NumRu::Lapack.ssbtrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSBTRD reduces a real symmetric band matrix A to symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) REAL array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) REAL 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_q = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- vect = StringValueCStr(rb_vect)[0];
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of ab");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, real*);
- MEMCPY(ab_out__, ab, real, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(real, (n));
-
- ssbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_info, rb_ab, rb_q);
-}
-
-void
-init_lapack_ssbtrd(VALUE mLapack){
- rb_define_module_function(mLapack, "ssbtrd", rb_ssbtrd, -1);
-}
diff --git a/ssfrk.c b/ssfrk.c
deleted file mode 100644
index 57990f4..0000000
--- a/ssfrk.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssfrk_(char *transr, char *uplo, char *trans, integer *n, integer *k, real *alpha, real *a, integer *lda, real *beta, real *c);
-
-static VALUE
-rb_ssfrk(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- real *a;
- VALUE rb_beta;
- real beta;
- VALUE rb_c;
- real *c;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer nt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.ssfrk( transr, uplo, trans, n, k, alpha, a, beta, c)\n or\n NumRu::Lapack.ssfrk # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* SSFRK performs one of the symmetric rank--k operations\n*\n* C := alpha*A*A' + beta*C,\n*\n* or\n*\n* C := alpha*A'*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n symmetric\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.\n*\n* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with TRANS = 'T'\n* or 't', K specifies the number of rows of the matrix A. K\n* must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) REAL array of DIMENSION (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) REAL\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n*\n* C (input/output) REAL array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n* Format. RFP Format is described by TRANSR, UPLO and N.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_n = argv[3];
- rb_k = argv[4];
- rb_alpha = argv[5];
- rb_a = argv[6];
- rb_beta = argv[7];
- rb_c = argv[8];
-
- k = NUM2INT(rb_k);
- transr = StringValueCStr(rb_transr)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- nt = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha = (real)NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- beta = (real)NUM2DBL(rb_beta);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != ((lsame_(&trans,"N") || lsame_(&trans,"n")) ? k : n))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", (lsame_(&trans,"N") || lsame_(&trans,"n")) ? k : n);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = nt;
- rb_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- ssfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
-
- return rb_c;
-}
-
-void
-init_lapack_ssfrk(VALUE mLapack){
- rb_define_module_function(mLapack, "ssfrk", rb_ssfrk, -1);
-}
diff --git a/sspcon.c b/sspcon.c
deleted file mode 100644
index 6d14caa..0000000
--- a/sspcon.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspcon_(char *uplo, integer *n, real *ap, integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sspcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.sspcon( uplo, ap, ipiv, anorm)\n or\n NumRu::Lapack.sspcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric packed matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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 block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\n*\n* ANORM (input) REAL\n* The 1-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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- work = ALLOC_N(real, (2*n));
- iwork = ALLOC_N(integer, (n));
-
- sspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_sspcon(VALUE mLapack){
- rb_define_module_function(mLapack, "sspcon", rb_sspcon, -1);
-}
diff --git a/sspev.c b/sspev.c
deleted file mode 100644
index f421007..0000000
--- a/sspev.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspev_(char *jobz, char *uplo, integer *n, real *ap, real *w, real *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_sspev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- real *work;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.sspev( jobz, uplo, ap)\n or\n NumRu::Lapack.sspev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(real, (3*n));
-
- sspev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ap);
-}
-
-void
-init_lapack_sspev(VALUE mLapack){
- rb_define_module_function(mLapack, "sspev", rb_sspev, -1);
-}
diff --git a/sspevd.c b/sspevd.c
deleted file mode 100644
index 8f6fc2f..0000000
--- a/sspevd.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspevd_(char *jobz, char *uplo, integer *n, real *ap, real *w, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_sspevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap = NumRu::Lapack.sspevd( jobz, uplo, ap, lwork, liwork)\n or\n NumRu::Lapack.sspevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPEVD computes all the eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least\n* 1 + 6*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_lwork = argv[3];
- rb_liwork = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- sspevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ap);
-}
-
-void
-init_lapack_sspevd(VALUE mLapack){
- rb_define_module_function(mLapack, "sspevd", rb_sspevd, -1);
-}
diff --git a/sspevx.c b/sspevx.c
deleted file mode 100644
index 49d47d4..0000000
--- a/sspevx.c
+++ /dev/null
@@ -1,122 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspevx_(char *jobz, char *range, char *uplo, integer *n, real *ap, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_sspevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- real *work;
- integer *iwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.sspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.sspevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A in packed storage. Eigenvalues/vectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- il = NUM2INT(rb_il);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(real, (8*n));
- iwork = ALLOC_N(integer, (5*n));
-
- sspevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap);
-}
-
-void
-init_lapack_sspevx(VALUE mLapack){
- rb_define_module_function(mLapack, "sspevx", rb_sspevx, -1);
-}
diff --git a/sspgst.c b/sspgst.c
deleted file mode 100644
index f0839bc..0000000
--- a/sspgst.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspgst_(integer *itype, char *uplo, integer *n, real *ap, real *bp, integer *info);
-
-static VALUE
-rb_sspgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_bp;
- real *bp;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.sspgst( itype, uplo, n, ap, bp)\n or\n NumRu::Lapack.sspgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* SSPGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by SPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) REAL array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by SPPTRF.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- itype = NUM2INT(rb_itype);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SFLOAT)
- rb_bp = na_change_type(rb_bp, NA_SFLOAT);
- bp = NA_PTR_TYPE(rb_bp, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- sspgst_(&itype, &uplo, &n, ap, bp, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_sspgst(VALUE mLapack){
- rb_define_module_function(mLapack, "sspgst", rb_sspgst, -1);
-}
diff --git a/sspgv.c b/sspgv.c
deleted file mode 100644
index 56e12ce..0000000
--- a/sspgv.c
+++ /dev/null
@@ -1,110 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspgv_(integer *itype, char *jobz, char *uplo, integer *n, real *ap, real *bp, real *w, real *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_sspgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_bp;
- real *bp;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- VALUE rb_bp_out__;
- real *bp_out__;
- real *work;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.sspgv( itype, jobz, uplo, ap, bp)\n or\n NumRu::Lapack.sspgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) REAL array, dimension\n* (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: SPPTRF or SSPEV returned an error code:\n* <= N: if INFO = i, SSPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero.\n* > N: if INFO = n + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPPTRF, SSPEV, SSPGST, STPMV, STPSV, XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SFLOAT)
- rb_bp = na_change_type(rb_bp, NA_SFLOAT);
- bp = NA_PTR_TYPE(rb_bp, real*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, real*);
- MEMCPY(bp_out__, bp, real, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(real, (3*n));
-
- sspgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_sspgv(VALUE mLapack){
- rb_define_module_function(mLapack, "sspgv", rb_sspgv, -1);
-}
diff --git a/sspgvd.c b/sspgvd.c
deleted file mode 100644
index ff4c57d..0000000
--- a/sspgvd.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspgvd_(integer *itype, char *jobz, char *uplo, integer *n, real *ap, real *bp, real *w, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_sspgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_bp;
- real *bp;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- VALUE rb_bp_out__;
- real *bp_out__;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, iwork, info, ap, bp = NumRu::Lapack.sspgvd( itype, jobz, uplo, ap, bp, lwork, liwork)\n or\n NumRu::Lapack.sspgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: SPPTRF or SSPEVD returned an error code:\n* <= N: if INFO = i, SSPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
- rb_lwork = argv[5];
- rb_liwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SFLOAT)
- rb_bp = na_change_type(rb_bp, NA_SFLOAT);
- bp = NA_PTR_TYPE(rb_bp, real*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, real*);
- MEMCPY(bp_out__, bp, real, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
-
- sspgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_iwork, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_sspgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "sspgvd", rb_sspgvd, -1);
-}
diff --git a/sspgvx.c b/sspgvx.c
deleted file mode 100644
index 7447f93..0000000
--- a/sspgvx.c
+++ /dev/null
@@ -1,151 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspgvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, real *ap, real *bp, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_sspgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_bp;
- real *bp;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- VALUE rb_bp_out__;
- real *bp_out__;
- real *work;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.sspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)\n or\n NumRu::Lapack.sspgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSPGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric, stored in packed storage, and B\n* is also positive definite. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T, in the same storage\n* format as B.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (8*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: SPPTRF or SSPEVX returned an error code:\n* <= N: if INFO = i, SSPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_ap = argv[4];
- rb_bp = argv[5];
- rb_vl = argv[6];
- rb_vu = argv[7];
- rb_il = argv[8];
- rb_iu = argv[9];
- rb_abstol = argv[10];
- rb_ldz = argv[11];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_SFLOAT)
- rb_bp = na_change_type(rb_bp, NA_SFLOAT);
- bp = NA_PTR_TYPE(rb_bp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, real*);
- MEMCPY(bp_out__, bp, real, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(real, (8*n));
- iwork = ALLOC_N(integer, (5*n));
-
- sspgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_sspgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sspgvx", rb_sspgvx, -1);
-}
diff --git a/ssprfs.c b/ssprfs.c
deleted file mode 100644
index 277a4b8..0000000
--- a/ssprfs.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssprfs_(char *uplo, integer *n, integer *nrhs, real *ap, real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_ssprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_afp;
- real *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.ssprfs( uplo, ap, afp, ipiv, b, x)\n or\n NumRu::Lapack.ssprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix A, packed\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*\n* AFP (input) REAL array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by SSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\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 SSPTRS.\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SFLOAT)
- rb_afp = na_change_type(rb_afp, NA_SFLOAT);
- afp = NA_PTR_TYPE(rb_afp, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- ssprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_ssprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ssprfs", rb_ssprfs, -1);
-}
diff --git a/sspsv.c b/sspsv.c
deleted file mode 100644
index a901547..0000000
--- a/sspsv.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspsv_(char *uplo, integer *n, integer *nrhs, real *ap, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_sspsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_b;
- real *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldb;
- integer nrhs;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.sspsv( uplo, ap, b)\n or\n NumRu::Lapack.sspsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSPSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) REAL array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by SSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSPTRF, SSPTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- sspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_sspsv(VALUE mLapack){
- rb_define_module_function(mLapack, "sspsv", rb_sspsv, -1);
-}
diff --git a/sspsvx.c b/sspsvx.c
deleted file mode 100644
index 736494b..0000000
--- a/sspsvx.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sspsvx_(char *fact, char *uplo, integer *n, integer *nrhs, real *ap, real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sspsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_afp;
- real *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_afp_out__;
- real *afp_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.sspsvx( fact, uplo, ap, afp, ipiv, b)\n or\n NumRu::Lapack.sspsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a real system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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 triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) REAL array, dimension\n* (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by SSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by SSPTRF.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_SFLOAT)
- rb_afp = na_change_type(rb_afp, NA_SFLOAT);
- afp = NA_PTR_TYPE(rb_afp, real*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, real*);
- MEMCPY(afp_out__, afp, real, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- sspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_afp, rb_ipiv);
-}
-
-void
-init_lapack_sspsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "sspsvx", rb_sspsvx, -1);
-}
diff --git a/ssptrd.c b/ssptrd.c
deleted file mode 100644
index f875f03..0000000
--- a/ssptrd.c
+++ /dev/null
@@ -1,81 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssptrd_(char *uplo, integer *n, real *ap, real *d, real *e, real *tau, integer *info);
-
-static VALUE
-rb_ssptrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.ssptrd( uplo, ap)\n or\n NumRu::Lapack.ssptrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRD reduces a real symmetric matrix A stored in packed form to\n* symmetric tridiagonal form T by an orthogonal similarity\n* transformation: Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- ssptrd_(&uplo, &n, ap, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_ap);
-}
-
-void
-init_lapack_ssptrd(VALUE mLapack){
- rb_define_module_function(mLapack, "ssptrd", rb_ssptrd, -1);
-}
diff --git a/ssptrf.c b/ssptrf.c
deleted file mode 100644
index cf64fee..0000000
--- a/ssptrf.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssptrf_(char *uplo, integer *n, real *ap, integer *ipiv, integer *info);
-
-static VALUE
-rb_ssptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.ssptrf( uplo, ap)\n or\n NumRu::Lapack.ssptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRF computes the factorization of a real symmetric matrix A stored\n* in packed format using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- ssptrf_(&uplo, &n, ap, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ap);
-}
-
-void
-init_lapack_ssptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "ssptrf", rb_ssptrf, -1);
-}
diff --git a/ssptri.c b/ssptri.c
deleted file mode 100644
index 72f49e2..0000000
--- a/ssptri.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssptri_(char *uplo, integer *n, real *ap, integer *ipiv, real *work, integer *info);
-
-static VALUE
-rb_ssptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
- real *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.ssptri( uplo, ap, ipiv)\n or\n NumRu::Lapack.ssptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRI computes the inverse of a real symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by SSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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 block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\n*\n* WORK (workspace) REAL 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(real, (n));
-
- ssptri_(&uplo, &n, ap, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_ssptri(VALUE mLapack){
- rb_define_module_function(mLapack, "ssptri", rb_ssptri, -1);
-}
diff --git a/ssptrs.c b/ssptrs.c
deleted file mode 100644
index 3a59d48..0000000
--- a/ssptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssptrs_(char *uplo, integer *n, integer *nrhs, real *ap, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ssptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ssptrs( uplo, ap, ipiv, b)\n or\n NumRu::Lapack.ssptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSPTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) REAL array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSPTRF.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ssptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ssptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ssptrs", rb_ssptrs, -1);
-}
diff --git a/sstebz.c b/sstebz.c
deleted file mode 100644
index 8a26862..0000000
--- a/sstebz.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstebz_(char *range, char *order, integer *n, real *vl, real *vu, integer *il, integer *iu, real *abstol, real *d, real *e, integer *m, integer *nsplit, real *w, integer *iblock, integer *isplit, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_sstebz(int argc, VALUE *argv, VALUE self){
- VALUE rb_range;
- char range;
- VALUE rb_order;
- char order;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_m;
- integer m;
- VALUE rb_nsplit;
- integer nsplit;
- VALUE rb_w;
- real *w;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, nsplit, w, iblock, isplit, info = NumRu::Lapack.sstebz( range, order, vl, vu, il, iu, abstol, d, e)\n or\n NumRu::Lapack.sstebz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEBZ computes the eigenvalues of a symmetric tridiagonal\n* matrix T. The user may ask for all eigenvalues, all eigenvalues\n* in the half-open interval (VL, VU], or the IL-th through IU-th\n* eigenvalues.\n*\n* To avoid overflow, the matrix must be scaled so that its\n* largest element is no greater than overflow**(1/2) *\n* underflow**(1/4) in absolute value, and for greatest\n* accuracy, it should not be much smaller than that.\n*\n* See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n* Matrix\", Report CS41, Computer Science Dept., Stanford\n* University, July 21, 1966.\n*\n\n* Arguments\n* =========\n*\n* RANGE (input) CHARACTER*1\n* = 'A': (\"All\") all eigenvalues will be found.\n* = 'V': (\"Value\") all eigenvalues in the half-open interval\n* (VL, VU] will be found.\n* = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n* entire matrix) will be found.\n*\n* ORDER (input) CHARACTER*1\n* = 'B': (\"By Block\") the eigenvalues will be grouped by\n* split-off block (see IBLOCK, ISPLIT) and\n* ordered from smallest to largest within\n* the block.\n* = 'E': (\"Entire matrix\")\n* the eigenvalues for the entire matrix\n* will be ordered from smallest to\n* largest.\n*\n* N (input) INTEGER\n* The order of the tridiagonal matrix T. N >= 0.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. Eigenvalues less than or equal\n* to VL, or greater than VU, will not be returned. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute tolerance for the eigenvalues. An eigenvalue\n* (or cluster) is considered to be located if it has been\n* determined to lie in an interval whose width is ABSTOL or\n* less. If ABSTOL is less than or equal to zero, then ULP*|T|\n* will be used, where |T| means the 1-norm of T.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n* M (output) INTEGER\n* The actual number of eigenvalues found. 0 <= M <= N.\n* (See also the description of INFO=2,3.)\n*\n* NSPLIT (output) INTEGER\n* The number of diagonal blocks in the matrix T.\n* 1 <= NSPLIT <= N.\n*\n* W (output) REAL array, dimension (N)\n* On exit, the first M elements of W will contain the\n* eigenvalues. (SSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* IBLOCK (output) INTEGER array, dimension (N)\n* At each row/column j where E(j) is zero or small, the\n* matrix T is considered to split into a block diagonal\n* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n* block (from 1 to the number of blocks) the eigenvalue W(i)\n* belongs. (SSTEBZ may use the remaining N-M elements as\n* workspace.)\n*\n* ISPLIT (output) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to ISPLIT(1),\n* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n* etc., and the NSPLIT-th consists of rows/columns\n* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n* (Only the first NSPLIT elements will actually be used, but\n* since the user cannot know a priori what value NSPLIT will\n* have, N words must be reserved for ISPLIT.)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: some or all of the eigenvalues failed to converge or\n* were not computed:\n* =1 or 3: Bisection failed to converge for some\n* eigenvalues; these eigenvalues are flagged by a\n* negative block number. The effect is that the\n* eigenvalues may not be as accurate as the\n* absolute and relative tolerances. This is\n* generally caused by unexpectedly inaccurate\n* arithmetic.\n* =2 or 3: RANGE='I' only: Not all of the eigenvalues\n* IL:IU were found.\n* Effect: M < IU+1-IL\n* Cause: non-monotonic arithmetic, causing the\n* Sturm sequence to be non-monotonic.\n* Cure: recalculate, using RANGE='A', and pick\n* out eigenvalues IL:IU. In some cases,\n* increasing the PARAMETER \"FUDGE\" may\n* make things work.\n* = 4: RANGE='I', and the Gershgorin interval\n* initially used was too small. No eigenvalues\n* were computed.\n* Probable cause: your machine has sloppy\n* floating-point arithmetic.\n* Cure: Increase the PARAMETER \"FUDGE\",\n* recompile, and try again.\n*\n* Internal Parameters\n* ===================\n*\n* RELFAC REAL, default = 2.0e0\n* The relative tolerance. An interval (a,b] lies within\n* \"relative tolerance\" if b-a < RELFAC*ulp*max(|a|,|b|),\n* where \"ulp\" is the machine precision (distance from 1 to\n* the next larger floating point number.)\n*\n* FUDGE REAL, default = 2\n* A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n* a value of 1 should work, but on machines with sloppy\n* arithmetic, this needs to be larger. The default for\n* publicly released versions should be large enough to handle\n* the worst machine around. Note that this has no effect\n* on accuracy of the solution.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_range = argv[0];
- rb_order = argv[1];
- rb_vl = argv[2];
- rb_vu = argv[3];
- rb_il = argv[4];
- rb_iu = argv[5];
- rb_abstol = argv[6];
- rb_d = argv[7];
- rb_e = argv[8];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- il = NUM2INT(rb_il);
- range = StringValueCStr(rb_range)[0];
- vu = (real)NUM2DBL(rb_vu);
- order = StringValueCStr(rb_order)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (8th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (9th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (3*n));
-
- sstebz_(&range, &order, &n, &vl, &vu, &il, &iu, &abstol, d, e, &m, &nsplit, w, iblock, isplit, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_nsplit = INT2NUM(nsplit);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_m, rb_nsplit, rb_w, rb_iblock, rb_isplit, rb_info);
-}
-
-void
-init_lapack_sstebz(VALUE mLapack){
- rb_define_module_function(mLapack, "sstebz", rb_sstebz, -1);
-}
diff --git a/sstedc.c b/sstedc.c
deleted file mode 100644
index 1bd82d2..0000000
--- a/sstedc.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstedc_(char *compz, integer *n, real *d, real *e, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_sstedc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_z;
- real *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, iwork, info, d, e, z = NumRu::Lapack.sstedc( compz, d, e, z, lwork, liwork)\n or\n NumRu::Lapack.sstedc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band real symmetric matrix can also be\n* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See SLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original dense symmetric\n* matrix also. On entry, Z contains the orthogonal\n* matrix used to reduce the original matrix to\n* tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\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.\n* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be max(1,2*(N-1)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If COMPZ = 'V' and N > 1 then LIWORK must be at least\n* ( 6 + 6*N + 5*N*lg N ).\n* If COMPZ = 'I' and N > 1 then LIWORK must be at least\n* ( 3 + 5*N ).\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
- rb_lwork = argv[4];
- rb_liwork = argv[5];
-
- compz = StringValueCStr(rb_compz)[0];
- liwork = NUM2INT(rb_liwork);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- sstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_work, rb_iwork, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_sstedc(VALUE mLapack){
- rb_define_module_function(mLapack, "sstedc", rb_sstedc, -1);
-}
diff --git a/sstegr.c b/sstegr.c
deleted file mode 100644
index 1df5416..0000000
--- a/sstegr.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstegr_(char *jobz, char *range, integer *n, real *d, real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, integer *isuppz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_sstegr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.sstegr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* SSTEGR is a compatability wrapper around the improved SSTEMR routine.\n* See SSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : SSTEGR and SSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in SLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* SLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL SSTEMR\n* ..\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- il = NUM2INT(rb_il);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- sstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_sstegr(VALUE mLapack){
- rb_define_module_function(mLapack, "sstegr", rb_sstegr, -1);
-}
diff --git a/sstein.c b/sstein.c
deleted file mode 100644
index a158c4c..0000000
--- a/sstein.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstein_(integer *n, real *d, real *e, integer *m, real *w, integer *iblock, integer *isplit, real *z, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_sstein(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_w;
- real *w;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_z;
- real *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldz;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.sstein( d, e, w, iblock, isplit)\n or\n NumRu::Lapack.sstein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) REAL array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) REAL array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) REAL array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from SSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from SSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from SSTEBZ is expected here. )\n*\n* Z (output) REAL array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_w = argv[2];
- rb_iblock = argv[3];
- rb_isplit = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_SFLOAT)
- rb_w = na_change_type(rb_w, NA_SFLOAT);
- w = NA_PTR_TYPE(rb_w, real*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- m = n;
- ldz = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = m;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = m;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- work = ALLOC_N(real, (5*n));
- iwork = ALLOC_N(integer, (n));
-
- sstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_z, rb_ifail, rb_info);
-}
-
-void
-init_lapack_sstein(VALUE mLapack){
- rb_define_module_function(mLapack, "sstein", rb_sstein, -1);
-}
diff --git a/sstemr.c b/sstemr.c
deleted file mode 100644
index 89a2ee8..0000000
--- a/sstemr.c
+++ /dev/null
@@ -1,162 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstemr_(char *jobz, char *range, integer *n, real *d, real *e, real *vl, real *vu, integer *il, integer *iu, integer *m, real *w, real *z, integer *ldz, integer *nzc, integer *isuppz, logical *tryrac, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_sstemr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_nzc;
- integer nzc;
- VALUE rb_tryrac;
- logical tryrac;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.sstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)\n or\n NumRu::Lapack.sstemr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.SSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) REAL array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) REAL array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in SLARRE,\n* if INFO = 2X, internal error in SLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by SLARRE or\n* SLARRV, respectively.\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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_nzc = argv[8];
- rb_tryrac = argv[9];
- rb_lwork = argv[10];
- rb_liwork = argv[11];
-
- vl = (real)NUM2DBL(rb_vl);
- nzc = NUM2INT(rb_nzc);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- il = NUM2INT(rb_il);
- tryrac = (rb_tryrac == Qtrue);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- sstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- rb_tryrac = tryrac ? Qtrue : Qfalse;
- return rb_ary_new3(10, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e, rb_tryrac);
-}
-
-void
-init_lapack_sstemr(VALUE mLapack){
- rb_define_module_function(mLapack, "sstemr", rb_sstemr, -1);
-}
diff --git a/ssteqr.c b/ssteqr.c
deleted file mode 100644
index 3ff307d..0000000
--- a/ssteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssteqr_(char *compz, integer *n, real *d, real *e, real *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_ssteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- VALUE rb_z_out__;
- real *z_out__;
- real *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.ssteqr( compz, d, e, z)\n or\n NumRu::Lapack.ssteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band symmetric matrix can also be found\n* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to\n* tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* symmetric matrix. On entry, Z must contain the\n* orthogonal matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) REAL array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the orthogonal\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original symmetric matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is orthogonally similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(real, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
-
- ssteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_ssteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "ssteqr", rb_ssteqr, -1);
-}
diff --git a/ssterf.c b/ssterf.c
deleted file mode 100644
index c474c1f..0000000
--- a/ssterf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssterf_(integer *n, real *d, real *e, integer *info);
-
-static VALUE
-rb_ssterf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.ssterf( d, e)\n or\n NumRu::Lapack.ssterf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTERF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n* using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm failed to find all of the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- ssterf_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_ssterf(VALUE mLapack){
- rb_define_module_function(mLapack, "ssterf", rb_ssterf, -1);
-}
diff --git a/sstev.c b/sstev.c
deleted file mode 100644
index 39caefd..0000000
--- a/sstev.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstev_(char *jobz, integer *n, real *d, real *e, real *z, integer *ldz, real *work, integer *info);
-
-static VALUE
-rb_sstev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_z;
- real *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- real *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, info, d, e = NumRu::Lapack.sstev( jobz, d, e)\n or\n NumRu::Lapack.sstev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (max(1,2*N-2))\n* If JOBZ = 'N', WORK is not referenced.\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, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_jobz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
-
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(real, (lsame_(&jobz,"N") ? 0 : MAX(1,2*n-2)));
-
- sstev_(&jobz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_z, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_sstev(VALUE mLapack){
- rb_define_module_function(mLapack, "sstev", rb_sstev, -1);
-}
diff --git a/sstevd.c b/sstevd.c
deleted file mode 100644
index 95f7d20..0000000
--- a/sstevd.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstevd_(char *jobz, integer *n, real *d, real *e, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_sstevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, work, iwork, info, d, e = NumRu::Lapack.sstevd( jobz, d, e, lwork, liwork)\n or\n NumRu::Lapack.sstevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric tridiagonal matrix. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) REAL array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A, stored in elements 1 to N-1 of E.\n* On exit, the contents of E are destroyed.\n*\n* Z (output) REAL array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with D(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) REAL array,\n* dimension (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.\n* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LWORK must be at least\n* ( 1 + 4*N + N**2 ).\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of E did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_lwork = argv[3];
- rb_liwork = argv[4];
-
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- sstevd_(&jobz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_z, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_sstevd(VALUE mLapack){
- rb_define_module_function(mLapack, "sstevd", rb_sstevd, -1);
-}
diff --git a/sstevr.c b/sstevr.c
deleted file mode 100644
index 8a695e8..0000000
--- a/sstevr.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstevr_(char *jobz, char *range, integer *n, real *d, real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, integer *isuppz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_sstevr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstevr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.sstevr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSTEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n* Whenever possible, SSTEVR calls SSTEMR to compute the\n* eigenspectrum using Relatively Robust Representations. SSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows. For the i-th\n* unreduced block of T,\n* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n* is a relatively robust representation,\n* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n* relative accuracy by the dqds algorithm,\n* (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n* close to the cluster, and go to step (a),\n* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n* compute the corresponding eigenvector by forming a\n* rank-revealing twisted factorization.\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n* Computer Science Division Technical Report No. UCB//CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of SSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** SSTEIN are called\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) REAL array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal (and\n* minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= 20*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal (and\n* minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 10*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = NUM2INT(rb_lwork);
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (MAX(1,n-1)))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- m = lsame_(&range,"I") ? iu-il+1 : n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = MAX(1,n-1);
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- sstevr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_sstevr(VALUE mLapack){
- rb_define_module_function(mLapack, "sstevr", rb_sstevr, -1);
-}
diff --git a/sstevx.c b/sstevx.c
deleted file mode 100644
index 9f3db6b..0000000
--- a/sstevx.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID sstevx_(char *jobz, char *range, integer *n, real *d, real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, real *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_sstevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- real *d_out__;
- VALUE rb_e_out__;
- real *e_out__;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, d, e = NumRu::Lapack.sstevx( jobz, range, d, e, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.sstevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSTEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix A. Eigenvalues and\n* eigenvectors can be selected by specifying either a range of values\n* or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) REAL array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A.\n* On exit, D may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* E (input/output) REAL array, dimension (max(1,N-1))\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A in elements 1 to N-1 of E.\n* On exit, E may be multiplied by a constant factor chosen\n* to avoid over/underflow in computing the eigenvalues.\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less\n* than or equal to zero, then EPS*|T| will be used in\n* its place, where |T| is the 1-norm of the tridiagonal\n* matrix.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge (INFO > 0), then that\n* column of Z contains the latest approximation to the\n* eigenvector, and the index of the eigenvector is returned\n* in IFAIL. If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) REAL array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- il = NUM2INT(rb_il);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (MAX(1,n-1)))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- m = n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, real*);
- MEMCPY(d_out__, d, real, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = MAX(1,n-1);
- rb_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, real*);
- MEMCPY(e_out__, e, real, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- work = ALLOC_N(real, (5*n));
- iwork = ALLOC_N(integer, (5*n));
-
- sstevx_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_sstevx(VALUE mLapack){
- rb_define_module_function(mLapack, "sstevx", rb_sstevx, -1);
-}
diff --git a/ssycon.c b/ssycon.c
deleted file mode 100644
index 8ba14a9..0000000
--- a/ssycon.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssycon_(char *uplo, integer *n, real *a, integer *lda, integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_ssycon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- real anorm;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.ssycon( uplo, a, ipiv, anorm)\n or\n NumRu::Lapack.ssycon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a real symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by SSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* ANORM (input) REAL\n* The 1-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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = (real)NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (2*n));
- iwork = ALLOC_N(integer, (n));
-
- ssycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_ssycon(VALUE mLapack){
- rb_define_module_function(mLapack, "ssycon", rb_ssycon, -1);
-}
diff --git a/ssyconv.c b/ssyconv.c
deleted file mode 100644
index e9a214a..0000000
--- a/ssyconv.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyconv_(char *uplo, char *way, integer *n, real *a, integer *lda, integer *ipiv, real *work, integer *info);
-
-static VALUE
-rb_ssyconv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_way;
- char way;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info = NumRu::Lapack.ssyconv( uplo, way, a, ipiv)\n or\n NumRu::Lapack.ssyconv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYCONV convert A given by TRF into L and D and vice-versa.\n* Get Non-diag elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_way = argv[1];
- rb_a = argv[2];
- rb_ipiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- way = StringValueCStr(rb_way)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (MAX(1,n)));
-
- ssyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_info;
-}
-
-void
-init_lapack_ssyconv(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyconv", rb_ssyconv, -1);
-}
diff --git a/ssyequb.c b/ssyequb.c
deleted file mode 100644
index 817a483..0000000
--- a/ssyequb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyequb_(char *uplo, integer *n, real *a, integer *lda, real *s, real *scond, real *amax, real *work, integer *info);
-
-static VALUE
-rb_ssyequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_s;
- real *s;
- VALUE rb_scond;
- real scond;
- VALUE rb_amax;
- real amax;
- VALUE rb_info;
- integer info;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.ssyequb( uplo, a)\n or\n NumRu::Lapack.ssyequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) REAL array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) REAL\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) REAL\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) REAL array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- work = ALLOC_N(real, (3*n));
-
- ssyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
-
- free(work);
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_ssyequb(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyequb", rb_ssyequb, -1);
-}
diff --git a/ssyev.c b/ssyev.c
deleted file mode 100644
index 5cead3a..0000000
--- a/ssyev.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyev_(char *jobz, char *uplo, integer *n, real *a, integer *lda, real *w, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ssyev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.ssyev( jobz, uplo, a, lwork)\n or\n NumRu::Lapack.ssyev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEV computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for SSYTRD returned by ILAENV.\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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_ssyev(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyev", rb_ssyev, -1);
-}
diff --git a/ssyevd.c b/ssyevd.c
deleted file mode 100644
index 7fadb73..0000000
--- a/ssyevd.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyevd_(char *jobz, char *uplo, integer *n, real *a, integer *lda, real *w, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_ssyevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, iwork, info, a = NumRu::Lapack.ssyevd( jobz, uplo, a, lwork, liwork)\n or\n NumRu::Lapack.ssyevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n* real symmetric matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n* Because of large use of BLAS of level 3, SSYEVD needs N**2 more\n* workspace than SSYEVX.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) REAL array,\n* dimension (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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least \n* 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n* Modified by Francoise Tisseur, University of Tennessee.\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
- rb_liwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- liwork = NUM2INT(rb_liwork);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssyevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_ssyevd(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyevd", rb_ssyevd, -1);
-}
diff --git a/ssyevr.c b/ssyevr.c
deleted file mode 100644
index 753e3e3..0000000
--- a/ssyevr.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyevr_(char *jobz, char *range, char *uplo, integer *n, real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, integer *isuppz, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_ssyevr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.ssyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.ssyevr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* SSYEVR first reduces the matrix A to tridiagonal form T with a call\n* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute\n* the eigenspectrum using Relatively Robust Representations. SSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see SSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of SSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** SSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* future releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 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 >= max(1,26*N).\n* For optimal efficiency, LWORK >= (NB+6)*N,\n* where NB is the max of the blocksize for SSYTRD and SORMTR\n* returned by ILAENV.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- liwork = NUM2INT(rb_liwork);
- m = lsame_(&range,"I") ? iu-il+1 : n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssyevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_ssyevr(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyevr", rb_ssyevr, -1);
-}
diff --git a/ssyevx.c b/ssyevx.c
deleted file mode 100644
index f0287b8..0000000
--- a/ssyevx.c
+++ /dev/null
@@ -1,132 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyevx_(char *jobz, char *range, char *uplo, integer *n, real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_ssyevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.ssyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)\n or\n NumRu::Lapack.ssyevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSYEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n* selected by specifying either a range of values or a range of indices\n* for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\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 length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 8*N.\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the max of the blocksize for SSYTRD and SORMTR\n* returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = (real)NUM2DBL(rb_vu);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- m = lsame_(&range,"I") ? iu-il+1 : n;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- iwork = ALLOC_N(integer, (5*n));
-
- ssyevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a);
-}
-
-void
-init_lapack_ssyevx(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyevx", rb_ssyevx, -1);
-}
diff --git a/ssygs2.c b/ssygs2.c
deleted file mode 100644
index 04b731b..0000000
--- a/ssygs2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssygs2_(integer *itype, char *uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ssygs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ssygs2( itype, uplo, a, b)\n or\n NumRu::Lapack.ssygs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSYGS2 reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) REAL array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by SPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssygs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ssygs2(VALUE mLapack){
- rb_define_module_function(mLapack, "ssygs2", rb_ssygs2, -1);
-}
diff --git a/ssygst.c b/ssygst.c
deleted file mode 100644
index d5c6346..0000000
--- a/ssygst.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssygst_(integer *itype, char *uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ssygst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ssygst( itype, uplo, a, b)\n or\n NumRu::Lapack.ssygst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSYGST reduces a real symmetric-definite generalized eigenproblem\n* to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n* B must have been previously factorized as U**T*U or L*L**T by SPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n* = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**T*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**T.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) REAL array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by SPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssygst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ssygst(VALUE mLapack){
- rb_define_module_function(mLapack, "ssygst", rb_ssygst, -1);
-}
diff --git a/ssygv.c b/ssygv.c
deleted file mode 100644
index 4bc2fa4..0000000
--- a/ssygv.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssygv_(integer *itype, char *jobz, char *uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ssygv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.ssygv( itype, jobz, uplo, a, b, lwork)\n or\n NumRu::Lapack.ssygv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be symmetric and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the symmetric positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK. LWORK >= max(1,3*N-1).\n* For optimal efficiency, LWORK >= (NB+2)*N,\n* where NB is the blocksize for SSYTRD returned by ILAENV.\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* > 0: SPOTRF or SSYEV returned an error code:\n* <= N: if INFO = i, SSYEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ssygv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_ssygv(VALUE mLapack){
- rb_define_module_function(mLapack, "ssygv", rb_ssygv, -1);
-}
diff --git a/ssygvd.c b/ssygvd.c
deleted file mode 100644
index 19ae370..0000000
--- a/ssygvd.c
+++ /dev/null
@@ -1,124 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssygvd_(integer *itype, char *jobz, char *uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_ssygvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- real *w;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, iwork, info, a, b = NumRu::Lapack.ssygvd( itype, jobz, uplo, a, b, lwork, liwork)\n or\n NumRu::Lapack.ssygvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be symmetric and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) REAL array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK and IWORK\n* arrays, returns these values as the first entries of the WORK\n* and IWORK arrays, and no error message related to LWORK or\n* LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK and IWORK arrays, and no error message related to\n* LWORK or LIWORK 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* > 0: SPOTRF or SSYEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if SSYEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
- rb_liwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- liwork = NUM2INT(rb_liwork);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ssygvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_work, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_ssygvd(VALUE mLapack){
- rb_define_module_function(mLapack, "ssygvd", rb_ssygvd, -1);
-}
diff --git a/ssygvx.c b/ssygvx.c
deleted file mode 100644
index 4fd80f3..0000000
--- a/ssygvx.c
+++ /dev/null
@@ -1,168 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssygvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z, integer *ldz, real *work, integer *lwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_ssygvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_ldb;
- integer ldb;
- VALUE rb_vl;
- real vl;
- VALUE rb_vu;
- real vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- real abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- real *w;
- VALUE rb_z;
- real *z;
- VALUE rb_work;
- real *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.ssygvx( itype, jobz, range, uplo, a, b, ldb, vl, vu, il, iu, abstol, ldz, lwork)\n or\n NumRu::Lapack.ssygvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* SSYGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a real generalized symmetric-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n* and B are assumed to be symmetric and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A and B are stored;\n* = 'L': Lower triangle of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrix pencil (A,B). N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDA, N)\n* On entry, the symmetric matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**T*U or B = L*L**T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) REAL\n* VU (input) REAL\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) REAL\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*SLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) REAL array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) REAL array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\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 length of the array WORK. LWORK >= max(1,8*N).\n* For optimal efficiency, LWORK >= (NB+3)*N,\n* where NB is the blocksize for SSYTRD returned by ILAENV.\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 (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: SPOTRF or SSYEVX returned an error code:\n* <= N: if INFO = i, SSYEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_ldb = argv[6];
- rb_vl = argv[7];
- rb_vu = argv[8];
- rb_il = argv[9];
- rb_iu = argv[10];
- rb_abstol = argv[11];
- rb_ldz = argv[12];
- rb_lwork = argv[13];
-
- abstol = (real)NUM2DBL(rb_abstol);
- vl = (real)NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- ldb = NUM2INT(rb_ldb);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- if (NA_SHAPE0(rb_b) != lda)
- rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 0 of a");
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- jobz = StringValueCStr(rb_jobz)[0];
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- vu = (real)NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, real*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
- rb_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (5*n));
-
- ssygvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_ssygvx(VALUE mLapack){
- rb_define_module_function(mLapack, "ssygvx", rb_ssygvx, -1);
-}
diff --git a/ssyrfs.c b/ssyrfs.c
deleted file mode 100644
index b49e34c..0000000
--- a/ssyrfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyrfs_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_ssyrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- real *x_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.ssyrfs( uplo, a, af, ipiv, b, x)\n or\n NumRu::Lapack.ssyrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\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 SSYTRS.\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- ssyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_ssyrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyrfs", rb_ssyrfs, -1);
-}
diff --git a/ssyrfsx.c b/ssyrfsx.c
deleted file mode 100644
index b8b330f..0000000
--- a/ssyrfsx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyrfsx_(char *uplo, char *equed, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_ssyrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_params;
- real *params;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_x_out__;
- real *x_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.ssyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)\n or\n NumRu::Lapack.ssyrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) REAL array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by SSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\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 SGETRS.\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* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
- rb_params = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, real*);
- MEMCPY(x_out__, x, real, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- ssyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_ssyrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyrfsx", rb_ssyrfsx, -1);
-}
diff --git a/ssysv.c b/ssysv.c
deleted file mode 100644
index 5060696..0000000
--- a/ssysv.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssysv_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, integer *ipiv, real *b, integer *ldb, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ssysv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.ssysv( uplo, a, b, lwork)\n or\n NumRu::Lapack.ssysv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYSV computes the solution to a real system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by SSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\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 length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* SSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSYTRF, SSYTRS2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ssysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_ssysv(VALUE mLapack){
- rb_define_module_function(mLapack, "ssysv", rb_ssysv, -1);
-}
diff --git a/ssysvx.c b/ssysvx.c
deleted file mode 100644
index f7b0c9b..0000000
--- a/ssysvx.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssysvx_(char *fact, char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_ssysvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_af_out__;
- real *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.ssysvx( fact, uplo, a, af, ipiv, b, lwork)\n or\n NumRu::Lapack.ssysvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a real system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form of\n* A. AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by SSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by SSYTRF.\n*\n* B (input) REAL array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\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/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 length of WORK. LWORK >= max(1,3*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n* NB is the optimal blocksize for SSYTRF.\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 (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- lwork = NUM2INT(rb_lwork);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, real*);
- MEMCPY(af_out__, af, real, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- iwork = ALLOC_N(integer, (n));
-
- ssysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_af, rb_ipiv);
-}
-
-void
-init_lapack_ssysvx(VALUE mLapack){
- rb_define_module_function(mLapack, "ssysvx", rb_ssysvx, -1);
-}
diff --git a/ssysvxx.c b/ssysvxx.c
deleted file mode 100644
index 954f3cf..0000000
--- a/ssysvxx.c
+++ /dev/null
@@ -1,239 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssysvxx_(char *fact, char *uplo, integer *n, integer *nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, char *equed, real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *n_err_bnds, real *err_bnds_norm, real *err_bnds_comp, integer *nparams, real *params, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_ssysvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_af;
- real *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- real *s;
- VALUE rb_b;
- real *b;
- VALUE rb_params;
- real *params;
- VALUE rb_x;
- real *x;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_rpvgrw;
- real rpvgrw;
- VALUE rb_berr;
- real *berr;
- VALUE rb_err_bnds_norm;
- real *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- real *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_af_out__;
- real *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_s_out__;
- real *s_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_params_out__;
- real *params_out__;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.ssysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)\n or\n NumRu::Lapack.ssysvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a real system of linear equations A * X = B, where A\n* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. SSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* SSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* SSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what SSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) REAL array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) REAL array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by SSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) REAL array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) REAL array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) REAL\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) REAL\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) REAL array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) REAL array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) REAL array, dimension (4*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
- rb_params = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_SFLOAT)
- rb_params = na_change_type(rb_params, NA_SFLOAT);
- params = NA_PTR_TYPE(rb_params, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_SFLOAT)
- rb_af = na_change_type(rb_af, NA_SFLOAT);
- af = NA_PTR_TYPE(rb_af, real*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, real*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, real*);
- MEMCPY(af_out__, af, real, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, real*);
- MEMCPY(s_out__, s, real, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, real*);
- MEMCPY(params_out__, params, real, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(real, (4*n));
- iwork = ALLOC_N(integer, (n));
-
- ssysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(14, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_ssysvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "ssysvxx", rb_ssysvxx, -1);
-}
diff --git a/ssyswapr.c b/ssyswapr.c
deleted file mode 100644
index b451eef..0000000
--- a/ssyswapr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssyswapr_(char *uplo, integer *n, real *a, integer *i1, integer *i2);
-
-static VALUE
-rb_ssyswapr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_i1;
- integer i1;
- VALUE rb_i2;
- integer i2;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.ssyswapr( uplo, a, i1, i2)\n or\n NumRu::Lapack.ssyswapr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* SSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n REAL TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL SSWAP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_i1 = argv[2];
- rb_i2 = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- i1 = NUM2INT(rb_i1);
- i2 = NUM2INT(rb_i2);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssyswapr_(&uplo, &n, a, &i1, &i2);
-
- return rb_a;
-}
-
-void
-init_lapack_ssyswapr(VALUE mLapack){
- rb_define_module_function(mLapack, "ssyswapr", rb_ssyswapr, -1);
-}
diff --git a/ssytd2.c b/ssytd2.c
deleted file mode 100644
index 507515d..0000000
--- a/ssytd2.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytd2_(char *uplo, integer *n, real *a, integer *lda, real *d, real *e, real *tau, integer *info);
-
-static VALUE
-rb_ssytd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.ssytd2( uplo, a)\n or\n NumRu::Lapack.ssytd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n* form T by an orthogonal similarity transformation: Q' * A * Q = T.\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) REAL 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssytd2_(&uplo, &n, a, &lda, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_ssytd2(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytd2", rb_ssytd2, -1);
-}
diff --git a/ssytf2.c b/ssytf2.c
deleted file mode 100644
index a5b2a4f..0000000
--- a/ssytf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytf2_(char *uplo, integer *n, real *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_ssytf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.ssytf2( uplo, a)\n or\n NumRu::Lapack.ssytf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* SSYTF2 computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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) REAL 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.204 and l.372\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssytf2_(&uplo, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_ssytf2(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytf2", rb_ssytf2, -1);
-}
diff --git a/ssytrd.c b/ssytrd.c
deleted file mode 100644
index a7f8a4c..0000000
--- a/ssytrd.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytrd_(char *uplo, integer *n, real *a, integer *lda, real *d, real *e, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ssytrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.ssytrd( uplo, a, lwork)\n or\n NumRu::Lapack.ssytrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRD reduces a real symmetric matrix A to real symmetric\n* tridiagonal form T by an orthogonal similarity transformation:\n* Q**T * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the orthogonal\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the orthogonal matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) REAL array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) REAL array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) REAL array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real scalar, and v is a real vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, real*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssytrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_ssytrd(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytrd", rb_ssytrd, -1);
-}
diff --git a/ssytrf.c b/ssytrf.c
deleted file mode 100644
index 6e5b296..0000000
--- a/ssytrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytrf_(char *uplo, integer *n, real *a, integer *lda, integer *ipiv, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ssytrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.ssytrf( uplo, a, lwork)\n or\n NumRu::Lapack.ssytrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRF computes the factorization of a real symmetric matrix A using\n* the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with \n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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 length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SLASYF, SSYTF2, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ssytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_ssytrf(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytrf", rb_ssytrf, -1);
-}
diff --git a/ssytri.c b/ssytri.c
deleted file mode 100644
index 8e02555..0000000
--- a/ssytri.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytri_(char *uplo, integer *n, real *a, integer *lda, integer *ipiv, real *work, integer *info);
-
-static VALUE
-rb_ssytri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ssytri( uplo, a, ipiv)\n or\n NumRu::Lapack.ssytri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRI computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* SSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n));
-
- ssytri_(&uplo, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ssytri(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytri", rb_ssytri, -1);
-}
diff --git a/ssytri2.c b/ssytri2.c
deleted file mode 100644
index a5c6b58..0000000
--- a/ssytri2.c
+++ /dev/null
@@ -1,99 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytri2_(char *uplo, integer *n, real *a, integer *lda, integer *ipiv, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ssytri2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_work_out__;
- real *work_out__;
- integer c__1;
- integer nb;
- integer c__m1;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, work = NumRu::Lapack.ssytri2( uplo, a, ipiv, work)\n or\n NumRu::Lapack.ssytri2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRI2 computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* SSYTRF. SSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling SSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL SSYTRI2X\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_work = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- c__1 = 1;
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (4th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (4th argument) must be %d", 1);
- lwork = NA_SHAPE0(rb_work);
- if (NA_TYPE(rb_work) != NA_SFLOAT)
- rb_work = na_change_type(rb_work, NA_SFLOAT);
- work = NA_PTR_TYPE(rb_work, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- c__m1 = -1;
- nb = ilaenv_(&c__1, "SSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = lwork;
- rb_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work_out__ = NA_PTR_TYPE(rb_work_out__, real*);
- MEMCPY(work_out__, work, real, NA_TOTAL(rb_work));
- rb_work = rb_work_out__;
- work = work_out__;
-
- ssytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_a, rb_work);
-}
-
-void
-init_lapack_ssytri2(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytri2", rb_ssytri2, -1);
-}
diff --git a/ssytri2x.c b/ssytri2x.c
deleted file mode 100644
index 370b9db..0000000
--- a/ssytri2x.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytri2x_(char *uplo, integer *n, real *a, integer *lda, integer *ipiv, real *work, integer *nb, integer *info);
-
-static VALUE
-rb_ssytri2x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_nb;
- integer nb;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- real *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ssytri2x( uplo, a, ipiv, nb)\n or\n NumRu::Lapack.ssytri2x # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRI2X computes the inverse of a real symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* SSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by SSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by SSYTRF.\n*\n* WORK (workspace) REAL array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_nb = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- nb = NUM2INT(rb_nb);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(real, (n+nb+1)*(nb+3));
-
- ssytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ssytri2x(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytri2x", rb_ssytri2x, -1);
-}
diff --git a/ssytrs.c b/ssytrs.c
deleted file mode 100644
index c223772..0000000
--- a/ssytrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytrs_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, integer *ipiv, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ssytrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ssytrs( uplo, a, ipiv, b)\n or\n NumRu::Lapack.ssytrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRS solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by SSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ssytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ssytrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytrs", rb_ssytrs, -1);
-}
diff --git a/ssytrs2.c b/ssytrs2.c
deleted file mode 100644
index 2279dd9..0000000
--- a/ssytrs2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ssytrs2_(char *uplo, integer *n, integer *nrhs, real *a, integer *lda, integer *ipiv, real *b, integer *ldb, real *work, integer *info);
-
-static VALUE
-rb_ssytrs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ssytrs2( uplo, a, ipiv, b)\n or\n NumRu::Lapack.ssytrs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* SSYTRS2 solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by SSYTRF and converted by SSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) REAL array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by SSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by SSYTRF.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (n));
-
- ssytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ssytrs2(VALUE mLapack){
- rb_define_module_function(mLapack, "ssytrs2", rb_ssytrs2, -1);
-}
diff --git a/stbcon.c b/stbcon.c
deleted file mode 100644
index e5706d3..0000000
--- a/stbcon.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stbcon_(char *norm, char *uplo, char *diag, integer *n, integer *kd, real *ab, integer *ldab, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_stbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.stbcon( norm, uplo, diag, kd, ab)\n or\n NumRu::Lapack.stbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- stbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_stbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "stbcon", rb_stbcon, -1);
-}
diff --git a/stbrfs.c b/stbrfs.c
deleted file mode 100644
index 1a433fe..0000000
--- a/stbrfs.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stbrfs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_stbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.stbrfs( uplo, trans, diag, kd, ab, b, x)\n or\n NumRu::Lapack.stbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by STBTRS or some other\n* means before entering this routine. STBRFS 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- stbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_stbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "stbrfs", rb_stbrfs, -1);
-}
diff --git a/stbtrs.c b/stbtrs.c
deleted file mode 100644
index 9a642ff..0000000
--- a/stbtrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stbtrs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_stbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- real *ab;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.stbtrs( uplo, trans, diag, kd, ab, b)\n or\n NumRu::Lapack.stbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* STBTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by NRHS matrix. A check is made to verify that A is nonsingular.\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 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) REAL array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_SFLOAT)
- rb_ab = na_change_type(rb_ab, NA_SFLOAT);
- ab = NA_PTR_TYPE(rb_ab, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- stbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_stbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "stbtrs", rb_stbtrs, -1);
-}
diff --git a/stfsm.c b/stfsm.c
deleted file mode 100644
index 67d7813..0000000
--- a/stfsm.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stfsm_(char *transr, char *side, char *uplo, char *trans, char *diag, integer *m, integer *n, real *alpha, real *a, real *b, integer *ldb);
-
-static VALUE
-rb_stfsm(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- real alpha;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer nt;
- integer ldb;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.stfsm( transr, side, uplo, trans, diag, m, alpha, a, b)\n or\n NumRu::Lapack.stfsm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* STFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = A'.\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'T': The Transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'T' or 't' op( A ) = A'.\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) REAL\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) REAL array, dimension (NT)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'T' then RFP is the transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) REAL array, DIMENSION (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_side = argv[1];
- rb_uplo = argv[2];
- rb_trans = argv[3];
- rb_diag = argv[4];
- rb_m = argv[5];
- rb_alpha = argv[6];
- rb_a = argv[7];
- rb_b = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (8th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
- nt = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (MAX(1,m)))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", MAX(1,m));
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- m = NUM2INT(rb_m);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- alpha = (real)NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- transr = StringValueCStr(rb_transr)[0];
- ldb = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- stfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_stfsm(VALUE mLapack){
- rb_define_module_function(mLapack, "stfsm", rb_stfsm, -1);
-}
diff --git a/stftri.c b/stftri.c
deleted file mode 100644
index ba316ff..0000000
--- a/stftri.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stftri_(char *transr, char *uplo, char *diag, integer *n, real *a, integer *info);
-
-static VALUE
-rb_stftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.stftri( transr, uplo, diag, n, a)\n or\n NumRu::Lapack.stftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* STFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'T': The Transpose TRANSR of RFP A is stored.\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* A (input/output) REAL array, dimension (NT);\n* NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n* Positive Definite matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n* the transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- stftri_(&transr, &uplo, &diag, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_stftri(VALUE mLapack){
- rb_define_module_function(mLapack, "stftri", rb_stftri, -1);
-}
diff --git a/stfttp.c b/stfttp.c
deleted file mode 100644
index 5875204..0000000
--- a/stfttp.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stfttp_(char *transr, char *uplo, integer *n, real *arf, real *ap, integer *info);
-
-static VALUE
-rb_stfttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_arf;
- real *arf;
- VALUE rb_ap;
- real *ap;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.stfttp( transr, uplo, n, arf)\n or\n NumRu::Lapack.stfttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* STFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) REAL array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) REAL array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_arf = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_arf) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_arf) != NA_SFLOAT)
- rb_arf = na_change_type(rb_arf, NA_SFLOAT);
- arf = NA_PTR_TYPE(rb_arf, real*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_ap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, real*);
-
- stfttp_(&transr, &uplo, &n, arf, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_stfttp(VALUE mLapack){
- rb_define_module_function(mLapack, "stfttp", rb_stfttp, -1);
-}
diff --git a/stfttr.c b/stfttr.c
deleted file mode 100644
index 0d799e3..0000000
--- a/stfttr.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stfttr_(char *transr, char *uplo, integer *n, real *arf, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_stfttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_arf;
- real *arf;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
-
- integer ldarf;
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.stfttr( transr, uplo, arf)\n or\n NumRu::Lapack.stfttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'T': ARF is in Transpose format.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrices ARF and A. N >= 0.\n*\n* ARF (input) REAL array, dimension (N*(N+1)/2).\n* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n* matrix A in RFP format. See the \"Notes\" below for more\n* details.\n*\n* A (output) REAL array, dimension (LDA,N)\n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER N1, N2, K, NT, NX2, NP1X2\n INTEGER I, J, L, IJ\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_arf = argv[2];
-
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
- ldarf = NA_SHAPE0(rb_arf);
- if (NA_TYPE(rb_arf) != NA_SFLOAT)
- rb_arf = na_change_type(rb_arf, NA_SFLOAT);
- arf = NA_PTR_TYPE(rb_arf, real*);
- n = ((int)sqrtf(ldarf*8+1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, real*);
-
- stfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_stfttr(VALUE mLapack){
- rb_define_module_function(mLapack, "stfttr", rb_stfttr, -1);
-}
diff --git a/stgevc.c b/stgevc.c
deleted file mode 100644
index 9bf125c..0000000
--- a/stgevc.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stgevc_(char *side, char *howmny, logical *select, integer *n, real *s, integer *lds, real *p, integer *ldp, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real *work, integer *info);
-
-static VALUE
-rb_stgevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_s;
- real *s;
- VALUE rb_p;
- real *p;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_vl_out__;
- real *vl_out__;
- VALUE rb_vr_out__;
- real *vr_out__;
- real *work;
-
- integer n;
- integer lds;
- integer ldp;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, vl, vr = NumRu::Lapack.stgevc( side, howmny, select, s, p, vl, vr)\n or\n NumRu::Lapack.stgevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* STGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of real matrices (S,P), where S is a quasi-triangular matrix\n* and P is upper triangular. Matrix pairs of this type are produced by\n* the generalized Schur factorization of a matrix pair (A,B):\n*\n* A = Q*S*Z**T, B = Q*P*Z**T\n*\n* as computed by SGGHRD + SHGEQZ.\n*\n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal blocks of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the orthogonal factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n* \n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. If w(j) is a real eigenvalue, the corresponding\n* real eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector\n* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n* set to .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) REAL array, dimension (LDS,N)\n* The upper quasi-triangular matrix S from a generalized Schur\n* factorization, as computed by SHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) REAL array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by SHGEQZ.\n* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n* of S must be in positive diagonal form.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) REAL array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of left Schur vectors returned by SHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n*\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) REAL array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Z (usually the orthogonal matrix Z\n* of right Schur vectors returned by SHGEQZ).\n*\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B' or 'b', the matrix Z*X;\n* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n* specified by SELECT, stored consecutively in the\n* columns of VR, in the same order as their\n* eigenvalues.\n*\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* \n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected real eigenvector occupies one\n* column and each selected complex eigenvector occupies two\n* columns.\n*\n* WORK (workspace) REAL array, dimension (6*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex\n* eigenvalue.\n*\n\n* Further Details\n* ===============\n*\n* Allocation of workspace:\n* ---------- -- ---------\n*\n* WORK( j ) = 1-norm of j-th column of A, above the diagonal\n* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n* WORK( 2*N+1:3*N ) = real part of eigenvector\n* WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n*\n* Rowwise vs. columnwise solution methods:\n* ------- -- ---------- -------- -------\n*\n* Finding a generalized eigenvector consists basically of solving the\n* singular triangular system\n*\n* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)\n*\n* Consider finding the i-th right eigenvector (assume all eigenvalues\n* are real). The equation to be solved is:\n* n i\n* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1\n* k=j k=j\n*\n* where C = (A - w B) (The components v(i+1:n) are 0.)\n*\n* The \"rowwise\" method is:\n*\n* (1) v(i) := 1\n* for j = i-1,. . .,1:\n* i\n* (2) compute s = - sum C(j,k) v(k) and\n* k=j+1\n*\n* (3) v(j) := s / C(j,j)\n*\n* Step 2 is sometimes called the \"dot product\" step, since it is an\n* inner product between the j-th row and the portion of the eigenvector\n* that has been computed so far.\n*\n* The \"columnwise\" method consists basically in doing the sums\n* for all the rows in parallel. As each v(j) is computed, the\n* contribution of v(j) times the j-th column of C is added to the\n* partial sums. Since FORTRAN arrays are stored columnwise, this has\n* the advantage that at each step, the elements of C that are accessed\n* are adjacent to one another, whereas with the rowwise method, the\n* elements accessed at a step are spaced LDS (and LDP) words apart.\n*\n* When finding left eigenvectors, the matrix in question is the\n* transpose of the one in storage, so the rowwise method then\n* actually accesses columns of A and B at each step, and so is the\n* preferred method.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_s = argv[3];
- rb_p = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_p))
- rb_raise(rb_eArgError, "p (5th argument) must be NArray");
- if (NA_RANK(rb_p) != 2)
- rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_p);
- ldp = NA_SHAPE0(rb_p);
- if (NA_TYPE(rb_p) != NA_SFLOAT)
- rb_p = na_change_type(rb_p, NA_SFLOAT);
- p = NA_PTR_TYPE(rb_p, real*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SFLOAT)
- rb_vr = na_change_type(rb_vr, NA_SFLOAT);
- vr = NA_PTR_TYPE(rb_vr, real*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 2)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 1 of p");
- lds = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_SFLOAT)
- rb_s = na_change_type(rb_s, NA_SFLOAT);
- s = NA_PTR_TYPE(rb_s, real*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of p");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, real*);
- MEMCPY(vl_out__, vl, real, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, real*);
- MEMCPY(vr_out__, vr, real, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(real, (6*n));
-
- stgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
-
- free(work);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_m, rb_info, rb_vl, rb_vr);
-}
-
-void
-init_lapack_stgevc(VALUE mLapack){
- rb_define_module_function(mLapack, "stgevc", rb_stgevc, -1);
-}
diff --git a/stgex2.c b/stgex2.c
deleted file mode 100644
index 06f9d5d..0000000
--- a/stgex2.c
+++ /dev/null
@@ -1,161 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stgex2_(logical *wantq, logical *wantz, integer *n, real *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *z, integer *ldz, integer *j1, integer *n1, integer *n2, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_stgex2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_q;
- real *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_z;
- real *z;
- VALUE rb_j1;
- integer j1;
- VALUE rb_n1;
- integer n1;
- VALUE rb_n2;
- integer n2;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_z_out__;
- real *z_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldz;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2)\n or\n NumRu::Lapack.stgex2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n* (A, B) by an orthogonal equivalence transformation.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL arrays, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL arrays, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11). 1 <= J1 <= N.\n*\n* N1 (input) INTEGER\n* The order of the first block (A11, B11). N1 = 0, 1 or 2.\n*\n* N2 (input) INTEGER\n* The order of the second block (A22, B22). N2 = 0, 1 or 2.\n*\n* WORK (workspace) REAL array, dimension (MAX(1,LWORK)).\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n*\n* INFO (output) INTEGER\n* =0: Successful exit\n* >0: If INFO = 1, the transformed matrix (A, B) would be\n* too far from generalized Schur form; the blocks are\n* not swapped and (A, B) and (Q, Z) are unchanged.\n* The problem of swapping is too ill-conditioned.\n* <0: If INFO = -16: LWORK is too small. Appropriate value\n* for LWORK is returned in WORK(1).\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* =====================================================================\n* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO\n* loops. Sven Hammarling, 1/5/02.\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_ldq = argv[5];
- rb_z = argv[6];
- rb_j1 = argv[7];
- rb_n1 = argv[8];
- rb_n2 = argv[9];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- n1 = NUM2INT(rb_n1);
- ldq = NUM2INT(rb_ldq);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- n2 = NUM2INT(rb_n2);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- if (NA_SHAPE0(rb_z) != ldz)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- j1 = NUM2INT(rb_j1);
- wantq = (rb_wantq == Qtrue);
- lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(real, (lwork));
-
- stgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &n1, &n2, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_stgex2(VALUE mLapack){
- rb_define_module_function(mLapack, "stgex2", rb_stgex2, -1);
-}
diff --git a/stgexc.c b/stgexc.c
deleted file mode 100644
index 6602f64..0000000
--- a/stgexc.c
+++ /dev/null
@@ -1,166 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stgexc_(logical *wantq, logical *wantz, integer *n, real *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real *z, integer *ldz, integer *ifst, integer *ilst, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_stgexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_q;
- real *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_z;
- real *z;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, lwork)\n or\n NumRu::Lapack.stgexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGEXC reorders the generalized real Schur decomposition of a real\n* matrix pair (A,B) using an orthogonal equivalence transformation\n*\n* (A, B) = Q * (A, B) * Z',\n*\n* so that the diagonal block of (A, B) with row index IFST is moved\n* to row ILST.\n*\n* (A, B) must be in generalized real Schur canonical form (as returned\n* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n* diagonal blocks. B is upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the matrix A in generalized real Schur canonical\n* form.\n* On exit, the updated matrix A, again in generalized\n* real Schur canonical form.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the matrix B in generalized real Schur canonical\n* form (A,B).\n* On exit, the updated matrix B, again in generalized\n* real Schur canonical form (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of\n* a 2-by-2 block, it is changed to point to the first row;\n* ILST always points to the first row of the block in its\n* final position (which may differ from its input value by\n* +1 or -1). 1 <= IFST, ILST <= N.\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.\n* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_ldq = argv[5];
- rb_z = argv[6];
- rb_ifst = argv[7];
- rb_ilst = argv[8];
- rb_lwork = argv[9];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- ldq = NUM2INT(rb_ldq);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- lwork = NUM2INT(rb_lwork);
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- if (NA_SHAPE0(rb_q) != ldz)
- rb_raise(rb_eRuntimeError, "shape 0 of q must be the same as shape 0 of z");
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- stgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- rb_ifst = INT2NUM(ifst);
- rb_ilst = INT2NUM(ilst);
- return rb_ary_new3(8, rb_work, rb_info, rb_a, rb_b, rb_q, rb_z, rb_ifst, rb_ilst);
-}
-
-void
-init_lapack_stgexc(VALUE mLapack){
- rb_define_module_function(mLapack, "stgexc", rb_stgexc, -1);
-}
diff --git a/stgsen.c b/stgsen.c
deleted file mode 100644
index 0102c95..0000000
--- a/stgsen.c
+++ /dev/null
@@ -1,221 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stgsen_(integer *ijob, logical *wantq, logical *wantz, logical *select, integer *n, real *a, integer *lda, real *b, integer *ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq, real *z, integer *ldz, integer *m, real *pl, real *pr, real *dif, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_stgsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_q;
- real *q;
- VALUE rb_z;
- real *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_alphar;
- real *alphar;
- VALUE rb_alphai;
- real *alphai;
- VALUE rb_beta;
- real *beta;
- VALUE rb_m;
- integer m;
- VALUE rb_pl;
- real pl;
- VALUE rb_pr;
- real pr;
- VALUE rb_dif;
- real *dif;
- VALUE rb_work;
- real *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_q_out__;
- real *q_out__;
- VALUE rb_z_out__;
- real *z_out__;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)\n or\n NumRu::Lapack.stgsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGSEN reorders the generalized real Schur decomposition of a real\n* matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the upper quasi-triangular\n* matrix A and the upper triangular B. The leading columns of Q and\n* Z form orthonormal bases of the corresponding left and right eigen-\n* spaces (deflating subspaces). (A, B) must be in generalized real\n* Schur canonical form (as returned by SGGES), i.e. A is block upper\n* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n* triangular.\n*\n* STGSEN also computes the generalized eigenvalues\n*\n* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, STGSEN computes the estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster.\n* To select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) REAL array, dimension(LDA,N)\n* On entry, the upper quasi-triangular matrix A, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, with (A, B) in\n* generalized real Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHAR (output) REAL array, dimension (N)\n* ALPHAI (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n* and BETA(j),j=1,...,N are the diagonals of the complex Schur\n* form (S,T) that would result if the 2-by-2 diagonal blocks of\n* the real generalized Schur form of (A,B) were further reduced\n* to triangular form using complex unitary transformations.\n* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n* positive, then the j-th and (j+1)-st eigenvalues are a\n* complex conjugate pair, with ALPHAI(j+1) negative.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* and if WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) REAL array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left orthogonal\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right eigen-\n* spaces (deflating subspaces). 0 <= M <= N.\n*\n* PL (output) REAL\n* PR (output) REAL\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspaces with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3, PL and PR are not referenced.\n*\n* DIF (output) REAL array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\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 >= 4*N+16.\n* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+6.\n* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n\n* Further Details\n* ===============\n*\n* STGSEN first collects the selected eigenvalues by computing\n* orthogonal U and W that move them to the top left corner of (A, B).\n* In other words, the selected eigenvalues are the eigenvalues of\n* (A11, B11) in:\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the transpose of U. The first n1 columns\n* of U and W span the specified pair of left and right eigenspaces\n* (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized real Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see SLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF\n* (IJOB = 2 will be used)). See STGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_ijob = argv[0];
- rb_wantq = argv[1];
- rb_wantz = argv[2];
- rb_select = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
- rb_lwork = argv[8];
- rb_liwork = argv[9];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- liwork = NUM2INT(rb_liwork);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_SFLOAT)
- rb_z = na_change_type(rb_z, NA_SFLOAT);
- z = NA_PTR_TYPE(rb_z, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphar = NA_PTR_TYPE(rb_alphar, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alphai = NA_PTR_TYPE(rb_alphai, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[1];
- shape[0] = 2;
- rb_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[1];
- shape[0] = ijob==0 ? 0 : MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, real*);
- MEMCPY(z_out__, z, real, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- stgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alphar, alphai, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_pl = rb_float_new((double)pl);
- rb_pr = rb_float_new((double)pr);
- rb_info = INT2NUM(info);
- return rb_ary_new3(14, rb_alphar, rb_alphai, rb_beta, rb_m, rb_pl, rb_pr, rb_dif, rb_work, rb_iwork, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_stgsen(VALUE mLapack){
- rb_define_module_function(mLapack, "stgsen", rb_stgsen, -1);
-}
diff --git a/stgsja.c b/stgsja.c
deleted file mode 100644
index 7362006..0000000
--- a/stgsja.c
+++ /dev/null
@@ -1,208 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stgsja_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, integer *k, integer *l, real *a, integer *lda, real *b, integer *ldb, real *tola, real *tolb, real *alpha, real *beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer *ldq, real *work, integer *ncycle, integer *info);
-
-static VALUE
-rb_stgsja(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_tola;
- real tola;
- VALUE rb_tolb;
- real tolb;
- VALUE rb_u;
- real *u;
- VALUE rb_v;
- real *v;
- VALUE rb_q;
- real *q;
- VALUE rb_alpha;
- real *alpha;
- VALUE rb_beta;
- real *beta;
- VALUE rb_ncycle;
- integer ncycle;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
- VALUE rb_b_out__;
- real *b_out__;
- VALUE rb_u_out__;
- real *u_out__;
- VALUE rb_v_out__;
- real *v_out__;
- VALUE rb_q_out__;
- real *q_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.stgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)\n or\n NumRu::Lapack.stgsja # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* STGSJA computes the generalized singular value decomposition (GSVD)\n* of two real upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine SGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are orthogonal matrices, Z' denotes the transpose\n* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n* ``diagonal'' matrices, which are of the following structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the orthogonal transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain an orthogonal matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* orthogonal matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain an orthogonal matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* orthogonal matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* orthogonal matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by STGSJA.\n* See Further Details.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) REAL array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) REAL\n* TOLB (input) REAL\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = max(M,N)*norm(A)*MACHEPS,\n* TOLB = max(P,N)*norm(B)*MACHEPS.\n*\n* ALPHA (output) REAL array, dimension (N)\n* BETA (output) REAL array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0 and\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) REAL array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the orthogonal matrix returned by SGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the orthogonal matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) REAL array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the orthogonal matrix returned by SGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the orthogonal matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the orthogonal matrix returned by SGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the orthogonal matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) REAL array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n* of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_k = argv[3];
- rb_l = argv[4];
- rb_a = argv[5];
- rb_b = argv[6];
- rb_tola = argv[7];
- rb_tolb = argv[8];
- rb_u = argv[9];
- rb_v = argv[10];
- rb_q = argv[11];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (11th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
- p = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_SFLOAT)
- rb_v = na_change_type(rb_v, NA_SFLOAT);
- v = NA_PTR_TYPE(rb_v, real*);
- k = NUM2INT(rb_k);
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- l = NUM2INT(rb_l);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (12th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- tola = (real)NUM2DBL(rb_tola);
- tolb = (real)NUM2DBL(rb_tolb);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (10th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
- m = NA_SHAPE1(rb_u);
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_SFLOAT)
- rb_u = na_change_type(rb_u, NA_SFLOAT);
- u = NA_PTR_TYPE(rb_u, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, real*);
- MEMCPY(u_out__, u, real, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, real*);
- MEMCPY(v_out__, v, real, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(real, (2*n));
-
- stgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
-
- free(work);
- rb_ncycle = INT2NUM(ncycle);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_ncycle, rb_info, rb_a, rb_b, rb_u, rb_v, rb_q);
-}
-
-void
-init_lapack_stgsja(VALUE mLapack){
- rb_define_module_function(mLapack, "stgsja", rb_stgsja, -1);
-}
diff --git a/stgsna.c b/stgsna.c
deleted file mode 100644
index 5810fc3..0000000
--- a/stgsna.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stgsna_(char *job, char *howmny, logical *select, integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl, integer *ldvl, real *vr, integer *ldvr, real *s, real *dif, integer *mm, integer *m, real *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_stgsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- real *s;
- VALUE rb_dif;
- real *dif;
- VALUE rb_m;
- integer m;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- integer *iwork;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.stgsna( job, howmny, select, a, b, vl, vr, lwork)\n or\n NumRu::Lapack.stgsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n* generalized real Schur canonical form (or of any matrix pair\n* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n* Z' denotes the transpose of Z.\n*\n* (A, B) must be in generalized real Schur form (as returned by SGGES),\n* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n* blocks. B is upper triangular.\n*\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The upper quasi-triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) REAL array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A,B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) REAL array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by STGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1.\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) REAL array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns ov VR, as returned by STGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1.\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), DIF(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of DIF are set to the same value. If\n* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected real\n* eigenvalue one element is used, and for each selected complex\n* conjugate pair of eigenvalues, two elements are used.\n* If HOWMNY = 'A', M is set to N.\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 >= max(1,N).\n* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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 (N + 6)\n* If JOB = 'E', IWORK is not referenced.\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* Further Details\n* ===============\n*\n* The reciprocal of the condition number of a generalized eigenvalue\n* w = (a, b) is defined as\n*\n* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the left and right eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u.\n* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n* of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number DIF(i) of right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows:\n*\n* a) If the i-th eigenvalue w = (a,b) is real\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1\n* ( 0 S22 ),( 0 T22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(i) is\n*\n* Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n*\n* where sigma-min(Zl) denotes the smallest singular value of the\n* 2(n-1)-by-2(n-1) matrix\n*\n* Zl = [ kron(a, In-1) -kron(1, S22) ]\n* [ kron(b, In-1) -kron(1, T22) ] .\n*\n* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n* Kronecker product between the matrices X and Y.\n*\n* Note that if the default method for computing DIF(i) is wanted\n* (see SLATDF), then the parameter DIFDRI (see below) should be\n* changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).\n* See STGSYL for more details.\n*\n* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n*\n* Suppose U and V are orthogonal transformations such that\n*\n* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2\n* ( 0 S22 ),( 0 T22) n-2\n* 2 n-2 2 n-2\n*\n* and (S11, T11) corresponds to the complex conjugate eigenvalue\n* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n* that\n*\n* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )\n* ( 0 s22 ) ( 0 t22 )\n*\n* where the generalized eigenvalues w = s11/t11 and\n* conjg(w) = s22/t22.\n*\n* Then the reciprocal condition number DIF(i) is bounded by\n*\n* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n*\n* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n* Z1 is the complex 2-by-2 matrix\n*\n* Z1 = [ s11 -s22 ]\n* [ t11 -t22 ],\n*\n* This is done by computing (using real arithmetic) the\n* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n* the determinant of X.\n*\n* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n*\n* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]\n* [ kron(T11', In-2) -kron(I2, T22) ]\n*\n* Note that if the default method for computing DIF is wanted (see\n* SLATDF), then the parameter DIFDRI (see below) should be changed\n* from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL\n* for more details.\n*\n* For each eigenvalue/vector specified by SELECT, DIF stores a\n* Frobenius norm-based estimate of Difl.\n*\n* An approximate error bound for the i-th computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software,\n* Report UMINF - 94.04, Department of Computing Science, Umea\n* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n* Note 87. To appear in Numerical Algorithms, 1996.\n*\n* [3] 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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
- rb_lwork = argv[7];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SFLOAT)
- rb_vr = na_change_type(rb_vr, NA_SFLOAT);
- vr = NA_PTR_TYPE(rb_vr, real*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = mm;
- rb_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n + 6));
-
- stgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_s, rb_dif, rb_m, rb_work, rb_info);
-}
-
-void
-init_lapack_stgsna(VALUE mLapack){
- rb_define_module_function(mLapack, "stgsna", rb_stgsna, -1);
-}
diff --git a/stgsy2.c b/stgsy2.c
deleted file mode 100644
index 3320e8d..0000000
--- a/stgsy2.c
+++ /dev/null
@@ -1,163 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stgsy2_(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 *rdsum, real *rdscal, integer *iwork, integer *pq, integer *info);
-
-static VALUE
-rb_stgsy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_c;
- real *c;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_f;
- real *f;
- VALUE rb_rdsum;
- real rdsum;
- VALUE rb_rdscal;
- real rdscal;
- VALUE rb_scale;
- real scale;
- VALUE rb_pq;
- integer pq;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_f_out__;
- real *f_out__;
- integer *iwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.stgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)\n or\n NumRu::Lapack.stgsy2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n* Purpose\n* =======\n*\n* STGSY2 solves the generalized Sylvester equation:\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F,\n*\n* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n* must be in generalized Schur canonical form, i.e. A, B are upper\n* quasi triangular and D, E are upper triangular. The solution (R, L)\n* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n* chosen to avoid overflow.\n*\n* In matrix notation solving equation (1) corresponds to solve\n* Z*x = scale*b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n* In the process of solving (1), we solve a number of such systems\n* where Dim(In), Dim(In) = 1 or 2.\n*\n* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* sigma_min(Z) using reverse communicaton with SLACON.\n*\n* STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of the matrix pair in\n* STGSYL. See STGSYL for details.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* = 2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (SGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) REAL array, dimension (LDA, M)\n* On entry, A contains an upper quasi triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) REAL array, dimension (LDB, N)\n* On entry, B contains an upper quasi triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix 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).\n* On exit, if IJOB = 0, C has been overwritten by the\n* solution R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) REAL array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) REAL array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix 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).\n* On exit, if IJOB = 0, F has been overwritten by the\n* solution L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) REAL\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0. Normally,\n* SCALE = 1.\n*\n* RDSUM (input/output) REAL\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by STGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n*\n* RDSCAL (input/output) REAL\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when STGSY2 is called by\n* STGSYL.\n*\n* IWORK (workspace) INTEGER array, dimension (M+N+2)\n*\n* PQ (output) INTEGER\n* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n* 8-by-8) solved by this routine.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, the i-th argument had an illegal value.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n* Replaced various illegal calls to SCOPY by calls to SLASET.\n* Sven Hammarling, 27/5/02.\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_rdsum = argv[8];
- rb_rdscal = argv[9];
-
- rdscal = (real)NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- rdsum = (real)NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_SFLOAT)
- rb_f = na_change_type(rb_f, NA_SFLOAT);
- f = NA_PTR_TYPE(rb_f, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, real*);
- MEMCPY(f_out__, f, real, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
- iwork = ALLOC_N(integer, (m+n+2));
-
- stgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, iwork, &pq, &info);
-
- free(iwork);
- rb_scale = rb_float_new((double)scale);
- rb_pq = INT2NUM(pq);
- rb_info = INT2NUM(info);
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(7, rb_scale, rb_pq, rb_info, rb_c, rb_f, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_stgsy2(VALUE mLapack){
- rb_define_module_function(mLapack, "stgsy2", rb_stgsy2, -1);
-}
diff --git a/stgsyl.c b/stgsyl.c
deleted file mode 100644
index 63d1705..0000000
--- a/stgsyl.c
+++ /dev/null
@@ -1,165 +0,0 @@
-#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
-rb_stgsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_c;
- real *c;
- VALUE rb_d;
- real *d;
- VALUE rb_e;
- real *e;
- VALUE rb_f;
- real *f;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_scale;
- real scale;
- VALUE rb_dif;
- real dif;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
- VALUE rb_f_out__;
- real *f_out__;
- integer *iwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, lwork)\n or\n NumRu::Lapack.stgsyl # print 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 (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_lwork = argv[8];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_SFLOAT)
- rb_d = na_change_type(rb_d, NA_SFLOAT);
- d = NA_PTR_TYPE(rb_d, real*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_SFLOAT)
- rb_e = na_change_type(rb_e, NA_SFLOAT);
- e = NA_PTR_TYPE(rb_e, real*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_SFLOAT)
- rb_f = na_change_type(rb_f, NA_SFLOAT);
- f = NA_PTR_TYPE(rb_f, real*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, real*);
- MEMCPY(f_out__, f, real, NA_TOTAL(rb_f));
- rb_f = rb_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);
- rb_scale = rb_float_new((double)scale);
- rb_dif = rb_float_new((double)dif);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_scale, rb_dif, rb_work, rb_info, rb_c, rb_f);
-}
-
-void
-init_lapack_stgsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "stgsyl", rb_stgsyl, -1);
-}
diff --git a/stpcon.c b/stpcon.c
deleted file mode 100644
index b3b548d..0000000
--- a/stpcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#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
-rb_stpcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- real *ap;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.stpcon( norm, uplo, diag, ap)\n or\n NumRu::Lapack.stpcon # print 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_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);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_stpcon(VALUE mLapack){
- rb_define_module_function(mLapack, "stpcon", rb_stpcon, -1);
-}
diff --git a/stprfs.c b/stprfs.c
deleted file mode 100644
index 3e2bc8c..0000000
--- a/stprfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#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
-rb_stprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- real *ap;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x)\n or\n NumRu::Lapack.stprfs # print 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_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);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_stprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "stprfs", rb_stprfs, -1);
-}
diff --git a/stptri.c b/stptri.c
deleted file mode 100644
index 97a5917..0000000
--- a/stptri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stptri_(char *uplo, char *diag, integer *n, real *ap, integer *info);
-
-static VALUE
-rb_stptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- real *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap)\n or\n NumRu::Lapack.stptri # print 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, real*);
- MEMCPY(ap_out__, ap, real, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- stptri_(&uplo, &diag, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_stptri(VALUE mLapack){
- rb_define_module_function(mLapack, "stptri", rb_stptri, -1);
-}
diff --git a/stptrs.c b/stptrs.c
deleted file mode 100644
index bdb30e9..0000000
--- a/stptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stptrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, real *ap, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_stptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.stptrs( uplo, trans, diag, n, ap, b)\n or\n NumRu::Lapack.stptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* STPTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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 matrix B. 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*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- stptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_stptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "stptrs", rb_stptrs, -1);
-}
diff --git a/stpttf.c b/stpttf.c
deleted file mode 100644
index dc6ce21..0000000
--- a/stpttf.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stpttf_(char *transr, char *uplo, integer *n, real *ap, real *arf, integer *info);
-
-static VALUE
-rb_stpttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- real *ap;
- VALUE rb_arf;
- real *arf;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.stpttf( transr, uplo, n, ap)\n or\n NumRu::Lapack.stpttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* STPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'T': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower 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* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) REAL array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_arf = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, real*);
-
- stpttf_(&transr, &uplo, &n, ap, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_stpttf(VALUE mLapack){
- rb_define_module_function(mLapack, "stpttf", rb_stpttf, -1);
-}
diff --git a/stpttr.c b/stpttr.c
deleted file mode 100644
index 0a95bfc..0000000
--- a/stpttr.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stpttr_(char *uplo, integer *n, real *ap, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_stpttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- real *ap;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.stpttr( uplo, ap)\n or\n NumRu::Lapack.stpttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) REAL array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) REAL array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -i, the i-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_SFLOAT)
- rb_ap = na_change_type(rb_ap, NA_SFLOAT);
- ap = NA_PTR_TYPE(rb_ap, real*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, real*);
-
- stpttr_(&uplo, &n, ap, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_stpttr(VALUE mLapack){
- rb_define_module_function(mLapack, "stpttr", rb_stpttr, -1);
-}
diff --git a/strcon.c b/strcon.c
deleted file mode 100644
index e3bb930..0000000
--- a/strcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strcon_(char *norm, char *uplo, char *diag, integer *n, real *a, integer *lda, real *rcond, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_strcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- real *a;
- VALUE rb_rcond;
- real rcond;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.strcon( norm, uplo, diag, a)\n or\n NumRu::Lapack.strcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRCON estimates the reciprocal of the condition number of a\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* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- strcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_strcon(VALUE mLapack){
- rb_define_module_function(mLapack, "strcon", rb_strcon, -1);
-}
diff --git a/strevc.c b/strevc.c
deleted file mode 100644
index b990344..0000000
--- a/strevc.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strevc_(char *side, char *howmny, logical *select, integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real *work, integer *info);
-
-static VALUE
-rb_strevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- real *t;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_select_out__;
- logical *select_out__;
- VALUE rb_vl_out__;
- real *vl_out__;
- VALUE rb_vr_out__;
- real *vr_out__;
- real *work;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, select, vl, vr = NumRu::Lapack.strevc( side, howmny, select, t, vl, vr)\n or\n NumRu::Lapack.strevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n* Purpose\n* =======\n*\n* STREVC computes some or all of the right and/or left eigenvectors of\n* a real upper quasi-triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal blocks of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the orthogonal factor that reduces a matrix\n* A to Schur form T, then Q*X and Q*Y are the matrices of right and\n* left eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input/output) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* If w(j) is a real eigenvalue, the corresponding real\n* eigenvector is computed if SELECT(j) is .TRUE..\n* If w(j) and w(j+1) are the real and imaginary parts of a\n* complex eigenvalue, the corresponding complex eigenvector is\n* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n* .FALSE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) REAL array, dimension (LDT,N)\n* The upper quasi-triangular matrix T in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) REAL array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by SHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part, and the second the imaginary part.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) REAL array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the orthogonal matrix Q\n* of Schur vectors returned by SHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* A complex eigenvector corresponding to a complex eigenvalue\n* is stored in two consecutive columns, the first holding the\n* real part and the second the imaginary part.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors.\n* If HOWMNY = 'A' or 'B', M is set to N.\n* Each selected real eigenvector occupies one column and each\n* selected complex eigenvector occupies two columns.\n*\n* WORK (workspace) REAL array, dimension (3*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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SFLOAT)
- rb_vr = na_change_type(rb_vr, NA_SFLOAT);
- vr = NA_PTR_TYPE(rb_vr, real*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_select);
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- select_out__ = NA_PTR_TYPE(rb_select_out__, logical*);
- MEMCPY(select_out__, select, logical, NA_TOTAL(rb_select));
- rb_select = rb_select_out__;
- select = select_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, real*);
- MEMCPY(vl_out__, vl, real, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, real*);
- MEMCPY(vr_out__, vr, real, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(real, (3*n));
-
- strevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);
-
- free(work);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_m, rb_info, rb_select, rb_vl, rb_vr);
-}
-
-void
-init_lapack_strevc(VALUE mLapack){
- rb_define_module_function(mLapack, "strevc", rb_strevc, -1);
-}
diff --git a/strexc.c b/strexc.c
deleted file mode 100644
index 2aa3ea5..0000000
--- a/strexc.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strexc_(char *compq, integer *n, real *t, integer *ldt, real *q, integer *ldq, integer *ifst, integer *ilst, real *work, integer *info);
-
-static VALUE
-rb_strexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_t;
- real *t;
- VALUE rb_q;
- real *q;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- real *t_out__;
- VALUE rb_q_out__;
- real *q_out__;
- real *work;
-
- integer ldt;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, t, q, ifst, ilst = NumRu::Lapack.strexc( compq, t, q, ifst, ilst)\n or\n NumRu::Lapack.strexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n* Purpose\n* =======\n*\n* STREXC reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n* moved to row ILST.\n*\n* The real Schur form T is reordered by an orthogonal similarity\n* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n* is updated by postmultiplying it with Z.\n*\n* T must be in Schur canonical form (as returned by SHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) REAL array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* Schur canonical form.\n* On exit, the reordered upper quasi-triangular matrix, again\n* in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input/output) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of T.\n* The block with row index IFST is moved to row ILST, by a\n* sequence of transpositions between adjacent blocks.\n* On exit, if IFST pointed on entry to the second row of a\n* 2-by-2 block, it is changed to point to the first row; ILST\n* always points to the first row of the block in its final\n* position (which may differ from its input value by +1 or -1).\n* 1 <= IFST <= N; 1 <= ILST <= N.\n*\n* WORK (workspace) REAL 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* = 1: two adjacent blocks were too close to swap (the problem\n* is very ill-conditioned); T may have been partially\n* reordered, and ILST points to the first row of the\n* current position of the block being moved.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_compq = argv[0];
- rb_t = argv[1];
- rb_q = argv[2];
- rb_ifst = argv[3];
- rb_ilst = argv[4];
-
- compq = StringValueCStr(rb_compq)[0];
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (2th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, real*);
- MEMCPY(t_out__, t, real, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(real, (n));
-
- strexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- rb_ifst = INT2NUM(ifst);
- rb_ilst = INT2NUM(ilst);
- return rb_ary_new3(5, rb_info, rb_t, rb_q, rb_ifst, rb_ilst);
-}
-
-void
-init_lapack_strexc(VALUE mLapack){
- rb_define_module_function(mLapack, "strexc", rb_strexc, -1);
-}
diff --git a/strrfs.c b/strrfs.c
deleted file mode 100644
index 7fbe741..0000000
--- a/strrfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, integer *iwork, integer *info);
-
-static VALUE
-rb_strrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_x;
- real *x;
- VALUE rb_ferr;
- real *ferr;
- VALUE rb_berr;
- real *berr;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.strrfs( uplo, trans, diag, a, b, x)\n or\n NumRu::Lapack.strrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by STRTRS or some other\n* means before entering this routine. STRRFS 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* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_SFLOAT)
- rb_x = na_change_type(rb_x, NA_SFLOAT);
- x = NA_PTR_TYPE(rb_x, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, real*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, real*);
- work = ALLOC_N(real, (3*n));
- iwork = ALLOC_N(integer, (n));
-
- strrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_strrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "strrfs", rb_strrfs, -1);
-}
diff --git a/strsen.c b/strsen.c
deleted file mode 100644
index 82d7f74..0000000
--- a/strsen.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strsen_(char *job, char *compq, logical *select, integer *n, real *t, integer *ldt, real *q, integer *ldq, real *wr, real *wi, integer *m, real *s, real *sep, real *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_strsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- real *t;
- VALUE rb_q;
- real *q;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_wr;
- real *wr;
- VALUE rb_wi;
- real *wi;
- VALUE rb_m;
- integer m;
- VALUE rb_s;
- real s;
- VALUE rb_sep;
- real sep;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- real *t_out__;
- VALUE rb_q_out__;
- real *q_out__;
- integer *iwork;
-
- integer n;
- integer ldt;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.strsen( job, compq, select, t, q, lwork, liwork)\n or\n NumRu::Lapack.strsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRSEN reorders the real Schur factorization of a real matrix\n* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n* the leading diagonal blocks of the upper quasi-triangular matrix T,\n* and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n* T must be in Schur canonical form (as returned by SHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elemnts equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select a real eigenvalue w(j), SELECT(j) must be set to\n* .TRUE.. To select a complex conjugate pair of eigenvalues\n* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n* either SELECT(j) or SELECT(j+1) or both must be set to\n* .TRUE.; a complex conjugate pair of eigenvalues must be\n* either both included in the cluster or both excluded.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) REAL array, dimension (LDT,N)\n* On entry, the upper quasi-triangular matrix T, in Schur\n* canonical form.\n* On exit, T is overwritten by the reordered matrix T, again in\n* Schur canonical form, with the selected eigenvalues in the\n* leading diagonal blocks.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) REAL array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* orthogonal transformation matrix which reorders T; the\n* leading M columns of Q form an orthonormal basis for the\n* specified invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* WR (output) REAL array, dimension (N)\n* WI (output) REAL array, dimension (N)\n* The real and imaginary parts, respectively, of the reordered\n* eigenvalues of T. The eigenvalues are stored in the same\n* order as on the diagonal of T, with WR(i) = T(i,i) and, if\n* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n* WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n* sufficiently ill-conditioned, then its value may differ\n* significantly from its value before reordering.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 < = M <= N.\n*\n* S (output) REAL\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) REAL\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\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.\n* If JOB = 'N', LWORK >= max(1,N);\n* if JOB = 'E', LWORK >= max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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 (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If JOB = 'N' or 'E', LIWORK >= 1;\n* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* = 1: reordering of T failed because some eigenvalues are too\n* close to separate (the problem is very ill-conditioned);\n* T may have been partially reordered, and WR and WI\n* contain the eigenvalues in the same order as in T; S and\n* SEP (if requested) are set to zero.\n*\n\n* Further Details\n* ===============\n*\n* STRSEN first collects the selected eigenvalues by computing an\n* orthogonal transformation Z to move them to the top left corner of T.\n* In other words, the selected eigenvalues are the eigenvalues of T11\n* in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n* of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the real Schur factorization of a matrix\n* A = Q*T*Q', then the reordered real Schur factorization of A is given\n* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n* the corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_q = argv[4];
- rb_lwork = argv[5];
- rb_liwork = argv[6];
-
- liwork = NUM2INT(rb_liwork);
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_SFLOAT)
- rb_q = na_change_type(rb_q, NA_SFLOAT);
- q = NA_PTR_TYPE(rb_q, real*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of q");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wr = NA_PTR_TYPE(rb_wr, real*);
- {
- int shape[1];
- shape[0] = n;
- rb_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- wi = NA_PTR_TYPE(rb_wi, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, real*);
- MEMCPY(t_out__, t, real, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, real*);
- MEMCPY(q_out__, q, real, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
-
- strsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, wr, wi, &m, &s, &sep, work, &lwork, iwork, &liwork, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_s = rb_float_new((double)s);
- rb_sep = rb_float_new((double)sep);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_wr, rb_wi, rb_m, rb_s, rb_sep, rb_work, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_strsen(VALUE mLapack){
- rb_define_module_function(mLapack, "strsen", rb_strsen, -1);
-}
diff --git a/strsna.c b/strsna.c
deleted file mode 100644
index fd16805..0000000
--- a/strsna.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strsna_(char *job, char *howmny, logical *select, integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, integer *ldvr, real *s, real *sep, integer *mm, integer *m, real *work, integer *ldwork, integer *iwork, integer *info);
-
-static VALUE
-rb_strsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- real *t;
- VALUE rb_vl;
- real *vl;
- VALUE rb_vr;
- real *vr;
- VALUE rb_ldwork;
- integer ldwork;
- VALUE rb_s;
- real *s;
- VALUE rb_sep;
- real *sep;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- real *work;
- integer *iwork;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.strsna( job, howmny, select, t, vl, vr, ldwork)\n or\n NumRu::Lapack.strsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* STRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a real upper\n* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n* orthogonal).\n*\n* T must be in Schur canonical form (as returned by SHSEQR), that is,\n* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n* 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the eigenpair corresponding to a real eigenvalue w(j),\n* SELECT(j) must be set to .TRUE.. To select condition numbers\n* corresponding to a complex conjugate pair of eigenvalues w(j)\n* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n* set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) REAL array, dimension (LDT,N)\n* The upper quasi-triangular matrix T, in Schur canonical form.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) REAL array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* SHSEIN or STREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) REAL array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* SHSEIN or STREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) REAL array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. For a complex conjugate pair of eigenvalues two\n* consecutive elements of S are set to the same value. Thus\n* S(j), SEP(j), and the j-th columns of VL and VR all\n* correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) REAL array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array. For a complex eigenvector two\n* consecutive elements of SEP are set to the same value. If\n* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n* is set to 0; this can only occur when the true value would be\n* very small anyway.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) REAL array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* IWORK (workspace) INTEGER array, dimension (2*(N-1))\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
- rb_ldwork = argv[6];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_SFLOAT)
- rb_t = na_change_type(rb_t, NA_SFLOAT);
- t = NA_PTR_TYPE(rb_t, real*);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_SFLOAT)
- rb_vl = na_change_type(rb_vl, NA_SFLOAT);
- vl = NA_PTR_TYPE(rb_vl, real*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_SFLOAT)
- rb_vr = na_change_type(rb_vr, NA_SFLOAT);
- vr = NA_PTR_TYPE(rb_vr, real*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of t");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- job = StringValueCStr(rb_job)[0];
- ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, real*);
- {
- int shape[1];
- shape[0] = mm;
- rb_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- sep = NA_PTR_TYPE(rb_sep, real*);
- work = ALLOC_N(real, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
- iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : 2*(n-1)));
-
- strsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, iwork, &info);
-
- free(work);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_sep, rb_m, rb_info);
-}
-
-void
-init_lapack_strsna(VALUE mLapack){
- rb_define_module_function(mLapack, "strsna", rb_strsna, -1);
-}
diff --git a/strsyl.c b/strsyl.c
deleted file mode 100644
index 53294ea..0000000
--- a/strsyl.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, real *a, integer *lda, real *b, integer *ldb, real *c, integer *ldc, real *scale, integer *info);
-
-static VALUE
-rb_strsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trana;
- char trana;
- VALUE rb_tranb;
- char tranb;
- VALUE rb_isgn;
- integer isgn;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_c;
- real *c;
- VALUE rb_scale;
- real scale;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- real *c_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.strsyl( trana, tranb, isgn, a, b, c)\n or\n NumRu::Lapack.strsyl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* STRSYL solves the real Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**T, and A and B are both upper quasi-\n* triangular. A is M-by-M and B is N-by-N; the right hand side C and\n* the solution X are M-by-N; and scale is an output scale factor, set\n* <= 1 to avoid overflow in X.\n*\n* A and B must be in Schur canonical form (as returned by SHSEQR), that\n* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n* each 2-by-2 diagonal block has its diagonal elements equal and its\n* off-diagonal elements of opposite sign.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'T': op(A) = A**T (Transpose)\n* = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'T': op(B) = B**T (Transpose)\n* = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,M)\n* The upper quasi-triangular matrix A, in Schur canonical form.\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, in Schur canonical form.\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, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) REAL\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trana = argv[0];
- rb_tranb = argv[1];
- rb_isgn = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- trana = StringValueCStr(rb_trana)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_SFLOAT)
- rb_c = na_change_type(rb_c, NA_SFLOAT);
- c = NA_PTR_TYPE(rb_c, real*);
- tranb = StringValueCStr(rb_tranb)[0];
- isgn = NUM2INT(rb_isgn);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, real*);
- MEMCPY(c_out__, c, real, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- strsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_scale, rb_info, rb_c);
-}
-
-void
-init_lapack_strsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "strsyl", rb_strsyl, -1);
-}
diff --git a/strti2.c b/strti2.c
deleted file mode 100644
index f438f52..0000000
--- a/strti2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strti2_(char *uplo, char *diag, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_strti2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.strti2( uplo, diag, a)\n or\n NumRu::Lapack.strti2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STRTI2 computes the inverse of a real upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- strti2_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_strti2(VALUE mLapack){
- rb_define_module_function(mLapack, "strti2", rb_strti2, -1);
-}
diff --git a/strtri.c b/strtri.c
deleted file mode 100644
index 854362b..0000000
--- a/strtri.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strtri_(char *uplo, char *diag, integer *n, real *a, integer *lda, integer *info);
-
-static VALUE
-rb_strtri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- real *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.strtri( uplo, diag, a)\n or\n NumRu::Lapack.strtri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* STRTRI computes the inverse of a real upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- strtri_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_strtri(VALUE mLapack){
- rb_define_module_function(mLapack, "strtri", rb_strtri, -1);
-}
diff --git a/strtrs.c b/strtrs.c
deleted file mode 100644
index ab97c11..0000000
--- a/strtrs.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer *info);
-
-static VALUE
-rb_strtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- real *a;
- VALUE rb_b;
- real *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- real *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.strtrs( uplo, trans, diag, a, b)\n or\n NumRu::Lapack.strtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* STRTRS solves a triangular system of the form\n*\n* A * X = B or A**T * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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 matrix B. NRHS >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) REAL array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_SFLOAT)
- rb_b = na_change_type(rb_b, NA_SFLOAT);
- b = NA_PTR_TYPE(rb_b, real*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, real*);
- MEMCPY(b_out__, b, real, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- strtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_strtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "strtrs", rb_strtrs, -1);
-}
diff --git a/strttf.c b/strttf.c
deleted file mode 100644
index 10f452e..0000000
--- a/strttf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strttf_(char *transr, char *uplo, integer *n, real *a, integer *lda, real *arf, integer *info);
-
-static VALUE
-rb_strttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_arf;
- real *arf;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.strttf( transr, uplo, a)\n or\n NumRu::Lapack.strttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* STRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal form is wanted;\n* = 'T': ARF in Transpose form is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N).\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) REAL array, dimension (NT).\n* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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* We first consider Rectangular Full Packed (RFP) Format when N is\n* even. We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* the transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* the transpose of the last three columns of AP lower.\n* This covers the case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 03 04 05 33 43 53\n* 13 14 15 00 44 54\n* 23 24 25 10 11 55\n* 33 34 35 20 21 22\n* 00 44 45 30 31 32\n* 01 11 55 40 41 42\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We then consider Rectangular Full Packed (RFP) Format when N is\n* odd. We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* the transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* the transpose of the last two columns of AP lower.\n* This covers the case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* 02 03 04 00 33 43\n* 12 13 14 10 11 44\n* 22 23 24 20 21 22\n* 00 33 34 30 31 32\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n* transpose of RFP A above. One therefore gets:\n*\n* RFP A RFP A\n*\n* 02 12 22 00 01 00 10 20 30 40 50\n* 03 13 23 33 11 33 11 21 31 41 51\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* Reference\n* =========\n*\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- transr = StringValueCStr(rb_transr)[0];
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_arf = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, real*);
-
- strttf_(&transr, &uplo, &n, a, &lda, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_strttf(VALUE mLapack){
- rb_define_module_function(mLapack, "strttf", rb_strttf, -1);
-}
diff --git a/strttp.c b/strttp.c
deleted file mode 100644
index 2bb7723..0000000
--- a/strttp.c
+++ /dev/null
@@ -1,54 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID strttp_(char *uplo, integer *n, real *a, integer *lda, real *ap, integer *info);
-
-static VALUE
-rb_strttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- real *a;
- VALUE rb_ap;
- real *ap;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.strttp( uplo, a)\n or\n NumRu::Lapack.strttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* STRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) REAL array, dimension (LDA,N)\n* On exit, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) REAL array, dimension (N*(N+1)/2\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, real*);
-
- strttp_(&uplo, &n, a, &lda, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_strttp(VALUE mLapack){
- rb_define_module_function(mLapack, "strttp", rb_strttp, -1);
-}
diff --git a/stzrqf.c b/stzrqf.c
deleted file mode 100644
index 3774d13..0000000
--- a/stzrqf.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stzrqf_(integer *m, integer *n, real *a, integer *lda, real *tau, integer *info);
-
-static VALUE
-rb_stzrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_tau;
- real *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.stzrqf( a)\n or\n NumRu::Lapack.stzrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine STZRZF.\n*\n* STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- stzrqf_(&m, &n, a, &lda, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_stzrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "stzrqf", rb_stzrqf, -1);
-}
diff --git a/stzrzf.c b/stzrzf.c
deleted file mode 100644
index 197191d..0000000
--- a/stzrzf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID stzrzf_(integer *m, integer *n, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info);
-
-static VALUE
-rb_stzrzf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- real *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- real *tau;
- VALUE rb_work;
- real *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- real *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.stzrzf( a, lwork)\n or\n NumRu::Lapack.stzrzf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n* to upper triangular form by means of orthogonal transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) REAL array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* orthogonal matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) REAL array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_lwork = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_SFLOAT)
- rb_a = na_change_type(rb_a, NA_SFLOAT);
- a = NA_PTR_TYPE(rb_a, real*);
- lwork = NUM2INT(rb_lwork);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, real*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, real*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, real*);
- MEMCPY(a_out__, a, real, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- stzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_stzrzf(VALUE mLapack){
- rb_define_module_function(mLapack, "stzrzf", rb_stzrzf, -1);
-}
diff --git a/tests/eig/ge/test_gesdd.rb b/tests/eig/ge/test_gesdd.rb
new file mode 100644
index 0000000..3dd7da6
--- /dev/null
+++ b/tests/eig/ge/test_gesdd.rb
@@ -0,0 +1,90 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GesddTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @s_exp = Hash.new
+ @u_exp = Hash.new
+ @a_exp = Hash.new
+
+ @a[:r] = NMatrix[[ 2.27, 0.28, -0.48, 1.07, -2.35, 0.62],
+ [-1.54, -1.67, -3.09, 1.22, 2.93, -7.39],
+ [ 1.15, 0.94, 0.99, 0.79, -1.45, 1.03],
+ [-1.94, -0.78, -0.21, 0.63, 2.30, -2.57]].to_lm
+ @s_exp[:r] = NArray[9.9966, 3.6831, 1.3569, 0.5000]
+ @u_exp[:r] = NMatrix[[-0.1921, 0.8030, 0.0041, -0.5642],
+ [ 0.8794, 0.3926, -0.0752, 0.2587],
+ [-0.2140, 0.2980, 0.7827, 0.5027],
+ [ 0.3795, -0.3351, 0.6178, -0.6017]].to_lm
+ @a_exp[:r] = NMatrix[[-0.2774, -0.2020, -0.2918, 0.0938, 0.4213, -0.7816],
+ [ 0.6003, 0.0301, -0.3348, 0.3699, -0.5266, -0.3353],
+ [-0.1277, 0.2805, 0.6453, 0.6781, 0.0413, -0.1645],
+ [ 0.1323, 0.7034, 0.1906, -0.5399, -0.0575, -0.3957]].to_lm
+
+
+ @a[:c] = NMatrix[[ 0.96+0.81*I, -0.98-1.98*I, 0.62+0.46*I, -0.37-0.38*I, 0.83-0.51*I, 1.08+0.28*I],
+ [-0.03-0.96*I, -1.20-0.19*I, 1.01-0.02*I, 0.19+0.54*I, 0.20-0.01*I, 0.20+0.12*I],
+ [-0.91-2.06*I, -0.66-0.42*I, 0.63+0.17*I, -0.98+0.36*I, -0.17+0.46*I, -0.07-1.23*I],
+ [-0.05-0.41*I, -0.81-0.56*I, -1.11-0.60*I, 0.22+0.20*I, 1.47-1.59*I, 0.26-0.26*I]].to_lm
+ @s_exp[:c] = NArray[3.9994, 3.0003, 1.9944, 0.9995]
+ @u_exp[:c] = NMatrix[[ 0.6971+0.0000*I, 0.2403+0.0000*I, -0.5123+0.0000*I, -0.4403+0.0000*I],
+ [ 0.0867-0.3548*I, 0.0725+0.2336*I, -0.3030+0.1735*I, 0.5294-0.6361*I],
+ [-0.0560-0.5400*I, -0.2477+0.5291*I, 0.0678-0.5162*I, -0.3027+0.0346*I],
+ [ 0.1878-0.2253*I, 0.7026-0.2177*I, 0.4418-0.3864*I, 0.1667-0.0258*I]].to_lm
+ @a_exp[:c] = NMatrix[[ 0.5634+0.0016*I, -0.1205-0.6108*I, 0.0816+0.1613*I, -0.1441-0.1532*I, 0.2487-0.0926*I, 0.3758+0.0793*I],
+ [-0.2687+0.2749*I, -0.2909-0.1085*I, -0.1660-0.3885*I, 0.1984+0.1737*I, 0.6253-0.3304*I, -0.0307+0.0816*I],
+ [ 0.2451-0.4657*I, 0.4329+0.1758*I, -0.4667-0.3821*I, -0.0034-0.1555*I, 0.2643+0.0194*I, 0.1266-0.1747*I],
+ [ 0.3787-0.2987*I, -0.0182+0.0437*I, -0.0800+0.2276*I, 0.2608+0.5382*I, 0.1002-0.0140*I, -0.4175+0.4058*I]].to_lm
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gesdd"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", @a[rc])
+ assert_equal 0, info
+ assert_narray @s_exp[rc], s, 1.0e-4
+ u.shape[1].times do |i|
+ u[true,i] *= -1 if comp_sign(u[0,i], @u_exp[rc][0,i])
+ end
+ assert_narray @u_exp[rc], u, 1.0e-4
+ a.shape[0].times do |i|
+ a[i,true] *= -1 if comp_sign(a[i,0], @a_exp[rc][i,0])
+ end
+ assert_narray @a_exp[rc], a, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquireing_lwork") do
+ s, u, vt, work, info, = NumRu::Lapack.send(method, "O", @a[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", @a[rc], :lwork => lwork)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ assert_narray @s_exp[rc], s, 1.0e-4
+ u.shape[1].times do |i|
+ u[true,i] *= -1 if comp_sign(u[0,i], @u_exp[rc][0,i])
+ end
+ assert_narray @u_exp[rc], u, 1.0e-4
+ a.shape[0].times do |i|
+ a[i,true] *= -1 if comp_sign(a[i,0], @a_exp[rc][i,0])
+ end
+ assert_narray @a_exp[rc], a, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquireing_lwork_oldargstyle") do
+ s, u, vt, work, info, = NumRu::Lapack.send(method, "O", @a[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", @a[rc], -1)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ end
+
+ end
+
+end
diff --git a/tests/eig/ge/test_gesvd.rb b/tests/eig/ge/test_gesvd.rb
new file mode 100644
index 0000000..ab5895e
--- /dev/null
+++ b/tests/eig/ge/test_gesvd.rb
@@ -0,0 +1,99 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GesvdTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @s_exp = Hash.new
+ @vt_exp = Hash.new
+ @a_exp = Hash.new
+
+ @a[:r] = NMatrix[[ 2.27, -1.54, 1.15, -1.94],
+ [ 0.28, -1.67, 0.94, -0.78],
+ [-0.48, -3.09, 0.99, -0.21],
+ [ 1.07, 1.22, 0.79, 0.63],
+ [-2.35, 2.93, -1.45, 2.30],
+ [ 0.62, -7.39, 1.03, -2.57]].to_lm
+ @s_exp[:r] = NArray[9.9966, 3.6831, 1.3569, 0.5000]
+ @vt_exp[:r] = NMatrix[[-0.1921, 0.8794, -0.2140, 0.3795],
+ [ 0.8030, 0.3926, 0.2980, -0.3351],
+ [ 0.0041, -0.0752, 0.7827, 0.6178],
+ [-0.5642, 0.2587, 0.5027, -0.6017]].to_lm
+ @a_exp[:r] = NMatrix[[-0.2774, 0.6003, -0.1277, 0.1323],
+ [-0.2020, 0.0301, 0.2805, 0.7034],
+ [-0.2918, -0.3348, 0.6453, 0.1906],
+ [ 0.0938, 0.3699, 0.6781, -0.5399],
+ [ 0.4213, -0.5266, 0.0413, -0.0575],
+ [-0.7816, -0.3353, -0.1645, -0.3957] ].to_lm
+
+ @a[:c] = NMatrix[[ 0.96+0.81*I, -0.03-0.96*I, -0.91-2.06*I, -0.05-0.41*I],
+ [-0.98-1.98*I, -1.20-0.19*I, -0.66-0.42*I, -0.81-0.56*I],
+ [ 0.62+0.46*I, 1.01-0.02*I, 0.63+0.17*I, -1.11-0.60*I],
+ [-0.37-0.38*I, 0.19+0.54*I, -0.98+0.36*I, 0.22+0.20*I],
+ [ 0.83-0.51*I, 0.20-0.01*I, -0.17+0.46*I, 1.47-1.59*I],
+ [ 1.08+0.28*I, 0.20+0.12*I, -0.07-1.23*I, 0.26-0.26*I]].to_lm
+ @s_exp[:c] = NArray[3.9994, 3.0003, 1.9944, 0.9995]
+ @vt_exp[:c] = NMatrix[[ 0.6971+0.0*I, 0.0867-0.3548*I, -0.0560-0.5400*I, 0.1878-0.2253*I],
+ [ 0.2403+0.0*I, 0.0725+0.2336*I, -0.2477+0.5291*I, 0.7026-0.2177*I],
+ [-0.5123+0.0*I, -0.3030+0.1735*I, 0.0678-0.5162*I, 0.4418-0.3864*I],
+ [-0.4403+0.0*I, 0.5294-0.6361*I, -0.3027+0.0346*I, 0.1667-0.0258*I]].to_lm
+ @a_exp[:c] = NMatrix[[ 0.5634+0.0016*I, -0.2687+0.2749*I, 0.2451-0.4657*I, 0.3787-0.2987*I],
+ [-0.1205-0.6108*I, -0.2909-0.1085*I, 0.4329+0.1758*I, -0.0182+0.0437*I],
+ [ 0.0816+0.1613*I, -0.1660-0.3885*I, -0.4667-0.3821*I, -0.0800+0.2276*I],
+ [-0.1441-0.1532*I, 0.1984+0.1737*I, -0.0034-0.1555*I, 0.2608+0.5382*I],
+ [ 0.2487-0.0926*I, 0.6253-0.3304*I, 0.2643+0.0194*I, 0.1002-0.0140*I],
+ [ 0.3758+0.0793*I, -0.0307+0.0816*I, 0.1266-0.1747*I, -0.4175+0.4058*I]].to_lm
+
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gesvd"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", "S", @a[rc])
+ assert_equal 0, info
+ assert_narray @s_exp[rc], s, 1.0e-4
+
+ vt.shape[0].times do |i|
+ vt[i,true] *= -1 if comp_sign(vt[i,0], @vt_exp[rc][i,0])
+ end
+ assert_narray @vt_exp[rc], u, 1.0e-4
+ a.shape[1].times do |i|
+ a[true,i] *= -1 if comp_sign(a[0,i], @a_exp[rc][0,i])
+ end
+ assert_narray @a_exp[rc], a, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquireing_lwork") do
+ s, u, vt, work, info, = NumRu::Lapack.send(method, "O", "S", @a[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", "S", @a[rc], :lwork => lwork)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ assert_narray @s_exp[rc], s, 1.0e-4
+ vt.shape[0].times do |i|
+ vt[i,true] *= -1 if comp_sign(vt[i,0], @vt_exp[rc][i,0])
+ end
+ assert_narray @vt_exp[rc], vt, 1.0e-4
+ a.shape[1].times do |i|
+ a[true,i] *= -1 if comp_sign(a[0,i], @a_exp[rc][0,i])
+ end
+ assert_narray @a_exp[rc], a, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquireing_lwork_oldargstyle") do
+ s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", "S", @a[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ s, u, vt, work, info, = NumRu::Lapack.send(method, "O", "S", @a[rc], -1)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ end
+
+ end
+
+end
diff --git a/tests/eig/gg/test_ggev.rb b/tests/eig/gg/test_ggev.rb
new file mode 100644
index 0000000..c2a3827
--- /dev/null
+++ b/tests/eig/gg/test_ggev.rb
@@ -0,0 +1,124 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GgevTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @vr_exp = Hash.new
+
+ @a[:r] = NMatrix[[3.9, 12.5, -34.5, -0.5],
+ [4.3, 21.5, -47.5, 7.5],
+ [4.3, 21.5, -43.5, 3.5],
+ [4.4, 26.0, -46.0, 6.0]].to_lm
+ @b[:r] = NMatrix[[1.0, 2.0, -3.0, 1.0],
+ [1.0, 3.0, -5.0, 4.0],
+ [1.0, 3.0, -4.0, 3.0],
+ [1.0, 3.0, -4.0, 4.0]].to_lm
+
+ @evr_exp = NArray[2.0, 3.0, 3.0, 4.0]
+ @evi_exp = NArray[0.0, 4.0, -4.0, 0.0]
+ @vr_exp[:r] = NArray[[ 1.0000e-0, 5.7143e-3, 6.2857e-2, 6.2857e-2],
+ [-4.3979e-1, -8.7958e-2, -1.4241e-1, -1.4241e-1],
+ [-5.6021e-1, -1.1204e-1, 3.1418e-3, 3.1418e-3],
+ [-1.0000e+0, -1.1111e-2, 3.3333e-2, -1.5556e-1]]
+
+ @a[:c] = NMatrix[[-21.10-22.50*I, 53.50-50.50*I, -34.50+127.50*I, 7.50 +0.50*I],
+ [ -0.46 -7.78*I, -3.50-37.50*I, -15.50 +58.50*I, -10.50 -1.50*I],
+ [ 4.30 -5.50*I, 39.70-17.10*I, -68.50 +12.50*I, -7.50 -3.50*I],
+ [ 5.50 +4.40*I, 14.40+43.30*I, -32.50 -46.00*I, -19.00-32.50*I]].to_lm
+ @b[:c] = NMatrix[[1.00-5.00*I, 1.60+1.20*I, -3.00+0.00*I, 0.00-1.00*I],
+ [0.80-0.60*I, 3.00-5.00*I, -4.00+3.00*I, -2.40-3.20*I],
+ [1.00+0.00*I, 2.40+1.80*I, -4.00-5.00*I, 0.00-3.00*I],
+ [0.00+1.00*I, -1.80+2.40*I, 0.00-4.00*I, 4.00-5.00*I]].to_lm
+
+ @ev_exp = NArray[3.0-9.0*I, 2.0-5.0*I, 3.0-1.0*I, 4.0-5.0*I]
+ @vr_exp[:c] = NArray[[-8.2377e-1-1.7623e-1*I, -1.5295e-1+7.0655e-2*I, -7.0655e-2-1.5295e-1*I, 1.5295e-1-7.0655e-2*I],
+ [ 6.3974e-1+3.6026e-1*I, 4.1597e-3-5.4650e-4*I, 4.0212e-2+2.2645e-2*I, -2.2645e-2+4.0212e-2*I],
+ [ 9.7754e-1+2.2465e-2*I, 1.5910e-1-1.1371e-1*I, 1.2090e-1-1.5371e-1*I, 1.5371e-1+1.2090e-1*I],
+ [-9.0623e-1+9.3766e-2*I, -7.4303e-3+6.8750e-3*I, 3.0208e-2-3.1255e-3*I, -1.4586e-2-1.4097e-1*I]]
+
+
+ end
+
+ %w(s d).each do |x|
+ method = "#{x}ggev"
+ rc = :r
+
+ define_method("test_#{method}") do
+ alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @evr_exp, alphar/beta, 1.0e-4
+ assert_narray @evi_exp, alphai/beta, 1.0e-4
+ vr.shape[1].times do |i|
+ vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
+ end
+ assert_narray @vr_exp[rc], vr, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquiring_lwork") do
+ alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => lwork)
+ assert_equal 0, info
+ assert_narray @evr_exp, alphar/beta, 1.0e-4
+ assert_narray @evi_exp, alphai/beta, 1.0e-4
+ vr.shape[1].times do |i|
+ vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
+ end
+ assert_narray @vr_exp[rc], vr, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquiring_lwork_oldargstyle") do
+ alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], -1)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ end
+
+ end
+
+ %w(c z).each do |x|
+ method = "#{x}ggev"
+ rc = :c
+
+ define_method("test_#{method}") do
+ alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @ev_exp, alpha/beta, 1.0e-4
+ vr.shape[1].times do |i|
+ vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
+ end
+ assert_narray @vr_exp[rc], vr, 2.0e-2
+ end
+
+ define_method("test_#{method}_inquiring_lwork") do
+ alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => lwork)
+ assert_equal 0, info
+ assert_narray @ev_exp, alpha/beta, 1.0e-4
+ vr.shape[1].times do |i|
+ vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
+ end
+ assert_narray @vr_exp[rc], vr, 2.0e-2
+ end
+
+ define_method("test_#{method}_inquiring_lwork_oldargstyle") do
+ alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], -1)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ end
+
+ end
+
+end
diff --git a/tests/eig/gg/test_ggsvd.rb b/tests/eig/gg/test_ggsvd.rb
new file mode 100644
index 0000000..93e27b5
--- /dev/null
+++ b/tests/eig/gg/test_ggsvd.rb
@@ -0,0 +1,76 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GgsvdTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @k_exp = Hash.new
+ @l_exp = Hash.new
+ @gsv_exp = Hash.new
+ @u_exp = Hash.new
+ @v_exp = Hash.new
+ @q_exp = Hash.new
+
+ @a[:r] = NMatrix[[1.0, 2.0, 3.0],
+ [3.0, 2.0, 1.0],
+ [4.0, 5.0, 6.0],
+ [7.0, 8.0, 8.0]].to_lm
+ @b[:r] = NMatrix[[-2.0, -3.0, 3.0],
+ [ 4.0, 6.0, 5.0]].to_lm
+ @k_exp[:r] = 1
+ @l_exp[:r] = 2
+ @gsv_exp[:r] = NArray[1.3151, 8.0185e-2]
+ @u_exp[:r] = NMatrix[[-1.3484e-1, 5.2524e-1, -2.0924e-1, 8.1373e-1 ],
+ [ 6.7420e-1, -5.2213e-1, -3.8886e-1, 3.4874e-1 ],
+ [ 2.6968e-1, 5.2757e-1, -6.5782e-1, -4.6499e-1 ],
+ [ 6.7420e-1, 4.1615e-1, 6.1014e-1, 1.5127e-15]].to_lm
+ @v_exp[:r] = NMatrix[[3.5539e-1, -9.3472e-1],
+ [9.3472e-1, 3.5539e-1]].to_lm
+ @q_exp[:r] = NMatrix[[-8.3205e-1, -9.4633e-2, -5.4657e-1],
+ [ 5.5470e-1, -1.4195e-1, -8.1985e-1],
+ [ 0.0000e+0, -9.8534e-1, 1.7060e-1]].to_lm
+
+ @a[:c] = NMatrix[[ 0.96-0.81*I, -0.03+0.96*I, -0.91+2.06*I, -0.05+0.41*I],
+ [-0.98+1.98*I, -1.20+0.19*I, -0.66+0.42*I, -0.81+0.56*I],
+ [ 0.62-0.46*I, 1.01+0.02*I, 0.63-0.17*I, -1.11+0.60*I],
+ [ 0.37+0.38*I, 0.19-0.54*I, -0.98-0.36*I, 0.22-0.20*I],
+ [ 0.83+0.51*I, 0.20+0.01*I, -0.17-0.46*I, 1.47+1.59*I],
+ [ 1.08-0.28*I, 0.20-0.12*I, -0.07+1.23*I, 0.26+0.26*I]].to_lm
+ @b[:c] = NMatrix[[ 1.00+0.00*I, 0.00+0.00*I, -1.00+0.00*I, 0.00+0.00*I],
+ [ 0.00+0.00*I, 1.00+0.00*I, 0.00+0.00*I, -1.00+0.00*I]].to_lm
+ @k_exp[:c] = 2
+ @l_exp[:c] = 2
+ @gsv_exp[:c] = NArray[2.0720e+0, 1.1058e+0]
+ @u_exp[:c] = NMatrix[[-1.3038e-02-3.2595e-01*I, -1.4039e-01-2.6167e-01*I, 2.5177e-01-7.9789e-01*I, -5.0956e-02-2.1750e-01*I, -4.5947e-02+1.4052e-04*I, -5.2773e-02-2.2492e-01*I],
+ [ 4.2764e-01-6.2582e-01*I, 8.6298e-02-3.8174e-02*I, -3.2188e-01+1.6112e-01*I, 1.1979e-01+1.6319e-01*I, -8.0311e-02-4.3605e-01*I, -3.8117e-02-2.1907e-01*I],
+ [-3.2595e-01+1.6428e-01*I, 3.8163e-01-1.8219e-01*I, 1.3231e-01-1.4565e-02*I, -5.0671e-01+1.8615e-01*I, 5.9714e-02-5.8974e-01*I, -1.3850e-01-9.0941e-02*I],
+ [ 1.5906e-01-5.2151e-03*I, -2.8207e-01+1.9732e-01*I, 2.1598e-01+1.8813e-01*I, -4.0163e-01+2.6787e-01*I, -4.6443e-02+3.0864e-01*I, -3.7354e-01-5.5148e-01*I],
+ [-1.7210e-01-1.3038e-02*I, -5.0942e-01-5.0319e-01*I, 3.6488e-02+2.0316e-01*I, 1.9271e-01+1.5574e-01*I, 5.7843e-01-1.2439e-01*I, -1.8815e-02-5.5686e-02*I],
+ [-2.6336e-01-2.4772e-01*I, -1.0861e-01+2.8474e-01*I, 1.0906e-01-1.2712e-01*I, -8.8159e-02+5.6169e-01*I, 1.5763e-02+4.7130e-02*I, 6.5007e-01+4.9173e-03*I]].to_lm
+ @v_exp[:c] = NMatrix[[ 9.8930e-01+1.9041e-19*I, -1.1461e-01+9.0250e-02*I],
+ [-1.1461e-01-9.0250e-02*I, -9.8930e-01+1.9041e-19*I]].to_lm
+ @q_exp[:c] = NMatrix[[7.0711e-01+0.0000e+00*I, 0.0000e+00+0.0000e+00*I, 6.9954e-01+4.7274e-19*I, 8.1044e-02-6.3817e-02*I],
+ [0.0000e+00+0.0000e+00*I, 7.0711e-01+0.0000e+00*I, -8.1044e-02-6.3817e-02*I, 6.9954e-01-4.7274e-19*I],
+ [7.0711e-01+0.0000e+00*I, 0.0000e+00+0.0000e+00*I, -6.9954e-01-4.7274e-19*I, -8.1044e-02+6.3817e-02*I],
+ [0.0000e+00+0.0000e+00*I, 7.0711e-01+0.0000e+00*I, 8.1044e-02+6.3817e-02*I, -6.9954e-01+4.7274e-19*I]].to_lm
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}ggsvd"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.send(method, "U", "V", "Q", @a[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @gsv_exp[rc], alpha[k...k+l]/beta[k...k+l], 1.0e-4
+ assert_narray @u_exp[rc], u, 1.0e-4
+ assert_narray @v_exp[rc], v, 1.0e-4
+ assert_narray @q_exp[rc], q, 1.0e-4
+ end
+
+ end
+
+end
diff --git a/tests/eig/sb/test_sbev.rb b/tests/eig/sb/test_sbev.rb
new file mode 100644
index 0000000..01a01cd
--- /dev/null
+++ b/tests/eig/sb/test_sbev.rb
@@ -0,0 +1,39 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class SbevTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @kd = 2
+ @ab = NMatrix[[1.0, 2.0, 3.0, 0.0, 0.0],
+ [2.0, 2.0, 3.0, 4.0, 0.0],
+ [3.0, 3.0, 3.0, 4.0, 5.0],
+ [0.0, 4.0, 4.0, 4.0, 5.0],
+ [0.0, 0.0, 5.0, 5.0, 5.0]]
+ @w_exp = NArray[-3.2474, -2.6633, 1.7511, 4.1599, 14.9997]
+ @z_exp = NArray[[-0.0394, -0.5721, 0.4372, 0.4424, -0.5332],
+ [ 0.6238, -0.2575, -0.5900, 0.4308, 0.1039],
+ [ 0.5635, -0.3896, 0.4008, -0.5581, 0.2421],
+ [-0.5165, -0.5955, -0.1470, 0.0470, 0.5956],
+ [-0.1582, -0.3161, -0.5277, -0.5523, -0.5400] ]
+ end
+
+ %w(s d).each do |x|
+ method = "#{x}sbev"
+
+ %w(U L).each do |uplo|
+ define_method("test_#{method}_uplo_#{uplo}") do
+ w, z, info, ab = NumRu::Lapack.send(method, "V", uplo, @kd, @ab.to_lsb(uplo, @kd))
+ assert_equal 0, info
+ assert_narray @w_exp, w, 1.0e-4
+ for n in 0...z.shape[1]
+ z[true,n] *= -1 if comp_sign(@z_exp[0,n], z[0,n])
+ end
+ assert_narray @z_exp, z, 1.0e-4
+ end
+ end
+
+ end
+
+end
diff --git a/tests/lapack_test.rb b/tests/lapack_test.rb
new file mode 100644
index 0000000..ffe383f
--- /dev/null
+++ b/tests/lapack_test.rb
@@ -0,0 +1,50 @@
+$:.unshift(File.join(File.dirname(__FILE__), "..", "lib"))
+require "test/unit"
+require "numru/lapack"
+
+module LapackTest
+
+ I = Complex::I
+
+ def assert_narray(expected, actual, delta=nil, message="")
+ unless delta
+ case actual.typecode
+ when NArray::SFLOAT, NArray::SCOMPLEX
+ delta = 5.0e-5
+ when NArray::DFLOAT, NArray::DCOMPLEX
+ delta = 1.0e-13
+ when NArray::INT, NArray::LINT
+ delta = 0
+ else
+ raise "typecode is invalid"
+ end
+ end
+ if message.empty?
+ message = <<EOF
+<#{expected.inspect}>
+and
+<#{actual.inspect}>
+expected to have maximan differnce <#{(expected-actual).abs.max}> within
+<#{delta}>.
+EOF
+ end
+ assert (expected - actual).abs.max <= delta, message
+ end
+
+ def get_int(x)
+ x = x.real if x.respond_to?(:real)
+ x.to_i
+ end
+
+ def comp_sign(a, b)
+ a = a.real if a.respond_to?(:real)
+ b = b.real if b.respond_to?(:real)
+ a*b < 0
+ end
+
+ def get_rc(x)
+ /\A[sd]/ =~ x ? :r : :c
+ end
+ module_function :get_rc
+
+end
diff --git a/tests/lin/gb/test_gbsv.rb b/tests/lin/gb/test_gbsv.rb
new file mode 100644
index 0000000..927c5a3
--- /dev/null
+++ b/tests/lin/gb/test_gbsv.rb
@@ -0,0 +1,46 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GbsvTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @ab = Hash.new
+ @b = Hash.new
+ @b_exp = Hash.new
+ @ipiv_exp = Hash.new
+
+ @kl = 1
+ @ku = 2
+
+ @ab[:r] = NMatrix[[-0.23, 2.54, -3.66, 0.00],
+ [-6.98, 2.46, -2.73, -2.13],
+ [ 0.00, 2.56, 2.46, 4.07],
+ [ 0.00, 0.00, -4.78, -3.82]].to_lb(@kl, @ku, @kl)
+ @b[:r] = NVector[[4.42, 27.13, -6.14, 10.50]]
+ @b_exp[:r] = NArray[[-2.0, 3.0, 1.0, -4.0]]
+ @ipiv_exp[:r] = NArray[2, 3, 3, 4]
+
+ @ab[:c] = NMatrix[[-1.65+2.26*I, -2.05-0.85*I, 0.97-2.84*I, 0.00+0.00*I],
+ [ 0.00+6.30*I, -1.48-1.75*I, -3.99+4.01*I, 0.59-0.48*I],
+ [ 0.00+0.00*I, -0.77+2.83*I, -1.06+1.94*I, 3.33-1.04*I],
+ [ 0.00+0.00*I, 0.00+0.00*I, 4.48-1.09*I, -0.46-1.72*I]].to_lb(@kl, @ku, @kl)
+ @b[:c] = NVector[[-1.06+21.50*I, -22.72-53.90*I, 28.24-38.60*I, -34.56+16.73*I]]
+ @b_exp[:c] = NArray[[-3.0+2.0*I, 1.0-7.0*I, -5.0+4.0*I, 6.0-8.0*I]]
+ @ipiv_exp[:c] = NArray[2, 3, 3, 4]
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gbsv"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ ipiv, info, ab, b = NumRu::Lapack.send(method, @kl, @ku, @ab[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @b_exp[rc], b
+ assert_equal @ipiv_exp[rc], ipiv
+ end
+
+ end
+
+end
diff --git a/tests/lin/gb/test_gbsvx.rb b/tests/lin/gb/test_gbsvx.rb
new file mode 100644
index 0000000..1aa6fe4
--- /dev/null
+++ b/tests/lin/gb/test_gbsvx.rb
@@ -0,0 +1,56 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GbsvxTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @ab = Hash.new
+ @b = Hash.new
+ @x_exp = Hash.new
+ @ipiv_exp = Hash.new
+ @rcond_exp = Hash.new
+
+ @kl = 1
+ @ku = 2
+ @rpgf_exp = 1.0
+
+ @ab[:r] = NMatrix[[-0.23, 2.54, -3.66, 0.00],
+ [-6.98, 2.46, -2.73, -2.13],
+ [ 0.00, 2.56, 2.46, 4.07],
+ [ 0.00, 0.00, -4.78, -3.82]].to_lb(@kl, @ku)
+ @b[:r] = NVector[[ 4.42, 27.13, -6.14, 10.50],
+ [-36.01, -31.67, -1.16, -25.82]]
+ @x_exp[:r] = NArray[[-2.0, 3.0, 1.0, -4.0],
+ [ 1.0, -4.0, 7.0, -2.0]]
+ @ipiv_exp[:r] = NArray[2, 3, 3, 4]
+ @rcond_exp[:r] = 1.8e-2
+
+ @ab[:c] = NMatrix[[-1.65+2.26*I, -2.05-0.85*I, 0.97-2.84*I, 0.00+0.00*I],
+ [ 0.00+6.30*I, -1.48-1.75*I, -3.99+4.01*I, 0.59-0.48*I],
+ [ 0.00+0.00*I, -0.77+2.83*I, -1.06+1.94*I, 3.33-1.04*I],
+ [ 0.00+0.00*I, 0.00+0.00*I, 4.48-1.09*I, -0.46-1.72*I]].to_lb(@kl, @ku)
+ @b[:c] = NVector[[-1.06+21.50*I, -22.72-53.90*I, 28.24-38.60*I, -34.56+16.73*I],
+ [12.85+ 2.84*I, -70.22+21.57*I, -20.73- 1.23*I, 26.01+31.97*I]]
+ @x_exp[:c] = NArray[[-3.0+2.0*I, 1.0-7.0*I, -5.0+4.0*I, 6.0-8.0*I],
+ [ 1.0+6.0*I, -7.0-4.0*I, 3.0+5.0*I, -8.0+2.0*I]]
+ @ipiv_exp[:c] = NArray[2, 3, 3, 4]
+ @rcond_exp[:c] = 9.6e-3
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gbsvx"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.send(method, "E", "N", @kl, @ku, @ab[rc], @b[rc])
+ assert_equal(0, info)
+ assert_narray @x_exp[rc], x
+ assert_equal @ipiv_exp[rc], ipiv
+ assert_in_delta @rcond_exp[rc], rcond, 1.0e-3
+ assert_equal @rpgf_exp, work[0]
+ end
+
+ end
+
+end
diff --git a/tests/lin/ge/test_gels.rb b/tests/lin/ge/test_gels.rb
new file mode 100644
index 0000000..8f2adb4
--- /dev/null
+++ b/tests/lin/ge/test_gels.rb
@@ -0,0 +1,63 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GelsTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @b_exp = Hash.new
+
+ @a[:r] = NMatrix[[-0.57, -1.28, -0.39, 0.25],
+ [-1.93, 1.08, -0.31, -2.14],
+ [ 2.30, 0.24, 0.40, -0.35],
+ [-1.93, 0.64, -0.66, 0.08],
+ [ 0.15, 0.30, 0.15, -2.13],
+ [-0.02, 1.03, -1.43, 0.50]].to_lm
+ @b[:r] = NVector[[-2.67, -0.55, 3.34, -0.77, 0.48, 4.10]]
+ @b_exp[:r] = NArray[[1.5339, 1.8707, -1.5241, 0.0392]]
+
+ i = Complex::I
+ @a[:c] = NMatrix[[ 0.96-0.81*I, -0.03+0.96*I, -0.91+2.06*I, -0.05+0.41*I],
+ [-0.98+1.98*I, -1.20+0.19*I, -0.66+0.42*I, -0.81+0.56*I],
+ [ 0.62-0.46*I, 1.01+0.02*I, 0.63-0.17*I, -1.11+0.60*I],
+ [-0.37+0.38*I, 0.19-0.54*I, -0.98-0.36*I, 0.22-0.20*I],
+ [ 0.83+0.51*I, 0.20+0.01*I, -0.17-0.46*I, 1.47+1.59*I],
+ [ 1.08-0.28*I, 0.20-0.12*I, -0.07+1.23*I, 0.26+0.26*I]].to_lm
+ @b[:c] = NVector[[-2.09+1.93*I, 3.34-3.53*I, -4.94-2.04*I, 0.17+4.23*I, -5.19+3.63*I, 0.98+2.53*I]]
+ @b_exp[:c] = NArray[[-0.5044-1.2179*I, -2.4281+2.8574*I, 1.4872-2.1955*I, 0.4537+2.6904*I]]
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gels"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @b_exp[rc], b, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquiring_lwork") do
+ work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], :lwork => lwork)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ assert_narray @b_exp[rc], b, 1.0e-4
+ end
+
+ define_method("test_#{method}_inquiring_lwork_oldargstyle") do
+ work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], -1)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ end
+
+ end
+
+end
diff --git a/tests/lin/ge/test_gelsd.rb b/tests/lin/ge/test_gelsd.rb
new file mode 100644
index 0000000..55b4752
--- /dev/null
+++ b/tests/lin/ge/test_gelsd.rb
@@ -0,0 +1,54 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GelsdTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @b_exp = Hash.new
+ @s_exp = Hash.new
+ @rank_exp = Hash.new
+
+ @a[:r] = NMatrix[[-0.09, -1.56, -1.48, -1.09, 0.08, -1.59],
+ [ 0.14, 0.20, -0.43, 0.84, 0.55, -0.72],
+ [-0.46, 0.29, 0.89, 0.77, -1.13, 1.06],
+ [ 0.68, 1.09, -0.71, 2.11, 0.14, 1.24],
+ [ 1.29, 0.51, -0.96, -1.27, 1.74, 0.34]].to_lm
+ @b[:r] = NVector[[7.4, 4.3, -8.1, 1.8, 8.7]]
+ @b_exp[:r] = NArray[[1.5938, -0.1180, -3.1501, 0.1554, 2.5529, -1.6730]]
+ @s_exp[:r] = NArray[3.9997, 2.9962, 2.0001, 0.9988, 0.0025]
+ @rank_exp[:r] = 4
+
+ @a[:c] = NMatrix[[ 0.47-0.34*I, -0.32-0.23*I, 0.35-0.60*I, 0.89+0.71*I, -0.19+0.06*I],
+ [-0.40+0.54*I, -0.05+0.20*I, -0.52-0.34*I, -0.45-0.45*I, 0.11-0.85*I],
+ [ 0.60+0.01*I, -0.26-0.44*I, 0.87-0.11*I, -0.02-0.57*I, 1.44+0.80*I],
+ [ 0.80-1.02*I, -0.43+0.17*I, -0.34-0.09*I, 1.14-0.78*I, 0.07+1.14*I]].to_lm
+ @b[:c] = NVector[[2.15-0.20*I, -2.24+1.82*I, 4.45-4.28*I, 5.70-6.25*I]]
+
+ @b_exp[:c] = NArray[[3.9747-1.8377*I, -0.9186+0.8253*I, -0.3105+0.1477*I, 1.0050+0.8626*I, -0.2256-1.9425*I]]
+ @s_exp[:c] = NArray[2.9979, 1.9983, 1.0044, 0.0064]
+ @rank_exp[:c] = 3
+
+ @rcond = 0.01
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gelsd"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ s, rank, work, info, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ s, rank, work, info, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, lwork)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ assert_equal @rank_exp[rc], rank
+ assert_narray @b_exp[rc], b, 10e-4
+ assert_narray @s_exp[rc], s, 10e-4
+ end
+ end
+
+end
diff --git a/tests/lin/ge/test_gelss.rb b/tests/lin/ge/test_gelss.rb
new file mode 100644
index 0000000..1b84105
--- /dev/null
+++ b/tests/lin/ge/test_gelss.rb
@@ -0,0 +1,73 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GelssTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @b_exp = Hash.new
+ @s_exp = Hash.new
+ @rank_exp = Hash.new
+
+ @a[:r] = NMatrix[[-0.09, 0.14, -0.46, 0.68, 1.29],
+ [-1.56, 0.20, 0.29, 1.09, 0.51],
+ [-1.48, -0.43, 0.89, -0.71, -0.96],
+ [-1.09, 0.84, 0.77, 2.11, -1.27],
+ [ 0.08, 0.55, -1.13, 0.14, 1.74],
+ [-1.59, -0.72, 1.06, 1.24, 0.34]].to_lm
+ @b[:r] = NVector[[7.4, 4.2, -8.3, 1.8, 8.6, 2.1]]
+ @rank_exp[:r] = 4
+ @b_exp[:r] = NArray[[0.6344, 0.9699, -1.4403, 3.3678, 3.3992]]
+ @s_exp[:r] = NArray[3.9997, 2.9962, 2.0001, 0.9988, 0.0025]
+
+ @a[:c] = NMatrix[[ 0.47-0.34*I, -0.40+0.54*I, 0.60+0.01*I, 0.80-1.02*I],
+ [-0.32-0.23*I, -0.05+0.20*I, -0.26-0.44*I, -0.43+0.17*I],
+ [ 0.35-0.60*I, -0.52-0.34*I, 0.87-0.11*I, -0.34-0.09*I],
+ [ 0.89+0.71*I, -0.45-0.45*I, -0.02-0.57*I, 1.14-0.78*I],
+ [-0.19+0.06*I, 0.11-0.85*I, 1.44+0.80*I, 0.07+1.14*I]].to_lm
+ @b[:c] = NVector[[-1.08-2.59*I, -2.61-1.49*I, 3.13-3.61*I, 7.33-8.01*I, 9.12+7.63*I]]
+ @b_exp[:c] = NArray[[1.1673-3.3222*I, 1.3480+5.5028*I, 4.1762+2.3434*I, 0.6465+0.0105*I]]
+ @s_exp[:c] = NArray[2.9979, 1.9983, 1.0044, 0.0064]
+ @rank_exp[:c] = 3
+
+ @rcond = 0.01
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gelss"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond)
+ assert_equal 0, info
+ assert_narray @b_exp[rc], b, 1e-4
+ assert_narray @s_exp[rc], s, 1e-4
+ assert_equal @rank_exp[rc], rank
+ end
+
+ define_method("test_#{method}_inquiring_lwork") do
+ s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, :lwork => lwork)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ assert_narray @b_exp[rc], b, 1e-4
+ assert_narray @s_exp[rc], s, 1e-4
+ assert_equal @rank_exp[rc], rank
+ end
+
+ define_method("test_#{method}_inquiring_lwork_oldargstyle") do
+ s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, -1)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ end
+
+ end
+
+end
diff --git a/tests/lin/ge/test_gelsy.rb b/tests/lin/ge/test_gelsy.rb
new file mode 100644
index 0000000..758c149
--- /dev/null
+++ b/tests/lin/ge/test_gelsy.rb
@@ -0,0 +1,73 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GelsyTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @jpvt = Hash.new
+ @b_exp = Hash.new
+ @rank_exp = Hash.new
+
+ @a[:r] = NMatrix[[-0.09, 0.14, -0.46, 0.68, 1.29],
+ [-1.56, 0.20, 0.29, 1.09, 0.51],
+ [-1.48, -0.43, 0.89, -0.71, -0.96],
+ [-1.09, 0.84, 0.77, 2.11, -1.27],
+ [ 0.08, 0.55, -1.13, 0.14, 1.74],
+ [-1.59, -0.72, 1.06, 1.24, 0.34]].to_lm
+ @b[:r] = NVector[[7.4, 4.2, -8.3, 1.8, 8.6, 2.1]]
+ @jpvt[:r] = NArray.int(@a[:r].shape[1])
+ @b_exp[:r] = NArray[[0.6344, 0.9699, -1.4403, 3.3678, 3.3992]]
+ @rank_exp[:r] = 4
+
+ i = Complex::I
+ @a[:c] = NMatrix[[ 0.47-0.34*I, -0.40+0.54*I, 0.60+0.01*I, 0.80-1.02*I],
+ [-0.32-0.23*I, -0.05+0.20*I, -0.26-0.44*I, -0.43+0.17*I],
+ [ 0.35-0.60*I, -0.52-0.34*I, 0.87-0.11*I, -0.34-0.09*I],
+ [ 0.89+0.71*I, -0.45-0.45*I, -0.02-0.57*I, 1.14-0.78*I],
+ [-0.19+0.06*I, 0.11-0.85*I, 1.44+0.80*I, 0.07+1.14*I]].to_lm
+ @b[:c] = NVector[[-1.08-2.59*I, -2.61-1.49*I, 3.13-3.61*I, 7.33-8.01*I, 9.12+7.63*I]]
+ @jpvt[:c] = NArray.int(@a[:c].shape[1])
+ @b_exp[:c] = NArray[[1.1669-3.3224*I, 1.3486+5.5027*I, 4.1764+2.3435*I, 0.6467+0.0107*I]]
+ @rank_exp[:c] = 3
+
+ @rcond = 0.01
+ end
+
+
+ %w(s d c z).each do |x|
+ method = "#{x}gelsy"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ rank, work, info, a, b, jpvt = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond)
+ assert_equal 0, info
+ assert_narray @b_exp[rc], b, 1e-4
+ assert_equal @rank_exp[rc], rank
+ end
+
+ define_method("test_#{method}_inquiring_lwork") do
+ rank, work, info, = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ rank, work, info, a, b, jpvt = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, :lwork => lwork)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ assert_narray @b_exp[rc], b, 1e-4
+ assert_equal @rank_exp[rc], rank
+ end
+
+ define_method("test_#{method}_inquiring_lwork_oldargstyle") do
+ rank, work, info, = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, :lwork => -1)
+ assert_equal 0, info
+ lwork = get_int(work[0])
+ rank, work, info, a, b, jpvt = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, -1)
+ assert_equal 0, info
+ assert_equal lwork, get_int(work[0])
+ end
+
+ end
+
+end
diff --git a/tests/lin/ge/test_gesv.rb b/tests/lin/ge/test_gesv.rb
new file mode 100644
index 0000000..1a05178
--- /dev/null
+++ b/tests/lin/ge/test_gesv.rb
@@ -0,0 +1,43 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GesvTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @b_exp = Hash.new
+ @ipiv_exp = Hash.new
+
+ @a[:r] = NMatrix[[ 1.80, 2.88, 2.05, -0.89],
+ [ 5.25, -2.95, -0.95, -3.80],
+ [ 1.58, -2.69, -2.90, -1.04],
+ [-1.11, -0.66, -0.59, 0.80]].to_lm
+ @b[:r] = NVector[[9.52, 24.35, 0.77, -6.22]]
+ @b_exp[:r] = NArray[[1.0, -1.0, 3.0, -5.0]]
+ @ipiv_exp[:r] = NArray[2, 2, 3, 4]
+
+ @a[:c] = NMatrix[[-1.34+2.55*I, 0.28+3.17*I, -6.39-2.20*I, 0.72-0.92*I],
+ [-0.17-1.41*I, 3.31-0.15*I, -0.15+1.34*I, 1.29+1.38*I],
+ [-3.29-2.39*I, -1.91+4.42*I, -0.14-1.35*I, 1.72+1.35*I],
+ [ 2.41+0.39*I, -0.56+1.47*I, -0.83-0.69*I, -1.96+0.67*I]].to_lm
+ @b[:c] = NVector[[26.26+51.78*I, 6.43-8.68*I, -5.75+25.31*I, 1.16+2.57*I]]
+ @b_exp[:c] = NArray[[1.0+1.0*I, 2.0-3.0*I, -4.0-5.0*I, 0.0+6.0*I]]
+ @ipiv_exp[:c] = NArray[3, 2, 3, 4]
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gesv"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ ipiv, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @b_exp[rc], b
+ assert_narray @ipiv_exp[rc], ipiv
+ end
+
+ end
+
+end
diff --git a/tests/lin/ge/test_gesvx.rb b/tests/lin/ge/test_gesvx.rb
new file mode 100644
index 0000000..106f62b
--- /dev/null
+++ b/tests/lin/ge/test_gesvx.rb
@@ -0,0 +1,52 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GesvxTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @a = Hash.new
+ @b = Hash.new
+ @x_exp = Hash.new
+ @ipiv_exp = Hash.new
+ @rcond_exp = Hash.new
+ @rpgf_exp = Hash.new
+
+ @a[:r] = NMatrix[[ 1.80, 2.88, 2.05, -0.89],
+ [ 525.00, -295.00,-95.00, -380.00],
+ [ 1.58, -2.69, -2.90, -1.04],
+ [ -1.11, -0.66, -0.59, 0.80]].to_lm
+ @b[:r] = NVector[[ 9.52, 2435.00, 0.77, -6.22],
+ [18.47, 225.00, -13.28, -6.21]]
+ @x_exp[:r] = NArray[[1.0, -1.0, 3.0, -5.0],
+ [3.0, 2.0, 4.0, 1.0]]
+ @rcond_exp[:r] = 1.8e-2
+ @rpgf_exp[:r] = 7.4e-1
+
+ @a[:c] = NMatrix[[-1.34 +2.55*I, 0.28+3.17*I, -6.39 -2.20*I, 0.72 -0.92*I],
+ [-1.70-14.10*I, 33.10-1.50*I, -1.50+13.40*I, 12.90+13.80*I],
+ [-3.29 -2.39*I, -1.91+4.42*I, -0.14 -1.35*I, 1.72 +1.35*I],
+ [ 2.41 +0.39*I, -0.56+1.47*I, -0.83 -0.69*I, -1.96 +0.67*I]].to_lm
+ @b[:c] = NVector[[26.26+51.78*I, 64.30-86.80*I, -5.75+25.31*I, 1.16+2.57*I],
+ [31.32 -6.70*I, 158.60-14.20*I, -2.15+30.19*I, -2.56+7.55*I]]
+ @x_exp[:c] = NArray[[ 1.0+1.0*I, 2.0-3.0*I, -4.0-5.0*I, 0.0+6.0*I],
+ [-1.0-2.0*I, 5.0+1.0*I, -3.0+4.0*I, 2.0-3.0*I]]
+ @rcond_exp[:c] = 1.0e-2
+ @rpgf_exp[:c] = 8.3e-1
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gesvx"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.send(method, "E", "N", @a[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @x_exp[rc], x, 1.0e-4
+ assert_in_delta @rcond_exp[rc], rcond, 1e-3
+ assert_in_delta @rpgf_exp[rc], work[0], 1e-2
+ end
+
+ end
+
+end
diff --git a/tests/lin/gt/test_gtsv.rb b/tests/lin/gt/test_gtsv.rb
new file mode 100644
index 0000000..bc113a9
--- /dev/null
+++ b/tests/lin/gt/test_gtsv.rb
@@ -0,0 +1,39 @@
+$:.push File.dirname(__FILE__) + "/../.."
+require "lapack_test"
+
+class GtsvTest < Test::Unit::TestCase
+ include LapackTest
+
+ def setup
+ @du = Hash.new
+ @d = Hash.new
+ @dl = Hash.new
+ @b = Hash.new
+ @b_exp = Hash.new
+
+ @du[:r] = NArray[2.1, -1.0, 1.9, 8.0]
+ @d[:r] = NArray[3.0, 2.3, -5.0, -0.9, 7.1]
+ @dl[:r] = NArray[3.4, 3.6, 7.0, -6.0]
+ @b[:r] = NArray[[2.7, -0.5, 2.6, 0.6, 2.7]]
+ @b_exp[:r] = NArray[[-4.0, 7.0, 3.0, -4.0, -3.0]]
+
+ @du[:c] = NArray[ 2.0-1.0*I, 2.0+1.0*I, -1.0+1.0*I, 1.0-1.0*I]
+ @d[:c] = NArray[-1.3+1.3*I, -1.3+1.3*I, -1.3+3.3*I, -0.3+4.3*I, -3.3+1.3*I]
+ @dl[:c] = NArray[ 1.0-2.0*I, 1.0+1.0*I, 2.0-3.0*I, 1.0+1.0*I]
+ @b[:c] = NArray[[2.4-5.0*I, 3.4+18.2*I, -14.7+9.7*I, 31.9-7.7*I, -1.0+1.6*I]]
+ @b_exp[:c] = NArray[[1.0+1.0*I, 3.0-1.0*I, 4.0+5.0*I, -1.0-2.0*I, 1.0-1.0*I]]
+ end
+
+ %w(s d c z).each do |x|
+ method = "#{x}gtsv"
+ rc = LapackTest.get_rc(x)
+
+ define_method("test_#{method}") do
+ info, dl, d, du, b = NumRu::Lapack.send(method, @dl[rc], @d[rc], @du[rc], @b[rc])
+ assert_equal 0, info
+ assert_narray @b_exp[rc], b
+ end
+
+ end
+
+end
diff --git a/xerbla.c b/xerbla.c
deleted file mode 100644
index c803e27..0000000
--- a/xerbla.c
+++ /dev/null
@@ -1,33 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID xerbla_(char *srname, integer *info);
-
-static VALUE
-rb_xerbla(int argc, VALUE *argv, VALUE self){
- VALUE rb_srname;
- char *srname;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n = NumRu::Lapack.xerbla( srname, info)\n or\n NumRu::Lapack.xerbla # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE XERBLA( SRNAME, INFO )\n\n* Purpose\n* =======\n*\n* XERBLA is an error handler for the LAPACK routines.\n* It is called by an LAPACK routine if an input parameter has an\n* invalid value. A message is printed and execution stops.\n*\n* Installers may consider modifying the STOP statement in order to\n* call system-specific exception-handling facilities.\n*\n\n* Arguments\n* =========\n*\n* SRNAME (input) CHARACTER*(*)\n* The name of the routine which called XERBLA.\n*\n* INFO (input) INTEGER\n* The position of the invalid parameter in the parameter list\n* of the calling routine.\n*\n\n* =====================================================================\n*\n* .. Intrinsic Functions ..\n INTRINSIC LEN_TRIM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_srname = argv[0];
- rb_info = argv[1];
-
- srname = StringValueCStr(rb_srname);
- info = NUM2INT(rb_info);
-
- xerbla_(srname, &info);
-
- return Qnil;
-}
-
-void
-init_lapack_xerbla(VALUE mLapack){
- rb_define_module_function(mLapack, "xerbla", rb_xerbla, -1);
-}
diff --git a/xerbla_array.c b/xerbla_array.c
deleted file mode 100644
index 188933b..0000000
--- a/xerbla_array.c
+++ /dev/null
@@ -1,34 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID xerbla_array_(char *srname_array, integer *srname_len, integer *info);
-
-static VALUE
-rb_xerbla_array(int argc, VALUE *argv, VALUE self){
- VALUE rb_srname_array;
- char *srname_array;
- VALUE rb_info;
- integer info;
-
- integer srname_len;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n = NumRu::Lapack.xerbla_array( srname_array, info)\n or\n NumRu::Lapack.xerbla_array # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO)\n\n* Purpose\n* =======\n*\n* XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK\n* and BLAS error handler. Rather than taking a Fortran string argument\n* as the function's name, XERBLA_ARRAY takes an array of single\n* characters along with the array's length. XERBLA_ARRAY then copies\n* up to 32 characters of that array into a Fortran string and passes\n* that to XERBLA. If called with a non-positive SRNAME_LEN,\n* XERBLA_ARRAY will call XERBLA with a string of all blank characters.\n*\n* Say some macro or other device makes XERBLA_ARRAY available to C99\n* by a name lapack_xerbla and with a common Fortran calling convention.\n* Then a C99 program could invoke XERBLA via:\n* {\n* int flen = strlen(__func__);\n* lapack_xerbla(__func__, &flen, &info);\n* }\n*\n* Providing XERBLA_ARRAY is not necessary for intercepting LAPACK\n* errors. XERBLA_ARRAY calls XERBLA.\n*\n\n* Arguments\n* =========\n*\n* SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN)\n* The name of the routine which called XERBLA_ARRAY.\n*\n* SRNAME_LEN (input) INTEGER\n* The length of the name in SRNAME_ARRAY.\n*\n* INFO (input) INTEGER\n* The position of the invalid parameter in the parameter list\n* of the calling routine.\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n INTEGER I\n* ..\n* .. Local Arrays ..\n CHARACTER*32 SRNAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN, LEN\n* ..\n* .. External Functions ..\n EXTERNAL XERBLA\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_srname_array = argv[0];
- rb_info = argv[1];
-
- info = NUM2INT(rb_info);
- srname_array = StringValueCStr(rb_srname_array);
-
- xerbla_array_(srname_array, &srname_len, &info);
-
- return Qnil;
-}
-
-void
-init_lapack_xerbla_array(VALUE mLapack){
- rb_define_module_function(mLapack, "xerbla_array", rb_xerbla_array, -1);
-}
diff --git a/zbbcsd.c b/zbbcsd.c
deleted file mode 100644
index a146f5f..0000000
--- a/zbbcsd.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zbbcsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, integer *m, integer *p, integer *q, doublereal *theta, doublereal *phi, doublecomplex *u1, integer *ldu1, doublecomplex *u2, integer *ldu2, doublecomplex *v1t, integer *ldv1t, doublecomplex *v2t, integer *ldv2t, doublereal *b11d, doublereal *b11e, doublereal *b12d, doublereal *b12e, doublereal *b21d, doublereal *b21e, doublereal *b22d, doublereal *b22e, doublereal *rwork, integer *lrwork, integer *info);
-
-static VALUE
-rb_zbbcsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_theta;
- doublereal *theta;
- VALUE rb_phi;
- doublereal *phi;
- VALUE rb_u1;
- doublecomplex *u1;
- VALUE rb_u2;
- doublecomplex *u2;
- VALUE rb_v1t;
- doublecomplex *v1t;
- VALUE rb_v2t;
- doublecomplex *v2t;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_b11d;
- doublereal *b11d;
- VALUE rb_b11e;
- doublereal *b11e;
- VALUE rb_b12d;
- doublereal *b12d;
- VALUE rb_b12e;
- doublereal *b12e;
- VALUE rb_b21d;
- doublereal *b21d;
- VALUE rb_b21e;
- doublereal *b21e;
- VALUE rb_b22d;
- doublereal *b22d;
- VALUE rb_b22e;
- doublereal *b22e;
- VALUE rb_info;
- integer info;
- VALUE rb_theta_out__;
- doublereal *theta_out__;
- VALUE rb_u1_out__;
- doublecomplex *u1_out__;
- VALUE rb_u2_out__;
- doublecomplex *u2_out__;
- VALUE rb_v1t_out__;
- doublecomplex *v1t_out__;
- VALUE rb_v2t_out__;
- doublecomplex *v2t_out__;
- doublereal *rwork;
-
- integer q;
- integer ldu1;
- integer p;
- integer ldu2;
- integer ldv1t;
- integer ldv2t;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, lrwork)\n or\n NumRu::Lapack.zbbcsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZBBCSD computes the CS decomposition of a unitary matrix in\n* bidiagonal-block form,\n*\n*\n* [ B11 | B12 0 0 ]\n* [ 0 | 0 -I 0 ]\n* X = [----------------]\n* [ B21 | B22 0 0 ]\n* [ 0 | 0 0 I ]\n*\n* [ C | -S 0 0 ]\n* [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H\n* = [---------] [---------------] [---------] .\n* [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n* [ 0 | 0 0 I ]\n*\n* X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n* than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n* transposed and/or permuted. This can be done in constant time using\n* the TRANS and SIGNS options. See ZUNCSD for details.)\n*\n* The bidiagonal matrices B11, B12, B21, and B22 are represented\n* implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n* The unitary matrices U1, U2, V1T, and V2T are input/output.\n* The input matrices are pre- or post-multiplied by the appropriate\n* singular vector matrices.\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is updated;\n* otherwise: U1 is not updated.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is updated;\n* otherwise: U2 is not updated.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is updated;\n* otherwise: V1T is not updated.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is updated;\n* otherwise: V2T is not updated.\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* M (input) INTEGER\n* The number of rows and columns in X, the unitary matrix in\n* bidiagonal-block form.\n*\n* P (input) INTEGER\n* The number of rows in the top-left block of X. 0 <= P <= M.\n*\n* Q (input) INTEGER\n* The number of columns in the top-left block of X.\n* 0 <= Q <= MIN(P,M-P,M-Q).\n*\n* THETA (input/output) DOUBLE PRECISION array, dimension (Q)\n* On entry, the angles THETA(1),...,THETA(Q) that, along with\n* PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n* form. On exit, the angles whose cosines and sines define the\n* diagonal blocks in the CS decomposition.\n*\n* PHI (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n* The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n* THETA(Q), define the matrix in bidiagonal-block form.\n*\n* U1 (input/output) COMPLEX*16 array, dimension (LDU1,P)\n* On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n* by the left singular vector matrix common to [ B11 ; 0 ] and\n* [ B12 0 0 ; 0 -I 0 0 ].\n*\n* LDU1 (input) INTEGER\n* The leading dimension of the array U1.\n*\n* U2 (input/output) COMPLEX*16 array, dimension (LDU2,M-P)\n* On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n* postmultiplied by the left singular vector matrix common to\n* [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n* LDU2 (input) INTEGER\n* The leading dimension of the array U2.\n*\n* V1T (input/output) COMPLEX*16 array, dimension (LDV1T,Q)\n* On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n* by the conjugate transpose of the right singular vector\n* matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n* LDV1T (input) INTEGER\n* The leading dimension of the array V1T.\n*\n* V2T (input/output) COMPLEX*16 array, dimenison (LDV2T,M-Q)\n* On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n* premultiplied by the conjugate transpose of the right\n* singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n* [ B22 0 0 ; 0 0 I ].\n*\n* LDV2T (input) INTEGER\n* The leading dimension of the array V2T.\n*\n* B11D (output) DOUBLE PRECISION array, dimension (Q)\n* When ZBBCSD converges, B11D contains the cosines of THETA(1),\n* ..., THETA(Q). If ZBBCSD fails to converge, then B11D\n* contains the diagonal of the partially reduced top-left\n* block.\n*\n* B11E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When ZBBCSD converges, B11E contains zeros. If ZBBCSD fails\n* to converge, then B11E contains the superdiagonal of the\n* partially reduced top-left block.\n*\n* B12D (output) DOUBLE PRECISION array, dimension (Q)\n* When ZBBCSD converges, B12D contains the negative sines of\n* THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then\n* B12D contains the diagonal of the partially reduced top-right\n* block.\n*\n* B12E (output) DOUBLE PRECISION array, dimension (Q-1)\n* When ZBBCSD converges, B12E contains zeros. If ZBBCSD fails\n* to converge, then B12E contains the subdiagonal of the\n* partially reduced top-right block.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the RWORK array,\n* returns this value as the first entry of the work array, and\n* no error message related to LRWORK 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* > 0: if ZBBCSD did not converge, INFO specifies the number\n* of nonzero entries in PHI, and B11D, B11E, etc.,\n* contain the partially reduced matrix.\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* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n* are within TOLMUL*EPS of either bound.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_m = argv[5];
- rb_theta = argv[6];
- rb_phi = argv[7];
- rb_u1 = argv[8];
- rb_u2 = argv[9];
- rb_v1t = argv[10];
- rb_v2t = argv[11];
- rb_lrwork = argv[12];
-
- if (!NA_IsNArray(rb_theta))
- rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
- if (NA_RANK(rb_theta) != 1)
- rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
- q = NA_SHAPE0(rb_theta);
- if (NA_TYPE(rb_theta) != NA_DFLOAT)
- rb_theta = na_change_type(rb_theta, NA_DFLOAT);
- theta = NA_PTR_TYPE(rb_theta, doublereal*);
- jobu1 = StringValueCStr(rb_jobu1)[0];
- trans = StringValueCStr(rb_trans)[0];
- m = NUM2INT(rb_m);
- jobu2 = StringValueCStr(rb_jobu2)[0];
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- if (!NA_IsNArray(rb_u1))
- rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
- if (NA_RANK(rb_u1) != 2)
- rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
- p = NA_SHAPE1(rb_u1);
- ldu1 = NA_SHAPE0(rb_u1);
- if (NA_TYPE(rb_u1) != NA_DCOMPLEX)
- rb_u1 = na_change_type(rb_u1, NA_DCOMPLEX);
- u1 = NA_PTR_TYPE(rb_u1, doublecomplex*);
- if (!NA_IsNArray(rb_v1t))
- rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
- if (NA_RANK(rb_v1t) != 2)
- rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v1t) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
- ldv1t = NA_SHAPE0(rb_v1t);
- if (NA_TYPE(rb_v1t) != NA_DCOMPLEX)
- rb_v1t = na_change_type(rb_v1t, NA_DCOMPLEX);
- v1t = NA_PTR_TYPE(rb_v1t, doublecomplex*);
- if (!NA_IsNArray(rb_u2))
- rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
- if (NA_RANK(rb_u2) != 2)
- rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u2) != (m-p))
- rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
- ldu2 = NA_SHAPE0(rb_u2);
- if (NA_TYPE(rb_u2) != NA_DCOMPLEX)
- rb_u2 = na_change_type(rb_u2, NA_DCOMPLEX);
- u2 = NA_PTR_TYPE(rb_u2, doublecomplex*);
- if (!NA_IsNArray(rb_phi))
- rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
- if (NA_RANK(rb_phi) != 1)
- rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_phi) != (q-1))
- rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
- if (NA_TYPE(rb_phi) != NA_DFLOAT)
- rb_phi = na_change_type(rb_phi, NA_DFLOAT);
- phi = NA_PTR_TYPE(rb_phi, doublereal*);
- lrwork = MAX(1,8*q);
- if (!NA_IsNArray(rb_v2t))
- rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
- if (NA_RANK(rb_v2t) != 2)
- rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v2t) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
- ldv2t = NA_SHAPE0(rb_v2t);
- if (NA_TYPE(rb_v2t) != NA_DCOMPLEX)
- rb_v2t = na_change_type(rb_v2t, NA_DCOMPLEX);
- v2t = NA_PTR_TYPE(rb_v2t, doublecomplex*);
- {
- int shape[1];
- shape[0] = q;
- rb_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b11d = NA_PTR_TYPE(rb_b11d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b11e = NA_PTR_TYPE(rb_b11e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b12d = NA_PTR_TYPE(rb_b12d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b12e = NA_PTR_TYPE(rb_b12e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b21d = NA_PTR_TYPE(rb_b21d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b21e = NA_PTR_TYPE(rb_b21e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b22d = NA_PTR_TYPE(rb_b22d, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- b22e = NA_PTR_TYPE(rb_b22e, doublereal*);
- {
- int shape[1];
- shape[0] = q;
- rb_theta_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- theta_out__ = NA_PTR_TYPE(rb_theta_out__, doublereal*);
- MEMCPY(theta_out__, theta, doublereal, NA_TOTAL(rb_theta));
- rb_theta = rb_theta_out__;
- theta = theta_out__;
- {
- int shape[2];
- shape[0] = ldu1;
- shape[1] = p;
- rb_u1_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u1_out__ = NA_PTR_TYPE(rb_u1_out__, doublecomplex*);
- MEMCPY(u1_out__, u1, doublecomplex, NA_TOTAL(rb_u1));
- rb_u1 = rb_u1_out__;
- u1 = u1_out__;
- {
- int shape[2];
- shape[0] = ldu2;
- shape[1] = m-p;
- rb_u2_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u2_out__ = NA_PTR_TYPE(rb_u2_out__, doublecomplex*);
- MEMCPY(u2_out__, u2, doublecomplex, NA_TOTAL(rb_u2));
- rb_u2 = rb_u2_out__;
- u2 = u2_out__;
- {
- int shape[2];
- shape[0] = ldv1t;
- shape[1] = q;
- rb_v1t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v1t_out__ = NA_PTR_TYPE(rb_v1t_out__, doublecomplex*);
- MEMCPY(v1t_out__, v1t, doublecomplex, NA_TOTAL(rb_v1t));
- rb_v1t = rb_v1t_out__;
- v1t = v1t_out__;
- {
- int shape[2];
- shape[0] = ldv2t;
- shape[1] = m-q;
- rb_v2t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v2t_out__ = NA_PTR_TYPE(rb_v2t_out__, doublecomplex*);
- MEMCPY(v2t_out__, v2t, doublecomplex, NA_TOTAL(rb_v2t));
- rb_v2t = rb_v2t_out__;
- v2t = v2t_out__;
- rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
-
- zbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, &lrwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(14, rb_b11d, rb_b11e, rb_b12d, rb_b12e, rb_b21d, rb_b21e, rb_b22d, rb_b22e, rb_info, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t);
-}
-
-void
-init_lapack_zbbcsd(VALUE mLapack){
- rb_define_module_function(mLapack, "zbbcsd", rb_zbbcsd, -1);
-}
diff --git a/zbdsqr.c b/zbdsqr.c
deleted file mode 100644
index 5fc6b6c..0000000
--- a/zbdsqr.c
+++ /dev/null
@@ -1,163 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zbdsqr_(char *uplo, integer *n, integer *ncvt, integer *nru, integer *ncc, doublereal *d, doublereal *e, doublecomplex *vt, integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c, integer *ldc, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zbdsqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nru;
- integer nru;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vt;
- doublecomplex *vt;
- VALUE rb_u;
- doublecomplex *u;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_vt_out__;
- doublecomplex *vt_out__;
- VALUE rb_u_out__;
- doublecomplex *u_out__;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublereal *rwork;
-
- integer n;
- integer ldvt;
- integer ncvt;
- integer ldu;
- integer ldc;
- integer ncc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, vt, u, c = NumRu::Lapack.zbdsqr( uplo, nru, d, e, vt, u, c)\n or\n NumRu::Lapack.zbdsqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZBDSQR computes the singular values and, optionally, the right and/or\n* left singular vectors from the singular value decomposition (SVD) of\n* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n* zero-shift QR algorithm. The SVD of B has the form\n* \n* B = Q * S * P**H\n* \n* where S is the diagonal matrix of singular values, Q is an orthogonal\n* matrix of left singular vectors, and P is an orthogonal matrix of\n* right singular vectors. If left singular vectors are requested, this\n* subroutine actually returns U*Q instead of Q, and, if right singular\n* vectors are requested, this subroutine returns P**H*VT instead of\n* P**H, for given complex input matrices U and VT. When U and VT are\n* the unitary matrices that reduce a general matrix A to bidiagonal\n* form: A = U*B*VT, as computed by ZGEBRD, then\n* \n* A = (U*Q) * S * (P**H*VT)\n* \n* is the SVD of A. Optionally, the subroutine may also compute Q**H*C\n* for a given complex input matrix C.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices With\n* Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n* no. 5, pp. 873-912, Sept 1990) and\n* \"Accurate singular values and differential qd algorithms,\" by\n* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n* Department, University of California at Berkeley, July 1992\n* for a detailed description of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': B is upper bidiagonal;\n* = 'L': B is lower bidiagonal.\n*\n* N (input) INTEGER\n* The order of the matrix B. N >= 0.\n*\n* NCVT (input) INTEGER\n* The number of columns of the matrix VT. NCVT >= 0.\n*\n* NRU (input) INTEGER\n* The number of rows of the matrix U. NRU >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the bidiagonal matrix B.\n* On exit, if INFO=0, the singular values of B in decreasing\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the N-1 offdiagonal elements of the bidiagonal\n* matrix B.\n* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n* will contain the diagonal and superdiagonal elements of a\n* bidiagonal matrix orthogonally equivalent to the one given\n* as input.\n*\n* VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)\n* On entry, an N-by-NCVT matrix VT.\n* On exit, VT is overwritten by P**H * VT.\n* Not referenced if NCVT = 0.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT.\n* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n* U (input/output) COMPLEX*16 array, dimension (LDU, N)\n* On entry, an NRU-by-N matrix U.\n* On exit, U is overwritten by U * Q.\n* Not referenced if NRU = 0.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,NRU).\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC, NCC)\n* On entry, an N-by-NCC matrix C.\n* On exit, C is overwritten by Q**H * C.\n* Not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm did not converge; D and E contain the\n* elements of a bidiagonal matrix which is orthogonally\n* similar to the input matrix B; if INFO = i, i\n* elements of E have not converged to zero.\n*\n* Internal Parameters\n* ===================\n*\n* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n* TOLMUL controls the convergence criterion of the QR loop.\n* If it is positive, TOLMUL*EPS is the desired relative\n* precision in the computed singular values.\n* If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n* desired absolute accuracy in the computed singular\n* values (corresponds to relative accuracy\n* abs(TOLMUL*EPS) in the largest singular value.\n* abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n* between 10 (for fast convergence) and .1/EPS\n* (for there to be some accuracy in the results).\n* Default is to lose at either one eighth or 2 of the\n* available decimal digits in each computed singular value\n* (whichever is smaller).\n*\n* MAXITR INTEGER, default = 6\n* MAXITR controls the maximum number of passes of the\n* algorithm through its inner loop. The algorithms stops\n* (and so fails to converge) if the number of passes\n* through the inner loop exceeds MAXITR*N**2.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_nru = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vt = argv[4];
- rb_u = argv[5];
- rb_c = argv[6];
-
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (6th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_u) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_DCOMPLEX)
- rb_u = na_change_type(rb_u, NA_DCOMPLEX);
- u = NA_PTR_TYPE(rb_u, doublecomplex*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
- ncvt = NA_SHAPE1(rb_vt);
- ldvt = NA_SHAPE0(rb_vt);
- if (NA_TYPE(rb_vt) != NA_DCOMPLEX)
- rb_vt = na_change_type(rb_vt, NA_DCOMPLEX);
- vt = NA_PTR_TYPE(rb_vt, doublecomplex*);
- nru = NUM2INT(rb_nru);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = ncvt;
- rb_vt_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vt_out__ = NA_PTR_TYPE(rb_vt_out__, doublecomplex*);
- MEMCPY(vt_out__, vt, doublecomplex, NA_TOTAL(rb_vt));
- rb_vt = rb_vt_out__;
- vt = vt_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = n;
- rb_u_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, doublecomplex*);
- MEMCPY(u_out__, u, doublecomplex, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- rwork = ALLOC_N(doublereal, ((ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)));
-
- zbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_info, rb_d, rb_e, rb_vt, rb_u, rb_c);
-}
-
-void
-init_lapack_zbdsqr(VALUE mLapack){
- rb_define_module_function(mLapack, "zbdsqr", rb_zbdsqr, -1);
-}
diff --git a/zcgesv.c b/zcgesv.c
deleted file mode 100644
index 9d732e9..0000000
--- a/zcgesv.c
+++ /dev/null
@@ -1,99 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zcgesv_(integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork, doublereal *rwork, integer *iter, integer *info);
-
-static VALUE
-rb_zcgesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_iter;
- integer iter;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
- complex *swork;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, x, iter, info, a = NumRu::Lapack.zcgesv( a, b)\n or\n NumRu::Lapack.zcgesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* ZCGESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* ZCGESV first attempts to factorize the matrix in COMPLEX and use this\n* factorization within an iterative refinement procedure to produce a\n* solution with COMPLEX*16 normwise backward error quality (see below).\n* If the approach fails the method switches to a COMPLEX*16\n* factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio COMPLEX performance over COMPLEX*16 performance is too\n* small. A reasonable strategy should take the number of right-hand\n* sides and the size of the matrix into account. This might be done\n* with a call to ILAENV in the future. Up to now, we always try\n* iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array,\n* dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n* Corresponds either to the single precision factorization\n* (if INFO.EQ.0 and ITER.GE.0) or the double precision\n* factorization (if INFO.EQ.0 and ITER.LT.0).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, COMPLEX*16\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of CGETRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, U(i,i) computed in COMPLEX*16 is exactly\n* zero. The factorization has been completed, but the\n* factor U is exactly singular, so the solution\n* could not be computed.\n*\n* =========\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n*nrhs));
- swork = ALLOC_N(complex, (n*(n+nrhs)));
- rwork = ALLOC_N(doublereal, (n));
-
- zcgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, x, &ldx, work, swork, rwork, &iter, &info);
-
- free(work);
- free(swork);
- free(rwork);
- rb_iter = INT2NUM(iter);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_x, rb_iter, rb_info, rb_a);
-}
-
-void
-init_lapack_zcgesv(VALUE mLapack){
- rb_define_module_function(mLapack, "zcgesv", rb_zcgesv, -1);
-}
diff --git a/zcposv.c b/zcposv.c
deleted file mode 100644
index c1ae6c9..0000000
--- a/zcposv.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zcposv_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork, doublereal *rwork, integer *iter, integer *info);
-
-static VALUE
-rb_zcposv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_iter;
- integer iter;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
- complex *swork;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iter, info, a = NumRu::Lapack.zcposv( uplo, a, b)\n or\n NumRu::Lapack.zcposv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n* Purpose\n* =======\n*\n* ZCPOSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* ZCPOSV first attempts to factorize the matrix in COMPLEX and use this\n* factorization within an iterative refinement procedure to produce a\n* solution with COMPLEX*16 normwise backward error quality (see below).\n* If the approach fails the method switches to a COMPLEX*16\n* factorization and solve.\n*\n* The iterative refinement is not going to be a winning strategy if\n* the ratio COMPLEX performance over COMPLEX*16 performance is too\n* small. A reasonable strategy should take the number of right-hand\n* sides and the size of the matrix into account. This might be done\n* with a call to ILAENV in the future. Up to now, we always try\n* iterative refinement.\n*\n* The iterative refinement process is stopped if\n* ITER > ITERMAX\n* or for all the RHS we have:\n* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n* where\n* o ITER is the number of the current iteration in the iterative\n* refinement process\n* o RNRM is the infinity-norm of the residual\n* o XNRM is the infinity-norm of the solution\n* o ANRM is the infinity-operator-norm of the matrix A\n* o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n* respectively.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array,\n* dimension (LDA,N)\n* On entry, the Hermitian 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* Note that the imaginary parts of the diagonal\n* elements need not be set and are assumed to be zero.\n*\n* On exit, if iterative refinement has been successfully used\n* (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n* unchanged, if double precision factorization has been used\n* (INFO.EQ.0 and ITER.LT.0, see description below), then the\n* array A contains the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)\n* This array is used to hold the residual vectors.\n*\n* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))\n* This array is used to use the single precision matrix and the\n* right-hand sides or solutions in single precision.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* ITER (output) INTEGER\n* < 0: iterative refinement has failed, COMPLEX*16\n* factorization has been performed\n* -1 : the routine fell back to full precision for\n* implementation- or machine-specific reasons\n* -2 : narrowing the precision induced an overflow,\n* the routine fell back to full precision\n* -3 : failure of CPOTRF\n* -31: stop the iterative refinement after the 30th\n* iterations\n* > 0: iterative refinement has been sucessfully used.\n* Returns the number of iterations\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, the leading minor of order i of\n* (COMPLEX*16) A is not positive definite, so the\n* factorization could not be completed, and the solution\n* has not been computed.\n*\n* =========\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n*nrhs));
- swork = ALLOC_N(complex, (n*(n+nrhs)));
- rwork = ALLOC_N(doublereal, (n));
-
- zcposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, work, swork, rwork, &iter, &info);
-
- free(work);
- free(swork);
- free(rwork);
- rb_iter = INT2NUM(iter);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_x, rb_iter, rb_info, rb_a);
-}
-
-void
-init_lapack_zcposv(VALUE mLapack){
- rb_define_module_function(mLapack, "zcposv", rb_zcposv, -1);
-}
diff --git a/zdrscl.c b/zdrscl.c
deleted file mode 100644
index c2e7aa8..0000000
--- a/zdrscl.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zdrscl_(integer *n, doublereal *sa, doublecomplex *sx, integer *incx);
-
-static VALUE
-rb_zdrscl(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_sa;
- doublereal sa;
- VALUE rb_sx;
- doublecomplex *sx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_sx_out__;
- doublecomplex *sx_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sx = NumRu::Lapack.zdrscl( n, sa, sx, incx)\n or\n NumRu::Lapack.zdrscl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZDRSCL( N, SA, SX, INCX )\n\n* Purpose\n* =======\n*\n* ZDRSCL multiplies an n-element complex vector x by the real scalar\n* 1/a. This is done without overflow or underflow as long as\n* the final result x/a does not overflow or underflow.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of components of the vector x.\n*\n* SA (input) DOUBLE PRECISION\n* The scalar a which is used to divide each component of x.\n* SA must be >= 0, or the subroutine will divide by zero.\n*\n* SX (input/output) COMPLEX*16 array, dimension\n* (1+(N-1)*abs(INCX))\n* The n-element vector x.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector SX.\n* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_sa = argv[1];
- rb_sx = argv[2];
- rb_incx = argv[3];
-
- sa = NUM2DBL(rb_sa);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_sx))
- rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
- if (NA_RANK(rb_sx) != 1)
- rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_sx) != (1+(n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
- if (NA_TYPE(rb_sx) != NA_DCOMPLEX)
- rb_sx = na_change_type(rb_sx, NA_DCOMPLEX);
- sx = NA_PTR_TYPE(rb_sx, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*abs(incx);
- rb_sx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- sx_out__ = NA_PTR_TYPE(rb_sx_out__, doublecomplex*);
- MEMCPY(sx_out__, sx, doublecomplex, NA_TOTAL(rb_sx));
- rb_sx = rb_sx_out__;
- sx = sx_out__;
-
- zdrscl_(&n, &sa, sx, &incx);
-
- return rb_sx;
-}
-
-void
-init_lapack_zdrscl(VALUE mLapack){
- rb_define_module_function(mLapack, "zdrscl", rb_zdrscl, -1);
-}
diff --git a/zgbbrd.c b/zgbbrd.c
deleted file mode 100644
index 7810309..0000000
--- a/zgbbrd.c
+++ /dev/null
@@ -1,138 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbbrd_(char *vect, integer *m, integer *n, integer *ncc, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, doublereal *d, doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *pt, integer *ldpt, doublecomplex *c, integer *ldc, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgbbrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_pt;
- doublecomplex *pt;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldc;
- integer ncc;
- integer ldq;
- integer m;
- integer ldpt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, q, pt, info, ab, c = NumRu::Lapack.zgbbrd( vect, kl, ku, ab, c)\n or\n NumRu::Lapack.zgbbrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBBRD reduces a complex general m-by-n band matrix A to real upper\n* bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* The routine computes B, and optionally forms Q or P', or computes\n* Q'*C for a given matrix C.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether or not the matrices Q and P' are to be\n* formed.\n* = 'N': do not form Q or P';\n* = 'Q': form Q only;\n* = 'P': form P' only;\n* = 'B': form both.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NCC (input) INTEGER\n* The number of columns of the matrix C. NCC >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals of the matrix A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the m-by-n band matrix A, stored in rows 1 to\n* KL+KU+1. The j-th column of A is stored in the j-th column of\n* the array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n* On exit, A is overwritten by values generated during the\n* reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B.\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The superdiagonal elements of the bidiagonal matrix B.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,M)\n* If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n* If VECT = 'N' or 'P', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n* PT (output) COMPLEX*16 array, dimension (LDPT,N)\n* If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n* If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n* LDPT (input) INTEGER\n* The leading dimension of the array PT.\n* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,NCC)\n* On entry, an m-by-ncc matrix C.\n* On exit, C is overwritten by Q'*C.\n* C is not referenced if NCC = 0.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C.\n* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(M,N))\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- ncc = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- vect = StringValueCStr(rb_vect)[0];
- ku = NUM2INT(rb_ku);
- m = ldab;
- ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
- ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = m;
- rb_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldpt;
- shape[1] = n;
- rb_pt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- pt = NA_PTR_TYPE(rb_pt, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = ncc;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (MAX(m,n)));
- rwork = ALLOC_N(doublereal, (MAX(m,n)));
-
- zgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_q, rb_pt, rb_info, rb_ab, rb_c);
-}
-
-void
-init_lapack_zgbbrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbbrd", rb_zgbbrd, -1);
-}
diff --git a/zgbcon.c b/zgbcon.c
deleted file mode 100644
index a276cea..0000000
--- a/zgbcon.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbcon_(char *norm, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zgbcon( norm, kl, ku, ab, ipiv, anorm)\n or\n NumRu::Lapack.zgbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBCON estimates the reciprocal of the condition number of a complex\n* general band matrix A, in either the 1-norm or the infinity-norm,\n* using the LU factorization computed by ZGBTRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_anorm = argv[5];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zgbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbcon", rb_zgbcon, -1);
-}
diff --git a/zgbequ.c b/zgbequ.c
deleted file mode 100644
index 0b003e0..0000000
--- a/zgbequ.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbequ_(integer *m, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_zgbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequ( m, kl, ku, ab)\n or\n NumRu::Lapack.zgbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGBEQU computes row and column scalings intended to equilibrate an\n* M-by-N band matrix A and reduce its condition number. R returns the\n* row scale factors and C the column scale factors, chosen to try to\n* make the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0, or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MAX(1,m);
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- zgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_zgbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbequ", rb_zgbequ, -1);
-}
diff --git a/zgbequb.c b/zgbequb.c
deleted file mode 100644
index c4dda4b..0000000
--- a/zgbequb.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbequb_(integer *m, integer *n, integer *kl, integer *ku, doublereal *ab, integer *ldab, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_zgbequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequb( kl, ku, ab)\n or\n NumRu::Lapack.zgbequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGBEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from ZGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", m);
- m = ldab;
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- ku = NUM2INT(rb_ku);
- ldab = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- zgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_zgbequb(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbequb", rb_zgbequb, -1);
-}
diff --git a/zgbrfs.c b/zgbrfs.c
deleted file mode 100644
index 48971ab..0000000
--- a/zgbrfs.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbrfs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zgbrfs( trans, kl, ku, ab, afb, ipiv, b, x)\n or\n NumRu::Lapack.zgbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is banded, 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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGBTRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zgbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbrfs", rb_zgbrfs, -1);
-}
diff --git a/zgbrfsx.c b/zgbrfsx.c
deleted file mode 100644
index e635013..0000000
--- a/zgbrfsx.c
+++ /dev/null
@@ -1,230 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbrfsx_(char *trans, char *equed, integer *n, integer *kl, integer *ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, integer *ldafb, integer *ipiv, doublereal *r, doublereal *c, doublereal *b, integer *ldb, doublereal *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgbrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_afb;
- doublereal *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_x_out__;
- doublereal *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.zgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.zgbrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBRFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The original band matrix A, stored in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by DGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from DGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_r = argv[7];
- rb_c = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
- rb_params = argv[11];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (8th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DFLOAT)
- rb_afb = na_change_type(rb_afb, NA_DFLOAT);
- afb = NA_PTR_TYPE(rb_afb, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- ku = NUM2INT(rb_ku);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublereal*);
- MEMCPY(x_out__, x, doublereal, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_r, rb_c, rb_x, rb_params);
-}
-
-void
-init_lapack_zgbrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbrfsx", rb_zgbrfsx, -1);
-}
diff --git a/zgbsv.c b/zgbsv.c
deleted file mode 100644
index 7a49c81..0000000
--- a/zgbsv.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbsv_(integer *n, integer *kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zgbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab, b = NumRu::Lapack.zgbsv( kl, ku, ab, b)\n or\n NumRu::Lapack.zgbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGBSV computes the solution to a complex system of linear equations\n* A * X = B, where A is a band matrix of order N with KL subdiagonals\n* and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as A = L * U, where L is a product of permutation\n* and unit lower triangular matrices with KL subdiagonals, and U is\n* upper triangular with KL+KU superdiagonals. The factored form of A\n* is then used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGBTRF, ZGBTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_zgbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbsv", rb_zgbsv, -1);
-}
diff --git a/zgbsvx.c b/zgbsvx.c
deleted file mode 100644
index f894e18..0000000
--- a/zgbsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbsvx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_afb_out__;
- doublecomplex *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *work;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.zgbsvx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.zgbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a band matrix of order N with KL subdiagonals and KU\n* superdiagonals, and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed by this subroutine:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = L * U,\n* where L is a product of permutation and unit lower triangular\n* matrices with KL subdiagonals, and U is upper triangular with\n* KL+KU superdiagonals.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB and IPIV contain the factored form of\n* A. If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* AB, AFB, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then A must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns details of the LU factorization of A.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns details of the LU factorization of the equilibrated\n* matrix A (see the description of AB for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n* Moved setting of INFO = N+1 so INFO does not subsequently get\n* overwritten. Sven, 17 Mar 05. \n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- equed = StringValueCStr(rb_equed)[0];
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, doublecomplex*);
- MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublecomplex, (2*n));
-
- zgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_rwork, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_zgbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbsvx", rb_zgbsvx, -1);
-}
diff --git a/zgbsvxx.c b/zgbsvxx.c
deleted file mode 100644
index 5950855..0000000
--- a/zgbsvxx.c
+++ /dev/null
@@ -1,270 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbsvxx_(char *fact, char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgbsvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_afb_out__;
- doublecomplex *afb_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.zgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.zgbsvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGBSVXX uses the LU factorization to compute the solution to a\n* complex*16 system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZGBSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZGBSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZGBSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZGBSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* If FACT = 'F' and EQUED is not 'N', then AB must have been\n* equilibrated by the scaling factors in R and/or C. AB is not\n* modified if FACT = 'F' or 'N', or if FACT = 'E' and\n* EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains details of the LU factorization of the band matrix\n* A, as computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n* the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by DGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In DGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_equed = argv[7];
- rb_r = argv[8];
- rb_c = argv[9];
- rb_b = argv[10];
- rb_params = argv[11];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (10th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (12th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (9th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, doublecomplex*);
- MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_ab, rb_afb, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_zgbsvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbsvxx", rb_zgbsvxx, -1);
-}
diff --git a/zgbtf2.c b/zgbtf2.c
deleted file mode 100644
index 9d34a80..0000000
--- a/zgbtf2.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbtf2_(integer *m, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_zgbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.zgbtf2( m, kl, ku, ab)\n or\n NumRu::Lapack.zgbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGBTF2 computes an LU factorization of a complex m-by-n band matrix\n* A using partial pivoting with row interchanges.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U, because of fill-in resulting from the row\n* interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_zgbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbtf2", rb_zgbtf2, -1);
-}
diff --git a/zgbtrf.c b/zgbtrf.c
deleted file mode 100644
index 1d7115b..0000000
--- a/zgbtrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbtrf_(integer *m, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, integer *ipiv, integer *info);
-
-static VALUE
-rb_zgbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ab = NumRu::Lapack.zgbtrf( m, kl, ku, ab)\n or\n NumRu::Lapack.zgbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGBTRF computes an LU factorization of a complex m-by-n band matrix A\n* using partial pivoting with row interchanges.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows KL+1 to\n* 2*KL+KU+1; rows 1 to KL of the array need not be set.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, details of the factorization: U is stored as an\n* upper triangular band matrix with KL+KU superdiagonals in\n* rows 1 to KL+KU+1, and the multipliers used during the\n* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n* See below for further details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* M = N = 6, KL = 2, KU = 1:\n*\n* On entry: On exit:\n*\n* * * * + + + * * * u14 u25 u36\n* * * + + + + * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n* a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n*\n* Array elements marked * are not used by the routine; elements marked\n* + need not be set on entry, but are required by the routine to store\n* elements of U because of fill-in resulting from the row interchanges.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ab);
-}
-
-void
-init_lapack_zgbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbtrf", rb_zgbtrf, -1);
-}
diff --git a/zgbtrs.c b/zgbtrs.c
deleted file mode 100644
index e2f74b7..0000000
--- a/zgbtrs.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgbtrs_(char *trans, integer *n, integer *kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zgbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zgbtrs( trans, kl, ku, ab, ipiv, b)\n or\n NumRu::Lapack.zgbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGBTRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general band matrix A using the LU factorization computed\n* by ZGBTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular band\n* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n* the multipliers used during the factorization are stored in\n* rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\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).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- ku = NUM2INT(rb_ku);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zgbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zgbtrs", rb_zgbtrs, -1);
-}
diff --git a/zgebak.c b/zgebak.c
deleted file mode 100644
index d1506a3..0000000
--- a/zgebak.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgebak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, doublereal *scale, integer *m, doublecomplex *v, integer *ldv, integer *info);
-
-static VALUE
-rb_zgebak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- doublereal *scale;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- doublecomplex *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.zgebak( job, side, ilo, ihi, scale, v)\n or\n NumRu::Lapack.zgebak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBAK forms the right or left eigenvectors of a complex general\n* matrix by backward transformation on the computed eigenvectors of the\n* balanced matrix output by ZGEBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N', do nothing, return immediately;\n* = 'P', do backward transformation for permutation only;\n* = 'S', do backward transformation for scaling only;\n* = 'B', do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to ZGEBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by ZGEBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* SCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutation and scaling factors, as returned\n* by ZGEBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX*16 array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by ZHSEIN or ZTREVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_scale = argv[4];
- rb_v = argv[5];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- if (!NA_IsNArray(rb_scale))
- rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
- if (NA_RANK(rb_scale) != 1)
- rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_scale);
- if (NA_TYPE(rb_scale) != NA_DFLOAT)
- rb_scale = na_change_type(rb_scale, NA_DFLOAT);
- scale = NA_PTR_TYPE(rb_scale, doublereal*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- job = StringValueCStr(rb_job)[0];
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublecomplex*);
- MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- zgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_zgebak(VALUE mLapack){
- rb_define_module_function(mLapack, "zgebak", rb_zgebak, -1);
-}
diff --git a/zgebal.c b/zgebal.c
deleted file mode 100644
index fabde92..0000000
--- a/zgebal.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgebal_(char *job, integer *n, doublecomplex *a, integer *lda, integer *ilo, integer *ihi, doublereal *scale, integer *info);
-
-static VALUE
-rb_zgebal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- doublereal *scale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, scale, info, a = NumRu::Lapack.zgebal( job, a)\n or\n NumRu::Lapack.zgebal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBAL balances a general complex matrix A. This involves, first,\n* permuting A by a similarity transformation to isolate eigenvalues\n* in the first 1 to ILO-1 and last IHI+1 to N elements on the\n* diagonal; and second, applying a diagonal similarity transformation\n* to rows and columns ILO to IHI to make the rows and columns as\n* close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrix, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A:\n* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n* for i = 1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\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 input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied to\n* A. If P(j) is the index of the row and column interchanged\n* with row and column j and D(j) is the scaling factor\n* applied to row and column j, then\n* SCALE(j) = P(j) for j = 1,...,ILO-1\n* = D(j) for j = ILO,...,IHI\n* = P(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-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* Further Details\n* ===============\n*\n* The permutations consist of row and column interchanges which put\n* the matrix in the form\n*\n* ( T1 X Y )\n* P A P = ( 0 B Z )\n* ( 0 0 T2 )\n*\n* where T1 and T2 are upper triangular matrices whose eigenvalues lie\n* along the diagonal. The column indices ILO and IHI mark the starting\n* and ending columns of the submatrix B. Balancing consists of applying\n* a diagonal similarity transformation inv(D) * B * D to make the\n* 1-norms of each row of B and its corresponding column nearly equal.\n* The output matrix is\n*\n* ( T1 X*D Y )\n* ( 0 inv(D)*B*D inv(D)*Z ).\n* ( 0 0 T2 )\n*\n* Information about the permutations P and the diagonal matrix D is\n* returned in the vector SCALE.\n*\n* This subroutine is based on the EISPACK routine CBAL.\n*\n* Modified by Tzu-Yi Chen, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);
-
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ilo, rb_ihi, rb_scale, rb_info, rb_a);
-}
-
-void
-init_lapack_zgebal(VALUE mLapack){
- rb_define_module_function(mLapack, "zgebal", rb_zgebal, -1);
-}
diff --git a/zgebd2.c b/zgebd2.c
deleted file mode 100644
index 2025f70..0000000
--- a/zgebd2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgebd2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *d, doublereal *e, doublecomplex *tauq, doublecomplex *taup, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgebd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tauq;
- doublecomplex *tauq;
- VALUE rb_taup;
- doublecomplex *taup;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, info, a = NumRu::Lapack.zgebd2( m, a)\n or\n NumRu::Lapack.zgebd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBD2 reduces a complex general m by n matrix A to upper or lower\n* real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX*16 array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, v and u are complex vectors;\n* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n* tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, doublecomplex*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (MAX(m,n)));
-
- zgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tauq, rb_taup, rb_info, rb_a);
-}
-
-void
-init_lapack_zgebd2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgebd2", rb_zgebd2, -1);
-}
diff --git a/zgebrd.c b/zgebrd.c
deleted file mode 100644
index 8577c0f..0000000
--- a/zgebrd.c
+++ /dev/null
@@ -1,102 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgebrd_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *d, doublereal *e, doublecomplex *tauq, doublecomplex *taup, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgebrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tauq;
- doublecomplex *tauq;
- VALUE rb_taup;
- doublecomplex *taup;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, work, info, a = NumRu::Lapack.zgebrd( m, a, lwork)\n or\n NumRu::Lapack.zgebrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEBRD reduces a general complex M-by-N matrix A to upper or lower\n* bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n*\n* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N general matrix to be reduced.\n* On exit,\n* if m >= n, the diagonal and the first superdiagonal are\n* overwritten with the upper bidiagonal matrix B; the\n* elements below the diagonal, with the array TAUQ, represent\n* the unitary matrix Q as a product of elementary\n* reflectors, and the elements above the first superdiagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors;\n* if m < n, the diagonal and the first subdiagonal are\n* overwritten with the lower bidiagonal matrix B; the\n* elements below the first subdiagonal, with the array TAUQ,\n* represent the unitary matrix Q as a product of\n* elementary reflectors, and the elements above the diagonal,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The diagonal elements of the bidiagonal matrix B:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n* The off-diagonal elements of the bidiagonal matrix B:\n* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n* TAUQ (output) COMPLEX*16 array dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,M,N).\n* For optimum performance LWORK >= (M+N)*NB, where NB\n* is the optimal blocksize.\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 matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* If m >= n,\n*\n* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n* A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n* A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n,\n*\n* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The contents of A on exit are illustrated by the following examples:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n* ( v1 v2 v3 v4 v5 )\n*\n* where d and e denote diagonal and off-diagonal elements of B, vi\n* denotes an element of the vector defining H(i), and ui an element of\n* the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n)-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, doublecomplex*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgebrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zgebrd", rb_zgebrd, -1);
-}
diff --git a/zgecon.c b/zgecon.c
deleted file mode 100644
index c0ce91b..0000000
--- a/zgecon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgecon_(char *norm, integer *n, doublecomplex *a, integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgecon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zgecon( norm, a, anorm)\n or\n NumRu::Lapack.zgecon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGECON estimates the reciprocal of the condition number of a general\n* complex matrix A, in either the 1-norm or the infinity-norm, using\n* the LU factorization computed by ZGETRF.\n*\n* An estimate is obtained for norm(inv(A)), and the reciprocal of the\n* condition number is 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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- norm = StringValueCStr(rb_norm)[0];
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zgecon(VALUE mLapack){
- rb_define_module_function(mLapack, "zgecon", rb_zgecon, -1);
-}
diff --git a/zgeequ.c b/zgeequ.c
deleted file mode 100644
index 53784f6..0000000
--- a/zgeequ.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeequ_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_zgeequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequ( a)\n or\n NumRu::Lapack.zgeequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEQU computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n* R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n* number and BIGNUM = largest safe number. Use of these scaling\n* factors is not guaranteed to reduce the condition number of A but\n* works well in practice.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- zgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_zgeequ(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeequ", rb_zgeequ, -1);
-}
diff --git a/zgeequb.c b/zgeequb.c
deleted file mode 100644
index 25b325f..0000000
--- a/zgeequb.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeequb_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer *info);
-
-static VALUE
-rb_zgeequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequb( a)\n or\n NumRu::Lapack.zgeequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEQUB computes row and column scalings intended to equilibrate an\n* M-by-N matrix A and reduce its condition number. R returns the row\n* scale factors and C the column scale factors, chosen to try to make\n* the largest element in each row and column of the matrix B with\n* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n* the radix.\n*\n* R(i) and C(j) are restricted to be a power of the radix between\n* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n* of these scaling factors is not guaranteed to reduce the condition\n* number of A but works well in practice.\n*\n* This routine differs from ZGEEQU by restricting the scaling factors\n* to a power of the radix. Baring over- and underflow, scaling by\n* these factors introduces no additional rounding errors. However, the\n* scaled entries' magnitured are no longer approximately 1 but lie\n* between sqrt(radix) and 1/sqrt(radix).\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The M-by-N matrix whose equilibration factors are\n* to be computed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* R (output) DOUBLE PRECISION array, dimension (M)\n* If INFO = 0 or INFO > M, R contains the row scale factors\n* for A.\n*\n* C (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, C contains the column scale factors for A.\n*\n* ROWCND (output) DOUBLE PRECISION\n* If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n* AMAX is neither too large nor too small, it is not worth\n* scaling by R.\n*\n* COLCND (output) DOUBLE PRECISION\n* If INFO = 0, COLCND contains the ratio of the smallest\n* C(i) to the largest C(i). If COLCND >= 0.1, it is not\n* worth scaling by C.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, and i is\n* <= M: the i-th row of A is exactly zero\n* > M: the (i-M)-th column of A is exactly zero\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lda = m;
- {
- int shape[1];
- shape[0] = m;
- rb_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r = NA_PTR_TYPE(rb_r, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
-
- zgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);
-
- rb_rowcnd = rb_float_new((double)rowcnd);
- rb_colcnd = rb_float_new((double)colcnd);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_r, rb_c, rb_rowcnd, rb_colcnd, rb_amax, rb_info);
-}
-
-void
-init_lapack_zgeequb(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeequb", rb_zgeequb, -1);
-}
diff --git a/zgees.c b/zgees.c
deleted file mode 100644
index a83c283..0000000
--- a/zgees.c
+++ /dev/null
@@ -1,117 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(doublecomplex *arg0){
- VALUE rb_arg0;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
-
- rb_ret = rb_yield_values(1, rb_arg0);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID zgees_(char *jobvs, char *sort, L_fp *select, integer *n, doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info);
-
-static VALUE
-rb_zgees(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_vs;
- doublecomplex *vs;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, w, vs, work, info, a = NumRu::Lapack.zgees( jobvs, sort, a, lwork){|a| ... }\n or\n NumRu::Lapack.zgees # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEES computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left.\n* The leading columns of Z then form an orthonormal basis for the\n* invariant subspace corresponding to the selected eigenvalues.\n*\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered:\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* IF SORT = 'N', SELECT is not referenced.\n* The eigenvalue W(j) is selected if SELECT(W(j)) is true.\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 N-by-N matrix A.\n* On exit, A has been overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues, in the same order that\n* they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX*16 array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1; if\n* JOBVS = 'V', LDVS >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged;\n* if JOBVS = 'V', VS contains the matrix which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because\n* some eigenvalues were too close to separate (the\n* problem is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Schur form no longer satisfy\n* SELECT = .TRUE.. This could also be caused by\n* underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- lwork = NUM2INT(rb_lwork);
- sort = StringValueCStr(rb_sort)[0];
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- zgees_(&jobvs, &sort, rb_select, &n, a, &lda, &sdim, w, vs, &ldvs, work, &lwork, rwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_sdim, rb_w, rb_vs, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgees(VALUE mLapack){
- rb_define_module_function(mLapack, "zgees", rb_zgees, -1);
-}
diff --git a/zgeesx.c b/zgeesx.c
deleted file mode 100644
index 0181a9c..0000000
--- a/zgeesx.c
+++ /dev/null
@@ -1,127 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_select(doublecomplex *arg0){
- VALUE rb_arg0;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
-
- rb_ret = rb_yield_values(1, rb_arg0);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID zgeesx_(char *jobvs, char *sort, L_fp *select, char *sense, integer *n, doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, doublecomplex *vs, integer *ldvs, doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info);
-
-static VALUE
-rb_zgeesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvs;
- char jobvs;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_vs;
- doublecomplex *vs;
- VALUE rb_rconde;
- doublereal rconde;
- VALUE rb_rcondv;
- doublereal rcondv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldvs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.zgeesx( jobvs, sort, sense, a, lwork){|a| ... }\n or\n NumRu::Lapack.zgeesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n* vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n*\n* Optionally, it also orders the eigenvalues on the diagonal of the\n* Schur form so that selected eigenvalues are at the top left;\n* computes a reciprocal condition number for the average of the\n* selected eigenvalues (RCONDE); and computes a reciprocal condition\n* number for the right invariant subspace corresponding to the\n* selected eigenvalues (RCONDV). The leading columns of Z form an\n* orthonormal basis for this invariant subspace.\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n* these quantities are called s and sep respectively).\n*\n* A complex matrix is in Schur form if it is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVS (input) CHARACTER*1\n* = 'N': Schur vectors are not computed;\n* = 'V': Schur vectors are computed.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELECT).\n*\n* SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n* SELECT must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'S', SELECT is used to select eigenvalues to order\n* to the top left of the Schur form.\n* If SORT = 'N', SELECT is not referenced.\n* An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for average of selected eigenvalues only;\n* = 'V': Computed for selected right invariant subspace only;\n* = 'B': Computed for both.\n* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\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 N-by-N matrix A.\n* On exit, A is overwritten by its Schur form T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues for which\n* SELECT is true.\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues, in the same order\n* that they appear on the diagonal of the output Schur form T.\n*\n* VS (output) COMPLEX*16 array, dimension (LDVS,N)\n* If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n* vectors.\n* If JOBVS = 'N', VS is not referenced.\n*\n* LDVS (input) INTEGER\n* The leading dimension of the array VS. LDVS >= 1, and if\n* JOBVS = 'V', LDVS >= N.\n*\n* RCONDE (output) DOUBLE PRECISION\n* If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n* condition number for the average of the selected eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION\n* If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n* condition number for the selected right invariant subspace.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n* where SDIM is the number of selected eigenvalues computed by\n* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n* that an error is only returned if LWORK < max(1,2*N), but if\n* SENSE = 'E' or 'V' or 'B' this may not be large enough.\n* For good performance, LWORK must generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates upper bound on the optimal size of the\n* array WORK, returns this value as the first entry of the WORK\n* array, and no error message related to LWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is\n* <= N: the QR algorithm failed to compute all the\n* eigenvalues; elements 1:ILO-1 and i+1:N of W\n* contain those eigenvalues which have converged; if\n* JOBVS = 'V', VS contains the transformation which\n* reduces A to its partially converged Schur form.\n* = N+1: the eigenvalues could not be reordered because some\n* eigenvalues were too close to separate (the problem\n* is very ill-conditioned);\n* = N+2: after reordering, roundoff changed values of some\n* complex eigenvalues so that leading eigenvalues in\n* the Schur form no longer satisfy SELECT=.TRUE. This\n* could also be caused by underflow due to scaling.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvs = argv[0];
- rb_sort = argv[1];
- rb_sense = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- jobvs = StringValueCStr(rb_jobvs)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- ldvs = lsame_(&jobvs,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvs;
- shape[1] = n;
- rb_vs = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vs = NA_PTR_TYPE(rb_vs, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- zgeesx_(&jobvs, &sort, rb_select, &sense, &n, a, &lda, &sdim, w, vs, &ldvs, &rconde, &rcondv, work, &lwork, rwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_rconde = rb_float_new((double)rconde);
- rb_rcondv = rb_float_new((double)rcondv);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_sdim, rb_w, rb_vs, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeesx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeesx", rb_zgeesx, -1);
-}
diff --git a/zgeev.c b/zgeev.c
deleted file mode 100644
index 84b233c..0000000
--- a/zgeev.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeev_(char *jobvl, char *jobvr, integer *n, doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgeev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, vl, vr, work, info, a = NumRu::Lapack.zgeev( jobvl, jobvr, a, lwork)\n or\n NumRu::Lapack.zgeev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of are computed.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\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 N-by-N matrix A.\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors have been computed;\n* elements and i+1:N of W contain eigenvalues which have\n* converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgeev_(&jobvl, &jobvr, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_vl, rb_vr, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeev(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeev", rb_zgeev, -1);
-}
diff --git a/zgeevx.c b/zgeevx.c
deleted file mode 100644
index 99d3c4c..0000000
--- a/zgeevx.c
+++ /dev/null
@@ -1,148 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm, doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgeevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_scale;
- doublereal *scale;
- VALUE rb_abnrm;
- doublereal abnrm;
- VALUE rb_rconde;
- doublereal *rconde;
- VALUE rb_rcondv;
- doublereal *rcondv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.zgeevx( balanc, jobvl, jobvr, sense, a, lwork)\n or\n NumRu::Lapack.zgeevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n* eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n* Optionally also, it computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n* (RCONDE), and reciprocal condition numbers for the right\n* eigenvectors (RCONDV).\n*\n* The right eigenvector v(j) of A satisfies\n* A * v(j) = lambda(j) * v(j)\n* where lambda(j) is its eigenvalue.\n* The left eigenvector u(j) of A satisfies\n* u(j)**H * A = lambda(j) * u(j)**H\n* where u(j)**H denotes the conjugate transpose of u(j).\n*\n* The computed eigenvectors are normalized to have Euclidean norm\n* equal to 1 and largest component real.\n*\n* Balancing a matrix means permuting the rows and columns to make it\n* more nearly upper triangular, and applying a diagonal similarity\n* transformation D * A * D**(-1), where D is a diagonal matrix, to\n* make its rows and columns closer in norm and the condition numbers\n* of its eigenvalues and eigenvectors smaller. The computed\n* reciprocal condition numbers correspond to the balanced matrix.\n* Permuting rows and columns will not change the condition numbers\n* (in exact arithmetic) but diagonal scaling will. For further\n* explanation of balancing, see section 4.10.2 of the LAPACK\n* Users' Guide.\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Indicates how the input matrix should be diagonally scaled\n* and/or permuted to improve the conditioning of its\n* eigenvalues.\n* = 'N': Do not diagonally scale or permute;\n* = 'P': Perform permutations to make the matrix more nearly\n* upper triangular. Do not diagonally scale;\n* = 'S': Diagonally scale the matrix, ie. replace A by\n* D*A*D**(-1), where D is a diagonal matrix chosen\n* to make the rows and columns of A more equal in\n* norm. Do not permute;\n* = 'B': Both diagonally scale and permute A.\n*\n* Computed reciprocal condition numbers will be for the matrix\n* after balancing and/or permuting. Permuting does not change\n* condition numbers (in exact arithmetic), but balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': left eigenvectors of A are not computed;\n* = 'V': left eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': right eigenvectors of A are not computed;\n* = 'V': right eigenvectors of A are computed.\n* If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': None are computed;\n* = 'E': Computed for eigenvalues only;\n* = 'V': Computed for right eigenvectors only;\n* = 'B': Computed for eigenvalues and right eigenvectors.\n*\n* If SENSE = 'E' or 'B', both left and right eigenvectors\n* must also be computed (JOBVL = 'V' and JOBVR = 'V').\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 N-by-N matrix A.\n* On exit, A has been overwritten. If JOBVL = 'V' or\n* JOBVR = 'V', A contains the Schur form of the balanced\n* version of the matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* W contains the computed eigenvalues.\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored one\n* after another in the columns of VL, in the same order\n* as their eigenvalues.\n* If JOBVL = 'N', VL is not referenced.\n* u(j) = VL(:,j), the j-th column of VL.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; if\n* JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors v(j) are stored one\n* after another in the columns of VR, in the same order\n* as their eigenvalues.\n* If JOBVR = 'N', VR is not referenced.\n* v(j) = VR(:,j), the j-th column of VR.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1; if\n* JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values determined when A was\n* balanced. The balanced A(i,j) = 0 if I > J and\n* J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n* SCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* when balancing A. If P(j) is the index of the row and column\n* interchanged with row and column j, and D(j) is the scaling\n* factor applied to row and column j, then\n* SCALE(J) = P(J), for J = 1,...,ILO-1\n* = D(J), for J = ILO,...,IHI\n* = P(J) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix (the maximum\n* of the sum of absolute values of elements of any column).\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* RCONDE(j) is the reciprocal condition number of the j-th\n* eigenvalue.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* RCONDV(j) is the reciprocal condition number of the j-th\n* right eigenvector.\n*\n* WORK (workspace/output) COMPLEX*16 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. If SENSE = 'N' or 'E',\n* LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n* LWORK >= N*N+2*N.\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, the QR algorithm failed to compute all the\n* eigenvalues, and no eigenvectors or condition numbers\n* have been computed; elements 1:ILO-1 and i+1:N of W\n* contain eigenvalues which have converged.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- sense = StringValueCStr(rb_sense)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- scale = NA_PTR_TYPE(rb_scale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_w, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_scale, rb_abnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeevx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeevx", rb_zgeevx, -1);
-}
diff --git a/zgegs.c b/zgegs.c
deleted file mode 100644
index 7e8d36b..0000000
--- a/zgegs.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgegs_(char *jobvsl, char *jobvsr, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl, integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgegs(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_vsl;
- doublecomplex *vsl;
- VALUE rb_vsr;
- doublecomplex *vsr;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgegs( jobvsl, jobvsr, a, b, lwork)\n or\n NumRu::Lapack.zgegs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGGES.\n*\n* ZGEGS computes the eigenvalues, Schur form, and, optionally, the\n* left and or/right Schur vectors of a complex matrix pair (A,B).\n* Given two square matrices A and B, the generalized Schur\n* factorization has the form\n* \n* A = Q*S*Z**H, B = Q*T*Z**H\n* \n* where Q and Z are unitary matrices and S and T are upper triangular.\n* The columns of Q are the left Schur vectors\n* and the columns of Z are the right Schur vectors.\n* \n* If only the eigenvalues of (A,B) are needed, the driver routine\n* ZGEGV should be used instead. See ZGEGV for a description of the\n* eigenvalues of the generalized nonsymmetric eigenvalue problem\n* (GNEP).\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors (returned in VSL).\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors (returned in VSR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A.\n* On exit, the upper triangular matrix S from the generalized\n* Schur factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B.\n* On exit, the upper triangular matrix T from the generalized\n* Schur factorization.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur\n* form of A.\n*\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The non-negative real scalars beta that define the\n* eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element\n* of the triangular factor T.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n*\n* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n* If JOBVSL = 'V', the matrix of left Schur vectors Q.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n* If JOBVSR = 'V', the matrix of right Schur vectors Z.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;\n* the optimal LWORK is N*(NB+1).\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* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from ZGGBAL\n* =N+2: error return from ZGEQRF\n* =N+3: error return from ZUNMQR\n* =N+4: error return from ZUNGQR\n* =N+5: error return from ZGGHRD\n* =N+6: error return from ZHGEQZ (other than failed\n* iteration)\n* =N+7: error return from ZGGBAK (computing VSL)\n* =N+8: error return from ZGGBAK (computing VSR)\n* =N+9: error return from ZLASCL (various places)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (3*n));
-
- zgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_alpha, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zgegs(VALUE mLapack){
- rb_define_module_function(mLapack, "zgegs", rb_zgegs, -1);
-}
diff --git a/zgegv.c b/zgegv.c
deleted file mode 100644
index e85a0f7..0000000
--- a/zgegv.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgegv_(char *jobvl, char *jobvr, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgegv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zgegv( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.zgegv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGGEV.\n*\n* ZGEGV computes the eigenvalues and, optionally, the left and/or right\n* eigenvectors of a complex matrix pair (A,B).\n* Given two square matrices A and B,\n* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n* eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n* that\n* A*x = lambda*B*x.\n*\n* An alternate form is to find the eigenvalues mu and corresponding\n* eigenvectors y such that\n* mu*A*y = B*y.\n*\n* These two forms are equivalent with mu = 1/lambda and x = y if\n* neither lambda nor mu is zero. In order to deal with the case that\n* lambda or mu is zero or small, two values alpha and beta are returned\n* for each eigenvalue, such that lambda = alpha/beta and\n* mu = beta/alpha.\n*\n* The vectors x and y in the above equations are right eigenvectors of\n* the matrix pair (A,B). Vectors u and v satisfying\n* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n* are left eigenvectors of (A,B).\n*\n* Note: this routine performs \"full balancing\" on A and B -- see\n* \"Further Details\", below.\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors (returned\n* in VL).\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors (returned\n* in VR).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit A\n* contains the Schur form of A from the generalized Schur\n* factorization of the pair (A,B) after balancing. If no\n* eigenvectors were computed, then only the diagonal elements\n* of the Schur form will be correct. See ZGGHRD and ZHGEQZ\n* for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B.\n* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n* upper triangular matrix obtained from B in the generalized\n* Schur factorization of the pair (A,B) after balancing.\n* If no eigenvectors were computed, then only the diagonal\n* elements of B will be correct. See ZGGHRD and ZHGEQZ for\n* details.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP.\n*\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars beta that define the eigenvalues of GNEP.\n* \n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left eigenvectors u(j) are stored\n* in the columns of VL, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right eigenvectors x(j) are stored\n* in the columns of VR, in the same order as their eigenvalues.\n* Each eigenvector is scaled so that its largest component has\n* abs(real part) + abs(imag. part) = 1, except for eigenvectors\n* corresponding to an eigenvalue with alpha = beta = 0, which\n* are set to zero.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\n* To compute the optimal value of LWORK, call ILAENV to get\n* blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.) Then compute:\n* NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR;\n* The optimal LWORK is MAX( 2*N, N*(NB+1) ).\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* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: errors that usually indicate LAPACK problems:\n* =N+1: error return from ZGGBAL\n* =N+2: error return from ZGEQRF\n* =N+3: error return from ZUNMQR\n* =N+4: error return from ZUNGQR\n* =N+5: error return from ZGGHRD\n* =N+6: error return from ZHGEQZ (other than failed\n* iteration)\n* =N+7: error return from ZTGEVC\n* =N+8: error return from ZGGBAK (computing VL)\n* =N+9: error return from ZGGBAK (computing VR)\n* =N+10: error return from ZLASCL (various calls)\n*\n\n* Further Details\n* ===============\n*\n* Balancing\n* ---------\n*\n* This driver calls ZGGBAL to both permute and scale rows and columns\n* of A and B. The permutations PL and PR are chosen so that PL*A*PR\n* and PL*B*R will be upper triangular except for the diagonal blocks\n* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n* possible. The diagonal scaling matrices DL and DR are chosen so\n* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n* one (except for the elements that start out zero.)\n*\n* After the eigenvalues and eigenvectors of the balanced matrices\n* have been computed, ZGGBAK transforms the eigenvectors back to what\n* they would have been (in perfect arithmetic) if they had not been\n* balanced.\n*\n* Contents of A and B on Exit\n* -------- -- - --- - -- ----\n*\n* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n* both), then on exit the arrays A and B will contain the complex Schur\n* form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n* are computed, then only the diagonal blocks will be correct.\n*\n* [*] In other words, upper triangular form.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = 8*n;
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_vl, rb_vr, rb_work, rb_rwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zgegv(VALUE mLapack){
- rb_define_module_function(mLapack, "zgegv", rb_zgegv, -1);
-}
diff --git a/zgehd2.c b/zgehd2.c
deleted file mode 100644
index f3c2eb8..0000000
--- a/zgehd2.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgehd2_(integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgehd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgehd2( ilo, ihi, a)\n or\n NumRu::Lapack.zgehd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n* by a unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to ZGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= max(1,N).\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the n by n general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zgehd2_(&n, &ilo, &ihi, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_zgehd2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgehd2", rb_zgehd2, -1);
-}
diff --git a/zgehrd.c b/zgehrd.c
deleted file mode 100644
index d617ae9..0000000
--- a/zgehrd.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgehrd_(integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgehrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgehrd( ilo, ihi, a, lwork)\n or\n NumRu::Lapack.zgehrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n* an unitary similarity transformation: Q' * A * Q = H .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that A is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to ZGEBAL; otherwise they should be\n* set to 1 and N respectively. See Further Details.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* elements below the first subdiagonal, with the array TAU,\n* represent the unitary matrix Q as a product of elementary\n* reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n* zero.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of (ihi-ilo) elementary\n* reflectors\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n* exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n* The contents of A are illustrated by the following example, with\n* n = 7, ilo = 2 and ihi = 6:\n*\n* on entry, on exit,\n*\n* ( a a a a a a a ) ( a a h h h h a )\n* ( a a a a a a ) ( a h h h h a )\n* ( a a a a a a ) ( h h h h h h )\n* ( a a a a a a ) ( v2 h h h h h )\n* ( a a a a a a ) ( v2 v3 h h h h )\n* ( a a a a a a ) ( v2 v3 v4 h h h )\n* ( a ) ( a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This file is a slight modification of LAPACK-3.0's DGEHRD\n* subroutine incorporating improvements proposed by Quintana-Orti and\n* Van de Geijn (2006). (See DLAHR2.)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ilo = NUM2INT(rb_ilo);
- lwork = NUM2INT(rb_lwork);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgehrd_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgehrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zgehrd", rb_zgehrd, -1);
-}
diff --git a/zgelq2.c b/zgelq2.c
deleted file mode 100644
index 88a4693..0000000
--- a/zgelq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgelq2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgelq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgelq2( a)\n or\n NumRu::Lapack.zgelq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELQ2 computes an LQ factorization of a complex m by n matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m by min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (m));
-
- zgelq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_zgelq2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgelq2", rb_zgelq2, -1);
-}
diff --git a/zgelqf.c b/zgelqf.c
deleted file mode 100644
index 43c115d..0000000
--- a/zgelqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgelqf_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgelqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgelqf( m, a, lwork)\n or\n NumRu::Lapack.zgelqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELQF computes an LQ factorization of a complex M-by-N matrix A:\n* A = L * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and below the diagonal of the array\n* contain the m-by-min(m,n) lower trapezoidal matrix L (L is\n* lower triangular if m <= n); the elements above the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n* A(i,i+1:n), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGELQ2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgelqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgelqf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgelqf", rb_zgelqf, -1);
-}
diff --git a/zgels.c b/zgels.c
deleted file mode 100644
index f39c72e..0000000
--- a/zgels.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgels_(char *trans, integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgels(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a, b = NumRu::Lapack.zgels( trans, m, a, b, lwork)\n or\n NumRu::Lapack.zgels # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELS solves overdetermined or underdetermined complex linear systems\n* involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n* or LQ factorization of A. It is assumed that A has full rank.\n*\n* The following options are provided:\n*\n* 1. If TRANS = 'N' and m >= n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A*X ||.\n*\n* 2. If TRANS = 'N' and m < n: find the minimum norm solution of\n* an underdetermined system A * X = B.\n*\n* 3. If TRANS = 'C' and m >= n: find the minimum norm solution of\n* an undetermined system A**H * X = B.\n*\n* 4. If TRANS = 'C' and m < n: find the least squares solution of\n* an overdetermined system, i.e., solve the least squares problem\n* minimize || B - A**H * X ||.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* = 'N': the linear system involves A;\n* = 'C': the linear system involves A**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of the matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* if M >= N, A is overwritten by details of its QR\n* factorization as returned by ZGEQRF;\n* if M < N, A is overwritten by details of its LQ\n* factorization as returned by ZGELQF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the matrix B of right hand side vectors, stored\n* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS\n* if TRANS = 'C'.\n* On exit, if INFO = 0, B is overwritten by the solution\n* vectors, stored columnwise:\n* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least\n* squares solution vectors; the residual sum of squares for the\n* solution in each column is given by the sum of squares of the\n* modulus of elements N+1 to M in that column;\n* if TRANS = 'N' and m < n, rows 1 to N of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m >= n, rows 1 to M of B contain the\n* minimum norm solution vectors;\n* if TRANS = 'C' and m < n, rows 1 to M of B contain the\n* least squares solution vectors; the residual sum of squares\n* for the solution in each column is given by the sum of\n* squares of the modulus of elements M+1 to N in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= MAX(1,M,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* LWORK >= max( 1, MN + max( MN, NRHS ) ).\n* For optimal performance,\n* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).\n* where MN = min(M,N) and NB is the optimum block size.\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* > 0: if INFO = i, the i-th diagonal element of the\n* triangular factor of A is zero, so that A does not have\n* full rank; the least squares solution could not be\n* computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgels_(&trans, &m, &n, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zgels(VALUE mLapack){
- rb_define_module_function(mLapack, "zgels", rb_zgels, -1);
-}
diff --git a/zgelsd.c b/zgelsd.c
deleted file mode 100644
index 9c74934..0000000
--- a/zgelsd.c
+++ /dev/null
@@ -1,117 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgelsd_(integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work, integer *lwork, doublereal *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zgelsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer c__9;
- integer c__0;
- integer lrwork;
- integer liwork;
- integer smlsiz;
- integer nlvl;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, b = NumRu::Lapack.zgelsd( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.zgelsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELSD computes the minimum-norm solution to a real linear least\n* squares problem:\n* minimize 2-norm(| b - A*x |)\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The problem is solved in three steps:\n* (1) Reduce the coefficient matrix A to bidiagonal form with\n* Householder tranformations, reducing the original problem\n* into a \"bidiagonal least squares problem\" (BLS)\n* (2) Solve the BLS using a divide and conquer approach.\n* (3) Apply back all the Householder tranformations to solve\n* the original least squares problem.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX*16 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 must be at least 1.\n* The exact minimum amount of workspace needed depends on M,\n* N and NRHS. As long as LWORK is at least\n* 2*N + N*NRHS\n* if M is greater than or equal to N or\n* 2*M + M*NRHS\n* if M is less than N, the code will execute correctly.\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the array WORK and the\n* minimum sizes of the arrays RWORK and IWORK, and returns\n* these values as the first entries of the WORK, RWORK and\n* IWORK arrays, and no error message related to LWORK is issued\n* by XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* LRWORK >=\n* 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is greater than or equal to N or\n* 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n* if M is less than N, the code will execute correctly.\n* SMLSIZ is returned by ILAENV and is equal to the maximum\n* size of the subproblems at the bottom of the computation\n* tree (usually about 25), and\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n* On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n*\n* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n* where MINMN = MIN( M,N ).\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- c__9 = 9;
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- c__0 = 0;
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- smlsiz = ilaenv_(&c__9,"ZGELSD"," ",&c__0,&c__0,&c__0,&c__0);
- nlvl = MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)));
- liwork = MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)));
- lrwork = m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
- iwork = ALLOC_N(integer, (MAX(1,liwork)));
-
- zgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, iwork, &info);
-
- free(rwork);
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_s, rb_rank, rb_work, rb_info, rb_b);
-}
-
-void
-init_lapack_zgelsd(VALUE mLapack){
- rb_define_module_function(mLapack, "zgelsd", rb_zgelsd, -1);
-}
diff --git a/zgelss.c b/zgelss.c
deleted file mode 100644
index 6c3bbcd..0000000
--- a/zgelss.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgelss_(integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgelss(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, rank, work, info, a, b = NumRu::Lapack.zgelss( m, a, b, rcond, lwork)\n or\n NumRu::Lapack.zgelss # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELSS computes the minimum norm solution to a complex linear\n* least squares problem:\n*\n* Minimize 2-norm(| b - A*x |).\n*\n* using the singular value decomposition (SVD) of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix\n* X.\n*\n* The effective rank of A is determined by treating as zero those\n* singular values which are less than RCOND times the largest singular\n* value.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the first min(m,n) rows of A are overwritten with\n* its right singular vectors, stored rowwise.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, B is overwritten by the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of the modulus of elements n+1:m in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A in decreasing order.\n* The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A.\n* Singular values S(i) <= RCOND*S(1) are treated as zero.\n* If RCOND < 0, machine precision is used instead.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the number of singular values\n* which are greater than RCOND*S(1).\n*\n* WORK (workspace/output) COMPLEX*16 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, and also:\n* LWORK >= 2*min(M,N) + max(M,N,NRHS)\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: the algorithm for computing the SVD failed to converge;\n* if INFO = i, i off-diagonal elements of an intermediate\n* bidiagonal form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_rcond = argv[3];
- rb_lwork = argv[4];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (5*MIN(m,n)));
-
- zgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_rank, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zgelss(VALUE mLapack){
- rb_define_module_function(mLapack, "zgelss", rb_zgelss, -1);
-}
diff --git a/zgelsx.c b/zgelsx.c
deleted file mode 100644
index cb500d0..0000000
--- a/zgelsx.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgelsx_(integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgelsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, a, b, jpvt = NumRu::Lapack.zgelsx( m, a, b, jpvt, rcond)\n or\n NumRu::Lapack.zgelsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGELSY.\n*\n* ZGELSX computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n* If m >= n and RANK = n, the residual sum-of-squares for\n* the solution in the i-th column is given by the sum of\n* squares of elements N+1:M in that column.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n* initial column, otherwise it is a free column. Before\n* the QR factorization of A, all initial columns are\n* permuted to the leading positions; only the remaining\n* free columns are moved as a result of column pivoting\n* during the factorization.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(doublecomplex, (MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_zgelsx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgelsx", rb_zgelsx, -1);
-}
diff --git a/zgelsy.c b/zgelsy.c
deleted file mode 100644
index 53d083c..0000000
--- a/zgelsy.c
+++ /dev/null
@@ -1,129 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgelsy_(integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgelsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_rank;
- integer rank;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, work, info, a, b, jpvt = NumRu::Lapack.zgelsy( m, a, b, jpvt, rcond, lwork)\n or\n NumRu::Lapack.zgelsy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGELSY computes the minimum-norm solution to a complex linear least\n* squares problem:\n* minimize || A * X - B ||\n* using a complete orthogonal factorization of A. A is an M-by-N\n* matrix which may be rank-deficient.\n*\n* Several right hand side vectors b and solution vectors x can be\n* handled in a single call; they are stored as the columns of the\n* M-by-NRHS right hand side matrix B and the N-by-NRHS solution\n* matrix X.\n*\n* The routine first computes a QR factorization with column pivoting:\n* A * P = Q * [ R11 R12 ]\n* [ 0 R22 ]\n* with R11 defined as the largest leading submatrix whose estimated\n* condition number is less than 1/RCOND. The order of R11, RANK,\n* is the effective rank of A.\n*\n* Then, R22 is considered to be negligible, and R12 is annihilated\n* by unitary transformations from the right, arriving at the\n* complete orthogonal factorization:\n* A * P = Q * [ T11 0 ] * Z\n* [ 0 0 ]\n* The minimum-norm solution is then\n* X = P * Z' [ inv(T11)*Q1'*B ]\n* [ 0 ]\n* where Q1 consists of the first RANK columns of Q.\n*\n* This routine is basically identical to the original xGELSX except\n* three differences:\n* o The permutation of matrix B (the right hand side) is faster and\n* more simple.\n* o The call to the subroutine xGEQPF has been substituted by the\n* the call to the subroutine xGEQP3. This subroutine is a Blas-3\n* version of the QR factorization with column pivoting.\n* o Matrix B (the right hand side) is updated with Blas-3.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of\n* columns of matrices B and X. NRHS >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A has been overwritten by details of its\n* complete orthogonal factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the M-by-NRHS right hand side matrix B.\n* On exit, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M,N).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of AP, otherwise column i is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* RCOND (input) DOUBLE PRECISION\n* RCOND is used to determine the effective rank of A, which\n* is defined as the order of the largest leading triangular\n* submatrix R11 in the QR factorization with pivoting of A,\n* whose estimated condition number < 1/RCOND.\n*\n* RANK (output) INTEGER\n* The effective rank of A, i.e., the order of the submatrix\n* R11. This is the same as the order of the submatrix T11\n* in the complete orthogonal factorization of A.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* The unblocked strategy requires that:\n* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n* where MN = min(M,N).\n* The block algorithm requires that:\n* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n* where NB is an upper bound on the blocksize returned\n* by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,\n* and ZUNMRZ.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_jpvt = argv[3];
- rb_rcond = argv[4];
- rb_lwork = argv[5];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_rank, rb_work, rb_info, rb_a, rb_b, rb_jpvt);
-}
-
-void
-init_lapack_zgelsy(VALUE mLapack){
- rb_define_module_function(mLapack, "zgelsy", rb_zgelsy, -1);
-}
diff --git a/zgeql2.c b/zgeql2.c
deleted file mode 100644
index 03fc409..0000000
--- a/zgeql2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeql2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgeql2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgeql2( m, a)\n or\n NumRu::Lapack.zgeql2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQL2 computes a QL factorization of a complex m by n matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the m by n lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zgeql2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeql2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeql2", rb_zgeql2, -1);
-}
diff --git a/zgeqlf.c b/zgeqlf.c
deleted file mode 100644
index dedb212..0000000
--- a/zgeqlf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeqlf_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgeqlf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgeqlf( m, a, lwork)\n or\n NumRu::Lapack.zgeqlf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQLF computes a QL factorization of a complex M-by-N matrix A:\n* A = Q * L.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m >= n, the lower triangle of the subarray\n* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n* if m <= n, the elements on and below the (n-m)-th\n* superdiagonal contain the M-by-N lower trapezoidal matrix L;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of elementary reflectors\n* (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n* A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQL2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgeqlf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeqlf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeqlf", rb_zgeqlf, -1);
-}
diff --git a/zgeqp3.c b/zgeqp3.c
deleted file mode 100644
index 9aa6628..0000000
--- a/zgeqp3.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeqp3_(integer *m, integer *n, doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgeqp3(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a, jpvt = NumRu::Lapack.zgeqp3( m, a, jpvt, lwork)\n or\n NumRu::Lapack.zgeqp3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQP3 computes a QR factorization with column pivoting of a\n* matrix A: A*P = Q*R using Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper trapezoidal matrix R; the elements below\n* the diagonal, together with the array TAU, represent the\n* unitary matrix Q as a product of min(M,N) elementary\n* reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(J)=0,\n* the J-th column of A is a free column.\n* On exit, if JPVT(J)=K, then the J-th column of A*P was the\n* the K-th column of A.\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= N+1.\n* For optimal performance LWORK >= ( N+1 )*NB, where NB\n* is the optimal blocksize.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a real/complex scalar, and v is a real/complex vector\n* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n* A(i+1:m,i), and tau in TAU(i).\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_tau, rb_work, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_zgeqp3(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeqp3", rb_zgeqp3, -1);
-}
diff --git a/zgeqpf.c b/zgeqpf.c
deleted file mode 100644
index 7cb959c..0000000
--- a/zgeqpf.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeqpf_(integer *m, integer *n, doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgeqpf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a, jpvt = NumRu::Lapack.zgeqpf( m, a, jpvt)\n or\n NumRu::Lapack.zgeqpf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZGEQP3.\n*\n* ZGEQPF computes a QR factorization with column pivoting of a\n* complex M-by-N matrix A: A*P = Q*R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of the array contains the\n* min(M,N)-by-N upper triangular matrix R; the elements\n* below the diagonal, together with the array TAU,\n* represent the unitary matrix Q as a product of\n* min(m,n) elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(n)\n*\n* Each H(i) has the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n* The matrix P is represented in jpvt as follows: If\n* jpvt(j) = i\n* then the jth column of P is the ith canonical unit vector.\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_jpvt = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgeqpf_(&m, &n, a, &lda, jpvt, tau, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_info, rb_a, rb_jpvt);
-}
-
-void
-init_lapack_zgeqpf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeqpf", rb_zgeqpf, -1);
-}
diff --git a/zgeqr2.c b/zgeqr2.c
deleted file mode 100644
index 7e9d986..0000000
--- a/zgeqr2.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeqr2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgeqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgeqr2( m, a)\n or\n NumRu::Lapack.zgeqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQR2 computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zgeqr2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeqr2", rb_zgeqr2, -1);
-}
diff --git a/zgeqr2p.c b/zgeqr2p.c
deleted file mode 100644
index bd9db9e..0000000
--- a/zgeqr2p.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeqr2p_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgeqr2p(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgeqr2p( m, a)\n or\n NumRu::Lapack.zgeqr2p # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQR2P computes a QR factorization of a complex m by n matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(m,n) by n upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zgeqr2p_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeqr2p(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeqr2p", rb_zgeqr2p, -1);
-}
diff --git a/zgeqrf.c b/zgeqrf.c
deleted file mode 100644
index 4d0430b..0000000
--- a/zgeqrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeqrf_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgeqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgeqrf( m, a, lwork)\n or\n NumRu::Lapack.zgeqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQRF computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQR2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgeqrf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeqrf", rb_zgeqrf, -1);
-}
diff --git a/zgeqrfp.c b/zgeqrfp.c
deleted file mode 100644
index eb7b68e..0000000
--- a/zgeqrfp.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgeqrfp_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgeqrfp(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgeqrfp( m, a, lwork)\n or\n NumRu::Lapack.zgeqrfp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n* A = Q * R.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n* upper triangular if m >= n); the elements below the diagonal,\n* with the array TAU, represent the unitary matrix Q as a\n* product of min(m,n) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n* and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,\n $ NBMIN, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQR2P, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgeqrfp_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgeqrfp(VALUE mLapack){
- rb_define_module_function(mLapack, "zgeqrfp", rb_zgeqrfp, -1);
-}
diff --git a/zgerfs.c b/zgerfs.c
deleted file mode 100644
index 7d718fa..0000000
--- a/zgerfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgerfs_(char *trans, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgerfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zgerfs( trans, a, af, ipiv, b, x)\n or\n NumRu::Lapack.zgerfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERFS improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates for\n* 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)\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGETRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zgerfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zgerfs", rb_zgerfs, -1);
-}
diff --git a/zgerfsx.c b/zgerfsx.c
deleted file mode 100644
index 06f44a4..0000000
--- a/zgerfsx.c
+++ /dev/null
@@ -1,200 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgerfsx_(char *trans, char *equed, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *r, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgerfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.zgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params)\n or\n NumRu::Lapack.zgerfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERFSX improves the computed solution to a system of linear\n* equations and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED, R\n* and C below. In this case, the solution and error bounds returned\n* are for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\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* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The original N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* R (input) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. \n* If R is accessed, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed.\n* If C is accessed, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_r = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_x = argv[8];
- rb_params = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (9th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (6th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_x, rb_params);
-}
-
-void
-init_lapack_zgerfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgerfsx", rb_zgerfsx, -1);
-}
diff --git a/zgerq2.c b/zgerq2.c
deleted file mode 100644
index 1a3ae27..0000000
--- a/zgerq2.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgerq2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgerq2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.zgerq2( a)\n or\n NumRu::Lapack.zgerq2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERQ2 computes an RQ factorization of a complex m by n matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the m by n upper trapezoidal matrix R; the remaining\n* elements, with the array TAU, represent the unitary matrix\n* Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = lda;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (m));
-
- zgerq2_(&m, &n, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_zgerq2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgerq2", rb_zgerq2, -1);
-}
diff --git a/zgerqf.c b/zgerqf.c
deleted file mode 100644
index 0353bce..0000000
--- a/zgerqf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgerqf_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgerqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.zgerqf( m, a, lwork)\n or\n NumRu::Lapack.zgerqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGERQF computes an RQ factorization of a complex M-by-N matrix A:\n* A = R * Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if m <= n, the upper triangle of the subarray\n* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n* if m >= n, the elements on and above the (m-n)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R;\n* the remaining elements, with the array TAU, represent the\n* unitary matrix Q as a product of min(m,n) elementary\n* reflectors (see Further Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)', where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n* exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGERQ2, ZLARFB, ZLARFT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgerqf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgerqf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgerqf", rb_zgerqf, -1);
-}
diff --git a/zgesc2.c b/zgesc2.c
deleted file mode 100644
index 06fbb3a..0000000
--- a/zgesc2.c
+++ /dev/null
@@ -1,89 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgesc2_(integer *n, doublecomplex *a, integer *lda, doublecomplex *rhs, integer *ipiv, integer *jpiv, doublereal *scale);
-
-static VALUE
-rb_zgesc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_rhs;
- doublecomplex *rhs;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_rhs_out__;
- doublecomplex *rhs_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, rhs = NumRu::Lapack.zgesc2( a, rhs, ipiv, jpiv)\n or\n NumRu::Lapack.zgesc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n* Purpose\n* =======\n*\n* ZGESC2 solves a system of linear equations\n*\n* A * X = scale* RHS\n*\n* with a general N-by-N matrix A using the LU factorization with\n* complete pivoting computed by ZGETC2.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix A computed by ZGETC2: A = P * L * U * Q\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* RHS (input/output) COMPLEX*16 array, dimension N.\n* On entry, the right hand side vector b.\n* On exit, the solution vector X.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, SCALE contains the scale factor. SCALE is chosen\n* 0 <= SCALE <= 1 to prevent owerflow in the solution.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_rhs = argv[1];
- rb_ipiv = argv[2];
- rb_jpiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_DCOMPLEX)
- rb_rhs = na_change_type(rb_rhs, NA_DCOMPLEX);
- rhs = NA_PTR_TYPE(rb_rhs, doublecomplex*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, doublecomplex*);
- MEMCPY(rhs_out__, rhs, doublecomplex, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- zgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);
-
- rb_scale = rb_float_new((double)scale);
- return rb_ary_new3(2, rb_scale, rb_rhs);
-}
-
-void
-init_lapack_zgesc2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgesc2", rb_zgesc2, -1);
-}
diff --git a/zgesdd.c b/zgesdd.c
deleted file mode 100644
index 96b543e..0000000
--- a/zgesdd.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgesdd_(char *jobz, integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u, integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work, integer *lwork, doublereal *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zgesdd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_u;
- doublecomplex *u;
- VALUE rb_vt;
- doublecomplex *vt;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldu;
- integer ucol;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.zgesdd( jobz, m, a, lwork)\n or\n NumRu::Lapack.zgesdd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESDD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors, by using divide-and-conquer method. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns VT = V**H, not V.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U and all N rows of V**H are\n* returned in the arrays U and VT;\n* = 'S': the first min(M,N) columns of U and the first\n* min(M,N) rows of V**H are returned in the arrays U\n* and VT;\n* = 'O': If M >= N, the first N columns of U are overwritten\n* in the array A and all rows of V**H are returned in\n* the array VT;\n* otherwise, all columns of U are returned in the\n* array U and the first M rows of V**H are overwritten\n* in the array A;\n* = 'N': no columns of U or rows of V**H are computed.\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 >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBZ = 'O', A is overwritten with the first N columns\n* of U (the left singular vectors, stored\n* columnwise) if M >= N;\n* A is overwritten with the first M rows\n* of V**H (the right singular vectors, stored\n* rowwise) otherwise.\n* if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX*16 array, dimension (LDU,UCOL)\n* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n* UCOL = min(M,N) if JOBZ = 'S'.\n* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n* unitary matrix U;\n* if JOBZ = 'S', U contains the first min(M,N) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n* VT (output) COMPLEX*16 array, dimension (LDVT,N)\n* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n* N-by-N unitary matrix V**H;\n* if JOBZ = 'S', VT contains the first min(M,N) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n* if JOBZ = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX*16 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 JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n* if JOBZ = 'O',\n* LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* if JOBZ = 'S' or 'A',\n* LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n* For good performance, LWORK should generally be larger.\n*\n* If LWORK = -1, a workspace query is assumed. The optimal\n* size for the WORK array is calculated and stored in WORK(1),\n* and no other work except argument checking is performed.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* If JOBZ = 'N', LRWORK >= 5*min(M,N).\n* Otherwise,\n* LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n*\n* IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The updating process of DBDSDC did not converge.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- m = NUM2INT(rb_m);
- jobz = StringValueCStr(rb_jobz)[0];
- ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
- ldu = ((lsame_(&jobz,"S")) || ((('a') || (((lsame_(&jobz,"O")) && (m < n)))))) ? m : 1;
- ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m == n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = ucol;
- rb_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (MAX(1, lsame_(&jobz,"N") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1))));
- iwork = ALLOC_N(integer, (8*MIN(m,n)));
-
- zgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info);
-
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgesdd(VALUE mLapack){
- rb_define_module_function(mLapack, "zgesdd", rb_zgesdd, -1);
-}
diff --git a/zgesv.c b/zgesv.c
deleted file mode 100644
index 6b79c00..0000000
--- a/zgesv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgesv_(integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zgesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a, b = NumRu::Lapack.zgesv( a, b)\n or\n NumRu::Lapack.zgesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* The LU decomposition with partial pivoting and row interchanges is\n* used to factor A as\n* A = P * L * U,\n* where P is a permutation matrix, L is unit lower triangular, and U is\n* upper triangular. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N coefficient matrix A.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* The pivot indices that define the permutation matrix P;\n* row i of the matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS matrix of right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGETRF, ZGETRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zgesv(VALUE mLapack){
- rb_define_module_function(mLapack, "zgesv", rb_zgesv, -1);
-}
diff --git a/zgesvd.c b/zgesvd.c
deleted file mode 100644
index 3b8a7e3..0000000
--- a/zgesvd.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgesvd_(char *jobu, char *jobvt, integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u, integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgesvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobvt;
- char jobvt;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_u;
- doublecomplex *u;
- VALUE rb_vt;
- doublecomplex *vt;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldu;
- integer ldvt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, u, vt, work, info, a = NumRu::Lapack.zgesvd( jobu, jobvt, m, a, lwork)\n or\n NumRu::Lapack.zgesvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESVD computes the singular value decomposition (SVD) of a complex\n* M-by-N matrix A, optionally computing the left and/or right singular\n* vectors. The SVD is written\n*\n* A = U * SIGMA * conjugate-transpose(V)\n*\n* where SIGMA is an M-by-N matrix which is zero except for its\n* min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n* V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n* are the singular values of A; they are real and non-negative, and\n* are returned in descending order. The first min(m,n) columns of\n* U and V are the left and right singular vectors of A.\n*\n* Note that the routine returns V**H, not V.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix U:\n* = 'A': all M columns of U are returned in array U:\n* = 'S': the first min(m,n) columns of U (the left singular\n* vectors) are returned in the array U;\n* = 'O': the first min(m,n) columns of U (the left singular\n* vectors) are overwritten on the array A;\n* = 'N': no columns of U (no left singular vectors) are\n* computed.\n*\n* JOBVT (input) CHARACTER*1\n* Specifies options for computing all or part of the matrix\n* V**H:\n* = 'A': all N rows of V**H are returned in the array VT;\n* = 'S': the first min(m,n) rows of V**H (the right singular\n* vectors) are returned in the array VT;\n* = 'O': the first min(m,n) rows of V**H (the right singular\n* vectors) are overwritten on the array A;\n* = 'N': no rows of V**H (no right singular vectors) are\n* computed.\n*\n* JOBVT and JOBU cannot both be 'O'.\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 >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit,\n* if JOBU = 'O', A is overwritten with the first min(m,n)\n* columns of U (the left singular vectors,\n* stored columnwise);\n* if JOBVT = 'O', A is overwritten with the first min(m,n)\n* rows of V**H (the right singular vectors,\n* stored rowwise);\n* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n* are destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* S (output) DOUBLE PRECISION array, dimension (min(M,N))\n* The singular values of A, sorted so that S(i) >= S(i+1).\n*\n* U (output) COMPLEX*16 array, dimension (LDU,UCOL)\n* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n* If JOBU = 'A', U contains the M-by-M unitary matrix U;\n* if JOBU = 'S', U contains the first min(m,n) columns of U\n* (the left singular vectors, stored columnwise);\n* if JOBU = 'N' or 'O', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= 1; if\n* JOBU = 'S' or 'A', LDU >= M.\n*\n* VT (output) COMPLEX*16 array, dimension (LDVT,N)\n* If JOBVT = 'A', VT contains the N-by-N unitary matrix\n* V**H;\n* if JOBVT = 'S', VT contains the first min(m,n) rows of\n* V**H (the right singular vectors, stored rowwise);\n* if JOBVT = 'N' or 'O', VT is not referenced.\n*\n* LDVT (input) INTEGER\n* The leading dimension of the array VT. LDVT >= 1; if\n* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* LWORK >= MAX(1,2*MIN(M,N)+MAX(M,N)).\n* For good performance, LWORK should generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n* On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n* unconverged superdiagonal elements of an upper bidiagonal\n* matrix B whose diagonal is in S (not necessarily sorted).\n* B satisfies A = U * B * VT, so it has the same singular\n* values as A, and singular vectors related by U and VT.\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 ZBDSQR did not converge, INFO specifies how many\n* superdiagonals of an intermediate bidiagonal form B\n* did not converge to zero. See the description of RWORK\n* above for details.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobvt = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- jobvt = StringValueCStr(rb_jobvt)[0];
- lwork = NUM2INT(rb_lwork);
- jobu = StringValueCStr(rb_jobu)[0];
- ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
- ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
- rb_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvt;
- shape[1] = n;
- rb_vt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vt = NA_PTR_TYPE(rb_vt, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (5*MIN(m,n)));
-
- zgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_s, rb_u, rb_vt, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgesvd(VALUE mLapack){
- rb_define_module_function(mLapack, "zgesvd", rb_zgesvd, -1);
-}
diff --git a/zgesvx.c b/zgesvx.c
deleted file mode 100644
index 6e9a5b9..0000000
--- a/zgesvx.c
+++ /dev/null
@@ -1,229 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgesvx_(char *fact, char *trans, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgesvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.zgesvx( fact, trans, a, af, ipiv, equed, r, c, b)\n or\n NumRu::Lapack.zgesvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESVX uses the LU factorization to compute the solution to a complex\n* system of linear equations\n* A * X = B,\n* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n* matrix A (after equilibration if FACT = 'E') as\n* A = P * L * U,\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n* to the original system of equations. Note that A and B are\n* modified on exit if EQUED .ne. 'N', and the solution to the\n* equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n* and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (2*N)\n* On exit, RWORK(1) contains the reciprocal pivot growth\n* factor norm(A)/norm(U). The \"max absolute element\" norm is\n* used. If RWORK(1) is much less than 1, then the stability\n* of the LU factorization of the (equilibrated) matrix A\n* could be poor. This also means that the solution X, condition\n* estimator RCOND, and forward error bound FERR could be\n* unreliable. If factorization fails with 0<INFO<=N, then\n* RWORK(1) contains the reciprocal pivot growth factor for the\n* leading INFO columns of A.\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, and i is\n* <= N: U(i,i) is exactly zero. The factorization has\n* been completed, but the factor U is exactly\n* singular, so the solution and error bounds\n* could not be computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = 2*n;
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublecomplex, (2*n));
-
- zgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_ferr, rb_berr, rb_rwork, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b);
-}
-
-void
-init_lapack_zgesvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgesvx", rb_zgesvx, -1);
-}
diff --git a/zgesvxx.c b/zgesvxx.c
deleted file mode 100644
index 75ca519..0000000
--- a/zgesvxx.c
+++ /dev/null
@@ -1,262 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgesvxx_(char *fact, char *trans, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, char *equed, doublereal *r, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgesvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_r_out__;
- doublereal *r_out__;
- VALUE rb_c_out__;
- doublereal *c_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.zgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params)\n or\n NumRu::Lapack.zgesvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGESVXX uses the LU factorization to compute the solution to a\n* complex*16 system of linear equations A * X = B, where A is an\n* N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZGESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZGESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZGESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZGESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n* or diag(C)*B (if TRANS = 'T' or 'C').\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = P * L * U,\n*\n* where P is a permutation matrix, L is a unit lower triangular\n* matrix, and U is upper triangular.\n*\n* 3. If some U(i,i)=0, so that U is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is less\n* than machine precision, the routine still goes on to solve for X\n* and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n* that it solves the original system before equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by R and C.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\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)\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n* not 'N', then A must have been equilibrated by the scaling\n* factors in R and/or C. A is not modified if FACT = 'F' or\n* 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if EQUED .ne. 'N', A is scaled as follows:\n* EQUED = 'R': A := diag(R) * A\n* EQUED = 'C': A := A * diag(C)\n* EQUED = 'B': A := diag(R) * A * diag(C).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then\n* AF is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the factors L and U from the factorization A = P*L*U\n* of the equilibrated matrix A (see the description of A for\n* the form of the equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the original matrix A.\n*\n* If FACT = 'E', then IPIV is an output argument and on exit\n* contains the pivot indices from the factorization A = P*L*U\n* of the equilibrated matrix A.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* R (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'R' or 'B', A is\n* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n* is not accessed. R is an input argument if FACT = 'F';\n* otherwise, R is an output argument. If FACT = 'F' and\n* EQUED = 'R' or 'B', each element of R must be positive.\n* If R is output, each element of R is a power of the radix.\n* If R is input, each element of R should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* C (input or output) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If EQUED = 'C' or 'B', A is\n* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n* is not accessed. C is an input argument if FACT = 'F';\n* otherwise, C is an output argument. If FACT = 'F' and\n* EQUED = 'C' or 'B', each element of C must be positive.\n* If C is output, each element of C is a power of the radix.\n* If C is input, each element of C should be a power of the radix\n* to ensure a reliable solution and error estimates. Scaling by\n* powers of the radix does not cause rounding errors unless the\n* result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n* diag(R)*B;\n* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n* overwritten by diag(C)*B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit\n* if EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A. In ZGESVX, this quantity is\n* returned in WORK(1).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_r = argv[6];
- rb_c = argv[7];
- rb_b = argv[8];
- rb_params = argv[9];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (7th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_r) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (10th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- r_out__ = NA_PTR_TYPE(rb_r_out__, doublereal*);
- MEMCPY(r_out__, r, doublereal, NA_TOTAL(rb_r));
- rb_r = rb_r_out__;
- r = r_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublereal*);
- MEMCPY(c_out__, c, doublereal, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(15, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_r, rb_c, rb_b, rb_params);
-}
-
-void
-init_lapack_zgesvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgesvxx", rb_zgesvxx, -1);
-}
diff --git a/zgetc2.c b/zgetc2.c
deleted file mode 100644
index c2a4c6d..0000000
--- a/zgetc2.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgetc2_(integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *jpiv, integer *info);
-
-static VALUE
-rb_zgetc2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, jpiv, info, a = NumRu::Lapack.zgetc2( a)\n or\n NumRu::Lapack.zgetc2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGETC2 computes an LU factorization, using complete pivoting, of the\n* n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n* where P and Q are permutation matrices, L is lower triangular with\n* unit diagonal elements and U is upper triangular.\n*\n* This is a level 1 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\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 n-by-n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U*Q; the unit diagonal elements of L are not stored.\n* If U(k, k) appears to be less than SMIN, U(k, k) is given the\n* value of SMIN, giving a nonsingular perturbed system.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, N).\n*\n* IPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (output) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, U(k, k) is likely to produce overflow if\n* one tries to solve for x in Ax = b. So U is perturbed\n* to avoid the overflow.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgetc2_(&n, a, &lda, ipiv, jpiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_jpiv, rb_info, rb_a);
-}
-
-void
-init_lapack_zgetc2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgetc2", rb_zgetc2, -1);
-}
diff --git a/zgetf2.c b/zgetf2.c
deleted file mode 100644
index e69c3ad..0000000
--- a/zgetf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgetf2_(integer *m, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_zgetf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zgetf2( m, a)\n or\n NumRu::Lapack.zgetf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGETF2 computes an LU factorization of a general m-by-n matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgetf2_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_zgetf2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgetf2", rb_zgetf2, -1);
-}
diff --git a/zgetrf.c b/zgetrf.c
deleted file mode 100644
index d90ad64..0000000
--- a/zgetrf.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgetrf_(integer *m, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_zgetrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zgetrf( m, a)\n or\n NumRu::Lapack.zgetrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGETRF computes an LU factorization of a general M-by-N matrix A\n* using partial pivoting with row interchanges.\n*\n* The factorization has the form\n* A = P * L * U\n* where P is a permutation matrix, L is lower triangular with unit\n* diagonal elements (lower trapezoidal if m > n), and U is upper\n* triangular (upper trapezoidal if m < n).\n*\n* This is the right-looking Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix to be factored.\n* On exit, the factors L and U from the factorization\n* A = P*L*U; the unit diagonal elements of L are not stored.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* IPIV (output) INTEGER array, dimension (min(M,N))\n* The pivot indices; for 1 <= i <= min(M,N), row i of the\n* matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgetrf_(&m, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_zgetrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgetrf", rb_zgetrf, -1);
-}
diff --git a/zgetri.c b/zgetri.c
deleted file mode 100644
index d8689b3..0000000
--- a/zgetri.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgetri_(integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgetri(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zgetri( a, ipiv, lwork)\n or\n NumRu::Lapack.zgetri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGETRI computes the inverse of a matrix using the LU factorization\n* computed by ZGETRF.\n*\n* This method inverts U and then computes inv(A) by solving the system\n* inv(A)*L = inv(U) for inv(A).\n*\n\n* Arguments\n* =========\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 factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n* On exit, if INFO = 0, the inverse of the original matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,N).\n* For optimal performance LWORK >= N*NB, where NB is\n* the optimal blocksize returned by ILAENV.\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* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is\n* singular and its inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_ipiv = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zgetri_(&n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zgetri(VALUE mLapack){
- rb_define_module_function(mLapack, "zgetri", rb_zgetri, -1);
-}
diff --git a/zgetrs.c b/zgetrs.c
deleted file mode 100644
index 58f3339..0000000
--- a/zgetrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgetrs_(char *trans, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zgetrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zgetrs( trans, a, ipiv, b)\n or\n NumRu::Lapack.zgetrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGETRS solves a system of linear equations\n* A * X = B, A**T * X = B, or A**H * X = B\n* with a general N-by-N matrix A using the LU factorization computed\n* by ZGETRF.\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)\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The factors L and U from the factorization A = P*L*U\n* as computed by ZGETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n* matrix was interchanged with row IPIV(i).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zgetrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zgetrs", rb_zgetrs, -1);
-}
diff --git a/zggbak.c b/zggbak.c
deleted file mode 100644
index 3c62730..0000000
--- a/zggbak.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggbak_(char *job, char *side, integer *n, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, integer *m, doublecomplex *v, integer *ldv, integer *info);
-
-static VALUE
-rb_zggbak(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_side;
- char side;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- doublereal *lscale;
- VALUE rb_rscale;
- doublereal *rscale;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- doublecomplex *v_out__;
-
- integer n;
- integer ldv;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.zggbak( job, side, ilo, ihi, lscale, rscale, v)\n or\n NumRu::Lapack.zggbak # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n* Purpose\n* =======\n*\n* ZGGBAK forms the right or left eigenvectors of a complex generalized\n* eigenvalue problem A*x = lambda*B*x, by backward transformation on\n* the computed eigenvectors of the balanced pair of matrices output by\n* ZGGBAL.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the type of backward transformation required:\n* = 'N': do nothing, return immediately;\n* = 'P': do backward transformation for permutation only;\n* = 'S': do backward transformation for scaling only;\n* = 'B': do backward transformations for both permutation and\n* scaling.\n* JOB must be the same as the argument JOB supplied to ZGGBAL.\n*\n* SIDE (input) CHARACTER*1\n* = 'R': V contains right eigenvectors;\n* = 'L': V contains left eigenvectors.\n*\n* N (input) INTEGER\n* The number of rows of the matrix V. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* The integers ILO and IHI determined by ZGGBAL.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* LSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the left side of A and B, as returned by ZGGBAL.\n*\n* RSCALE (input) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and/or scaling factors applied\n* to the right side of A and B, as returned by ZGGBAL.\n*\n* M (input) INTEGER\n* The number of columns of the matrix V. M >= 0.\n*\n* V (input/output) COMPLEX*16 array, dimension (LDV,M)\n* On entry, the matrix of right or left eigenvectors to be\n* transformed, as returned by ZTGEVC.\n* On exit, V is overwritten by the transformed eigenvectors.\n*\n* LDV (input) INTEGER\n* The leading dimension of the matrix V. LDV >= max(1,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* Further Details\n* ===============\n*\n* See R.C. Ward, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZDSCAL, ZSWAP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_side = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_lscale = argv[4];
- rb_rscale = argv[5];
- rb_v = argv[6];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- m = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_rscale))
- rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
- if (NA_RANK(rb_rscale) != 1)
- rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_rscale);
- if (NA_TYPE(rb_rscale) != NA_DFLOAT)
- rb_rscale = na_change_type(rb_rscale, NA_DFLOAT);
- rscale = NA_PTR_TYPE(rb_rscale, doublereal*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_lscale))
- rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
- if (NA_RANK(rb_lscale) != 1)
- rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lscale) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of lscale must be the same as shape 0 of rscale");
- if (NA_TYPE(rb_lscale) != NA_DFLOAT)
- rb_lscale = na_change_type(rb_lscale, NA_DFLOAT);
- lscale = NA_PTR_TYPE(rb_lscale, doublereal*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = m;
- rb_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublecomplex*);
- MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- zggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_zggbak(VALUE mLapack){
- rb_define_module_function(mLapack, "zggbak", rb_zggbak, -1);
-}
diff --git a/zggbal.c b/zggbal.c
deleted file mode 100644
index ae240bf..0000000
--- a/zggbal.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggbal_(char *job, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal *work, integer *info);
-
-static VALUE
-rb_zggbal(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- doublereal *lscale;
- VALUE rb_rscale;
- doublereal *rscale;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.zggbal( job, a, b)\n or\n NumRu::Lapack.zggbal # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGBAL balances a pair of general complex matrices (A,B). This\n* involves, first, permuting A and B by similarity transformations to\n* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n* elements on the diagonal; and second, applying a diagonal similarity\n* transformation to rows and columns ILO to IHI to make the rows\n* and columns as close in norm as possible. Both steps are optional.\n*\n* Balancing may reduce the 1-norm of the matrices, and improve the\n* accuracy of the computed eigenvalues and/or eigenvectors in the\n* generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies the operations to be performed on A and B:\n* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n* and RSCALE(I) = 1.0 for i=1,...,N;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the input matrix A.\n* On exit, A is overwritten by the balanced matrix.\n* If JOB = 'N', A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the input matrix B.\n* On exit, B is overwritten by the balanced matrix.\n* If JOB = 'N', B is not referenced.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are set to integers such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If P(j) is the index of the\n* row interchanged with row j, and D(j) is the scaling factor\n* applied to row j, then\n* LSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If P(j) is the index of the\n* column interchanged with column j, and D(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = P(j) for J = 1,...,ILO-1\n* = D(j) for J = ILO,...,IHI\n* = P(j) for J = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* WORK (workspace) REAL array, dimension (lwork)\n* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n* at least 1 when JOB = 'N' or 'P'.\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* See R.C. WARD, Balancing the generalized eigenvalue problem,\n* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_job = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- job = StringValueCStr(rb_job)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublereal, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));
-
- zggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);
-
- free(work);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggbal(VALUE mLapack){
- rb_define_module_function(mLapack, "zggbal", rb_zggbal, -1);
-}
diff --git a/zgges.c b/zgges.c
deleted file mode 100644
index 4155a9e..0000000
--- a/zgges.c
+++ /dev/null
@@ -1,167 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(doublecomplex *arg0, doublecomplex *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
- rb_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID zgges_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *sdim, doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl, integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info);
-
-static VALUE
-rb_zgges(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_vsl;
- doublecomplex *vsl;
- VALUE rb_vsr;
- doublecomplex *vsr;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgges( jobvsl, jobvsr, sort, a, b, lwork){|a,b| ... }\n or\n NumRu::Lapack.zgges # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGES computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the generalized complex Schur\n* form (S, T), and optionally left and/or right Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T. The leading\n* columns of VSL and VSR then form an unitary basis for the\n* corresponding left and right eigenspaces (deflating subspaces).\n*\n* (If only the generalized eigenvalues are needed, use the driver\n* ZGGEV instead, which is faster.)\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0, and even for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if S\n* and T are upper triangular and, in addition, the diagonal elements\n* of T are non-negative real numbers.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* An eigenvalue ALPHA(j)/BETA(j) is selected if\n* SELCTG(ALPHA(j),BETA(j)) is true.\n*\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+2 (See INFO below).\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),\n* j=1,...,N are the diagonals of the complex Schur form (A,B)\n* output by ZGGES. The BETA(j) will be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >= 1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in ZHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering falied in ZTGSEN.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (8*n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- zgges_(&jobvsl, &jobvsr, &sort, rb_selctg, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_sdim, rb_alpha, rb_beta, rb_vsl, rb_vsr, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zgges(VALUE mLapack){
- rb_define_module_function(mLapack, "zgges", rb_zgges, -1);
-}
diff --git a/zggesx.c b/zggesx.c
deleted file mode 100644
index b6b743c..0000000
--- a/zggesx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-static logical
-rb_selctg(doublecomplex *arg0, doublecomplex *arg1){
- VALUE rb_arg0, rb_arg1;
-
- VALUE rb_ret;
- logical ret;
-
- rb_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
- rb_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));
-
- rb_ret = rb_yield_values(2, rb_arg0, rb_arg1);
-
- ret = (rb_ret == Qtrue);
- return ret;
-}
-
-extern VOID zggesx_(char *jobvsl, char *jobvsr, char *sort, L_fp *selctg, char *sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *sdim, doublecomplex *alpha, doublecomplex *beta, doublecomplex *vsl, integer *ldvsl, doublecomplex *vsr, integer *ldvsr, doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, integer *iwork, integer *liwork, logical *bwork, integer *info);
-
-static VALUE
-rb_zggesx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvsl;
- char jobvsl;
- VALUE rb_jobvsr;
- char jobvsr;
- VALUE rb_sort;
- char sort;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_sdim;
- integer sdim;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_vsl;
- doublecomplex *vsl;
- VALUE rb_vsr;
- doublecomplex *vsr;
- VALUE rb_rconde;
- doublereal *rconde;
- VALUE rb_rcondv;
- doublereal *rcondv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvsl;
- integer ldvsr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.zggesx( jobvsl, jobvsr, sort, sense, a, b, lwork, liwork){|a,b| ... }\n or\n NumRu::Lapack.zggesx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n* and, optionally, the left and/or right matrices of Schur vectors (VSL\n* and VSR). This gives the generalized Schur factorization\n*\n* (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n*\n* where (VSR)**H is the conjugate-transpose of VSR.\n*\n* Optionally, it also orders the eigenvalues so that a selected cluster\n* of eigenvalues appears in the leading diagonal blocks of the upper\n* triangular matrix S and the upper triangular matrix T; computes\n* a reciprocal condition number for the average of the selected\n* eigenvalues (RCONDE); and computes a reciprocal condition number for\n* the right and left deflating subspaces corresponding to the selected\n* eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n* an orthonormal basis for the corresponding left and right eigenspaces\n* (deflating subspaces).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n* or a ratio alpha/beta = w, such that A - w*B is singular. It is\n* usually represented as the pair (alpha,beta), as there is a\n* reasonable interpretation for beta=0 or for both being zero.\n*\n* A pair of matrices (S,T) is in generalized complex Schur form if T is\n* upper triangular with non-negative diagonal and S is upper\n* triangular.\n*\n\n* Arguments\n* =========\n*\n* JOBVSL (input) CHARACTER*1\n* = 'N': do not compute the left Schur vectors;\n* = 'V': compute the left Schur vectors.\n*\n* JOBVSR (input) CHARACTER*1\n* = 'N': do not compute the right Schur vectors;\n* = 'V': compute the right Schur vectors.\n*\n* SORT (input) CHARACTER*1\n* Specifies whether or not to order the eigenvalues on the\n* diagonal of the generalized Schur form.\n* = 'N': Eigenvalues are not ordered;\n* = 'S': Eigenvalues are ordered (see SELCTG).\n*\n* SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n* SELCTG must be declared EXTERNAL in the calling subroutine.\n* If SORT = 'N', SELCTG is not referenced.\n* If SORT = 'S', SELCTG is used to select eigenvalues to sort\n* to the top left of the Schur form.\n* Note that a selected complex eigenvalue may no longer satisfy\n* SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n* ordering may change the value of complex eigenvalues\n* (especially if the eigenvalue is ill-conditioned), in this\n* case INFO is set to N+3 see INFO below).\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N' : None are computed;\n* = 'E' : Computed for average of selected eigenvalues only;\n* = 'V' : Computed for selected deflating subspaces only;\n* = 'B' : Computed for both.\n* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VSL, and VSR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the first of the pair of matrices.\n* On exit, A has been overwritten by its generalized Schur\n* form S.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the second of the pair of matrices.\n* On exit, B has been overwritten by its generalized Schur\n* form T.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* SDIM (output) INTEGER\n* If SORT = 'N', SDIM = 0.\n* If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n* for which SELCTG is true.\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are\n* the diagonals of the complex Schur form (S,T). BETA(j) will\n* be non-negative real.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n* If JOBVSL = 'V', VSL will contain the left Schur vectors.\n* Not referenced if JOBVSL = 'N'.\n*\n* LDVSL (input) INTEGER\n* The leading dimension of the matrix VSL. LDVSL >=1, and\n* if JOBVSL = 'V', LDVSL >= N.\n*\n* VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n* If JOBVSR = 'V', VSR will contain the right Schur vectors.\n* Not referenced if JOBVSR = 'N'.\n*\n* LDVSR (input) INTEGER\n* The leading dimension of the matrix VSR. LDVSR >= 1, and\n* if JOBVSR = 'V', LDVSR >= N.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n* reciprocal condition numbers for the average of the selected\n* eigenvalues.\n* Not referenced if SENSE = 'N' or 'V'.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )\n* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n* reciprocal condition number for the selected deflating\n* subspaces.\n* Not referenced if SENSE = 'N' or 'E'.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n* LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n* LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.\n* Note also that an error is only returned if\n* LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n* not be large enough.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the bound on the optimal size of the WORK\n* array and the minimum size of the IWORK array, returns these\n* values as the first entries of the WORK and IWORK arrays, and\n* no error message related to LWORK or LIWORK is issued by\n* XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N )\n* Real workspace.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n* LIWORK >= N+2.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the bound on the optimal size of the\n* WORK array and the minimum size of the IWORK array, returns\n* these values as the first entries of the WORK and IWORK\n* arrays, and no error message related to LWORK or LIWORK is\n* issued by XERBLA.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* Not referenced if SORT = 'N'.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. (A,B) are not in Schur\n* form, but ALPHA(j) and BETA(j) should be correct for\n* j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in ZHGEQZ\n* =N+2: after reordering, roundoff changed values of\n* some complex eigenvalues so that leading\n* eigenvalues in the Generalized Schur form no\n* longer satisfy SELCTG=.TRUE. This could also\n* be caused due to scaling.\n* =N+3: reordering failed in ZTGSEN.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_jobvsl = argv[0];
- rb_jobvsr = argv[1];
- rb_sort = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
- rb_liwork = argv[7];
-
- jobvsl = StringValueCStr(rb_jobvsl)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- liwork = NUM2INT(rb_liwork);
- sense = StringValueCStr(rb_sense)[0];
- sort = StringValueCStr(rb_sort)[0];
- lwork = NUM2INT(rb_lwork);
- jobvsr = StringValueCStr(rb_jobvsr)[0];
- ldvsr = lsame_(&jobvsr,"V") ? n : 1;
- ldvsl = lsame_(&jobvsl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvsl;
- shape[1] = n;
- rb_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vsl = NA_PTR_TYPE(rb_vsl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvsr;
- shape[1] = n;
- rb_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vsr = NA_PTR_TYPE(rb_vsr, doublecomplex*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (8*n));
- bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));
-
- zggesx_(&jobvsl, &jobvsr, &sort, rb_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, rwork, iwork, &liwork, bwork, &info);
-
- free(rwork);
- free(bwork);
- rb_sdim = INT2NUM(sdim);
- rb_info = INT2NUM(info);
- return rb_ary_new3(12, rb_sdim, rb_alpha, rb_beta, rb_vsl, rb_vsr, rb_rconde, rb_rcondv, rb_work, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggesx(VALUE mLapack){
- rb_define_module_function(mLapack, "zggesx", rb_zggesx, -1);
-}
diff --git a/zggev.c b/zggev.c
deleted file mode 100644
index f999985..0000000
--- a/zggev.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggev_(char *jobvl, char *jobvr, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zggev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zggev( jobvl, jobvr, a, b, lwork)\n or\n NumRu::Lapack.zggev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B), the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right generalized eigenvector v(j) corresponding to the\n* generalized eigenvalue lambda(j) of (A,B) satisfies\n*\n* A * v(j) = lambda(j) * B * v(j).\n*\n* The left generalized eigenvector u(j) corresponding to the\n* generalized eigenvalues lambda(j) of (A,B) satisfies\n*\n* u(j)**H * A = lambda(j) * u(j)**H * B\n*\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n\n* Arguments\n* =========\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n* generalized eigenvalues.\n*\n* Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio alpha/beta.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector is scaled so the largest component has\n* abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* For good performance, LWORK must generally be larger.\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* RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* =1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be\n* correct for j=INFO+1,...,N.\n* > N: =N+1: other then QZ iteration failed in DHGEQZ,\n* =N+2: error return from DTGEVC.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobvl = argv[0];
- rb_jobvr = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = 8*n;
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_vl, rb_vr, rb_work, rb_rwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggev(VALUE mLapack){
- rb_define_module_function(mLapack, "zggev", rb_zggev, -1);
-}
diff --git a/zggevx.c b/zggevx.c
deleted file mode 100644
index 3d82aea..0000000
--- a/zggevx.c
+++ /dev/null
@@ -1,201 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggevx_(char *balanc, char *jobvl, char *jobvr, char *sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *beta, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *ilo, integer *ihi, doublereal *lscale, doublereal *rscale, doublereal *abnrm, doublereal *bbnrm, doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, doublereal *rwork, integer *iwork, logical *bwork, integer *info);
-
-static VALUE
-rb_zggevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_balanc;
- char balanc;
- VALUE rb_jobvl;
- char jobvl;
- VALUE rb_jobvr;
- char jobvr;
- VALUE rb_sense;
- char sense;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_lscale;
- doublereal *lscale;
- VALUE rb_rscale;
- doublereal *rscale;
- VALUE rb_abnrm;
- doublereal abnrm;
- VALUE rb_bbnrm;
- doublereal bbnrm;
- VALUE rb_rconde;
- doublereal *rconde;
- VALUE rb_rcondv;
- doublereal *rcondv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
- integer *iwork;
- logical *bwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldvl;
- integer ldvr;
- integer lrwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.zggevx( balanc, jobvl, jobvr, sense, a, b, lwork)\n or\n NumRu::Lapack.zggevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n* (A,B) the generalized eigenvalues, and optionally, the left and/or\n* right generalized eigenvectors.\n*\n* Optionally, it also computes a balancing transformation to improve\n* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n* the eigenvalues (RCONDE), and reciprocal condition numbers for the\n* right eigenvectors (RCONDV).\n*\n* A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n* singular. It is usually represented as the pair (alpha,beta), as\n* there is a reasonable interpretation for beta=0, and even for both\n* being zero.\n*\n* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* A * v(j) = lambda(j) * B * v(j) .\n* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n* of (A,B) satisfies\n* u(j)**H * A = lambda(j) * u(j)**H * B.\n* where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n* Arguments\n* =========\n*\n* BALANC (input) CHARACTER*1\n* Specifies the balance option to be performed:\n* = 'N': do not diagonally scale or permute;\n* = 'P': permute only;\n* = 'S': scale only;\n* = 'B': both permute and scale.\n* Computed reciprocal condition numbers will be for the\n* matrices after permuting and/or balancing. Permuting does\n* not change condition numbers (in exact arithmetic), but\n* balancing does.\n*\n* JOBVL (input) CHARACTER*1\n* = 'N': do not compute the left generalized eigenvectors;\n* = 'V': compute the left generalized eigenvectors.\n*\n* JOBVR (input) CHARACTER*1\n* = 'N': do not compute the right generalized eigenvectors;\n* = 'V': compute the right generalized eigenvectors.\n*\n* SENSE (input) CHARACTER*1\n* Determines which reciprocal condition numbers are computed.\n* = 'N': none are computed;\n* = 'E': computed for eigenvalues only;\n* = 'V': computed for eigenvectors only;\n* = 'B': computed for eigenvalues and eigenvectors.\n*\n* N (input) INTEGER\n* The order of the matrices A, B, VL, and VR. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the matrix A in the pair (A,B).\n* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then A contains the first part of the complex Schur\n* form of the \"balanced\" versions of the input A and B.\n*\n* LDA (input) INTEGER\n* The leading dimension of A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the matrix B in the pair (A,B).\n* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n* or both, then B contains the second part of the complex\n* Schur form of the \"balanced\" versions of the input A and B.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n* eigenvalues.\n*\n* Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n* underflow, and BETA(j) may even be zero. Thus, the user\n* should avoid naively computing the ratio ALPHA/BETA.\n* However, ALPHA will be always less than and usually\n* comparable with norm(A) in magnitude, and BETA always less\n* than and usually comparable with norm(B).\n*\n* VL (output) COMPLEX*16 array, dimension (LDVL,N)\n* If JOBVL = 'V', the left generalized eigenvectors u(j) are\n* stored one after another in the columns of VL, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVL = 'N'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the matrix VL. LDVL >= 1, and\n* if JOBVL = 'V', LDVL >= N.\n*\n* VR (output) COMPLEX*16 array, dimension (LDVR,N)\n* If JOBVR = 'V', the right generalized eigenvectors v(j) are\n* stored one after another in the columns of VR, in the same\n* order as their eigenvalues.\n* Each eigenvector will be scaled so the largest component\n* will have abs(real part) + abs(imag. part) = 1.\n* Not referenced if JOBVR = 'N'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the matrix VR. LDVR >= 1, and\n* if JOBVR = 'V', LDVR >= N.\n*\n* ILO (output) INTEGER\n* IHI (output) INTEGER\n* ILO and IHI are integer values such that on exit\n* A(i,j) = 0 and B(i,j) = 0 if i > j and\n* j = 1,...,ILO-1 or i = IHI+1,...,N.\n* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n* LSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the left side of A and B. If PL(j) is the index of the\n* row interchanged with row j, and DL(j) is the scaling\n* factor applied to row j, then\n* LSCALE(j) = PL(j) for j = 1,...,ILO-1\n* = DL(j) for j = ILO,...,IHI\n* = PL(j) for j = IHI+1,...,N.\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* RSCALE (output) DOUBLE PRECISION array, dimension (N)\n* Details of the permutations and scaling factors applied\n* to the right side of A and B. If PR(j) is the index of the\n* column interchanged with column j, and DR(j) is the scaling\n* factor applied to column j, then\n* RSCALE(j) = PR(j) for j = 1,...,ILO-1\n* = DR(j) for j = ILO,...,IHI\n* = PR(j) for j = IHI+1,...,N\n* The order in which the interchanges are made is N to IHI+1,\n* then 1 to ILO-1.\n*\n* ABNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix A.\n*\n* BBNRM (output) DOUBLE PRECISION\n* The one-norm of the balanced matrix B.\n*\n* RCONDE (output) DOUBLE PRECISION array, dimension (N)\n* If SENSE = 'E' or 'B', the reciprocal condition numbers of\n* the eigenvalues, stored in consecutive elements of the array.\n* If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n* RCONDV (output) DOUBLE PRECISION array, dimension (N)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the eigenvectors, stored in consecutive elements\n* of the array. If the eigenvalues cannot be reordered to\n* compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n* when the true value would be very small anyway.\n* If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,2*N).\n* If SENSE = 'E', LWORK >= max(1,4*N).\n* If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*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* RWORK (workspace) REAL array, dimension (lrwork)\n* lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n* and at least max(1,2*N) otherwise.\n* Real workspace.\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If SENSE = 'E', IWORK is not referenced.\n*\n* BWORK (workspace) LOGICAL array, dimension (N)\n* If SENSE = 'N', BWORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1,...,N:\n* The QZ iteration failed. No eigenvectors have been\n* calculated, but ALPHA(j) and BETA(j) should be correct\n* for j=INFO+1,...,N.\n* > N: =N+1: other than QZ iteration failed in ZHGEQZ.\n* =N+2: error return from ZTGEVC.\n*\n\n* Further Details\n* ===============\n*\n* Balancing a matrix pair (A,B) includes, first, permuting rows and\n* columns to isolate eigenvalues, second, applying diagonal similarity\n* transformation to the rows and columns to make the rows and columns\n* as close in norm as possible. The computed reciprocal condition\n* numbers correspond to the balanced matrix. Permuting rows and columns\n* will not change the condition numbers (in exact arithmetic) but\n* diagonal scaling will. For further explanation of balancing, see\n* section 4.11.1.2 of LAPACK Users' Guide.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n* An approximate error bound for the angle between the i-th computed\n* eigenvector VL(i) or VR(i) is given by\n*\n* EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n* For further explanation of the reciprocal condition numbers RCONDE\n* and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_balanc = argv[0];
- rb_jobvl = argv[1];
- rb_jobvr = argv[2];
- rb_sense = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- jobvr = StringValueCStr(rb_jobvr)[0];
- balanc = StringValueCStr(rb_balanc)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- jobvl = StringValueCStr(rb_jobvl)[0];
- lwork = NUM2INT(rb_lwork);
- sense = StringValueCStr(rb_sense)[0];
- lrwork = ((lsame_(&balanc,"S")) || (lsame_(&balanc,"B"))) ? MAX(1,6*n) : MAX(1,2*n);
- ldvl = lsame_(&jobvl,"V") ? n : 1;
- ldvr = lsame_(&jobvr,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = n;
- rb_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = n;
- rb_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- lscale = NA_PTR_TYPE(rb_lscale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rscale = NA_PTR_TYPE(rb_rscale, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rconde = NA_PTR_TYPE(rb_rconde, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rcondv = NA_PTR_TYPE(rb_rcondv, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (lrwork));
- iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+2));
- bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));
-
- zggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, rwork, iwork, bwork, &info);
-
- free(rwork);
- free(iwork);
- free(bwork);
- rb_ilo = INT2NUM(ilo);
- rb_ihi = INT2NUM(ihi);
- rb_abnrm = rb_float_new((double)abnrm);
- rb_bbnrm = rb_float_new((double)bbnrm);
- rb_info = INT2NUM(info);
- return rb_ary_new3(16, rb_alpha, rb_beta, rb_vl, rb_vr, rb_ilo, rb_ihi, rb_lscale, rb_rscale, rb_abnrm, rb_bbnrm, rb_rconde, rb_rcondv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggevx(VALUE mLapack){
- rb_define_module_function(mLapack, "zggevx", rb_zggevx, -1);
-}
diff --git a/zggglm.c b/zggglm.c
deleted file mode 100644
index c9dc36d..0000000
--- a/zggglm.c
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggglm_(integer *n, integer *m, integer *p, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *d, doublecomplex *x, doublecomplex *y, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zggglm(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_d_out__;
- doublecomplex *d_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, work, info, a, b, d = NumRu::Lapack.zggglm( a, b, d, lwork)\n or\n NumRu::Lapack.zggglm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n* minimize || y ||_2 subject to d = A*x + B*y\n* x\n*\n* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n* given N-vector. It is assumed that M <= N <= M+P, and\n*\n* rank(A) = M and rank( A B ) = N.\n*\n* Under these assumptions, the constrained equation is always\n* consistent, and there is a unique solution x and a minimal 2-norm\n* solution y, which is obtained using a generalized QR factorization\n* of the matrices (A, B) given by\n*\n* A = Q*(R), B = Q*T*Z.\n* (0)\n*\n* In particular, if matrix B is square nonsingular, then the problem\n* GLM is equivalent to the following weighted linear least squares\n* problem\n*\n* minimize || inv(B)*(d-A*x) ||_2\n* x\n*\n* where inv(B) denotes the inverse of B.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. 0 <= M <= N.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= N-M.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the upper triangular part of the array A contains\n* the M-by-M upper triangular matrix R.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* D (input/output) COMPLEX*16 array, dimension (N)\n* On entry, D is the left hand side of the GLM equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX*16 array, dimension (M)\n* Y (output) COMPLEX*16 array, dimension (P)\n* On exit, X and Y are the solutions of the GLM problem.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N+M+P).\n* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ.\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* = 1: the upper triangular factor R associated with A in the\n* generalized QR factorization of the pair (A, B) is\n* singular, so that rank(A) < M; the least squares\n* solution could not be computed.\n* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n* factor T associated with B in the generalized QR\n* factorization of the pair (A, B) is singular, so that\n* rank( A B ) < N; the least squares solution could not\n* be computed.\n*\n\n* ===================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_d = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = m;
- rb_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = p;
- rb_y = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublecomplex*);
- MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- zggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_y, rb_work, rb_info, rb_a, rb_b, rb_d);
-}
-
-void
-init_lapack_zggglm(VALUE mLapack){
- rb_define_module_function(mLapack, "zggglm", rb_zggglm, -1);
-}
diff --git a/zgghrd.c b/zgghrd.c
deleted file mode 100644
index a564697..0000000
--- a/zgghrd.c
+++ /dev/null
@@ -1,148 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgghrd_(char *compq, char *compz, integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z, integer *ldz, integer *info);
-
-static VALUE
-rb_zgghrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.zgghrd( compq, compz, ilo, ihi, a, b, q, z)\n or\n NumRu::Lapack.zgghrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n* Hessenberg form using unitary transformations, where A is a\n* general matrix and B is upper triangular. The form of the\n* generalized eigenvalue problem is\n* A*x = lambda*B*x,\n* and B is typically made upper triangular by computing its QR\n* factorization and moving the unitary matrix Q to the left side\n* of the equation.\n*\n* This subroutine simultaneously reduces A to a Hessenberg matrix H:\n* Q**H*A*Z = H\n* and transforms B to another upper triangular matrix T:\n* Q**H*B*Z = T\n* in order to reduce the problem to its standard form\n* H*y = lambda*T*y\n* where y = Z**H*x.\n*\n* The unitary matrices Q and Z are determined as products of Givens\n* rotations. They may either be formed explicitly, or they may be\n* postmultiplied into input matrices Q1 and Z1, so that\n* Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n* Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n* If Q1 is the unitary matrix from the QR factorization of B in the\n* original equation A*x = lambda*B*x, then ZGGHRD reduces the original\n* problem to generalized Hessenberg form.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': do not compute Q;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry,\n* and the product Q1*Q is returned.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of A which are to be\n* reduced. It is assumed that A is already upper triangular\n* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n* normally set by a previous call to ZGGBAL; otherwise they\n* should be set to 1 and N respectively.\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the N-by-N general matrix to be reduced.\n* On exit, the upper triangle and the first subdiagonal of A\n* are overwritten with the upper Hessenberg matrix H, and the\n* rest is set to zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the N-by-N upper triangular matrix B.\n* On exit, the upper triangular matrix T = Q**H B Z. The\n* elements below the diagonal are set to zero.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ, N)\n* On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n* from the QR factorization of B.\n* On exit, if COMPQ='I', the unitary matrix Q, and if\n* COMPQ = 'V', the product Q1*Q.\n* Not referenced if COMPQ='N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1.\n* On exit, if COMPZ='I', the unitary matrix Z, and if\n* COMPZ = 'V', the product Z1*Z.\n* Not referenced if COMPZ='N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z.\n* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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* This routine reduces A to Hessenberg and B to triangular form by\n* an unblocked reduction, as described in _Matrix_Computations_,\n* by Golub and van Loan (Johns Hopkins Press).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_compq = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ilo = NUM2INT(rb_ilo);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- compq = StringValueCStr(rb_compq)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- zgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_zgghrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zgghrd", rb_zgghrd, -1);
-}
diff --git a/zgglse.c b/zgglse.c
deleted file mode 100644
index f2de1e7..0000000
--- a/zgglse.c
+++ /dev/null
@@ -1,146 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgglse_(integer *m, integer *n, integer *p, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *c, doublecomplex *d, doublecomplex *x, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zgglse(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- VALUE rb_d_out__;
- doublecomplex *d_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer m;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, work, info, a, b, c, d = NumRu::Lapack.zgglse( a, b, c, d, lwork)\n or\n NumRu::Lapack.zgglse # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGLSE solves the linear equality-constrained least squares (LSE)\n* problem:\n*\n* minimize || c - A*x ||_2 subject to B*x = d\n*\n* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n* M-vector, and d is a given P-vector. It is assumed that\n* P <= N <= M+P, and\n*\n* rank(B) = P and rank( ( A ) ) = N.\n* ( ( B ) )\n*\n* These conditions ensure that the LSE problem has a unique solution,\n* which is obtained using a generalized RQ factorization of the\n* matrices (B, A) given by\n*\n* B = (0 R)*Q, A = Z*T*Q.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n* contains the P-by-P upper triangular matrix R.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* C (input/output) COMPLEX*16 array, dimension (M)\n* On entry, C contains the right hand side vector for the\n* least squares part of the LSE problem.\n* On exit, the residual sum of squares for the solution\n* is given by the sum of squares of elements N-P+1 to M of\n* vector C.\n*\n* D (input/output) COMPLEX*16 array, dimension (P)\n* On entry, D contains the right hand side vector for the\n* constrained equation.\n* On exit, D is destroyed.\n*\n* X (output) COMPLEX*16 array, dimension (N)\n* On exit, X is the solution of the LSE problem.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M+N+P).\n* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n* where NB is an upper bound for the optimal blocksizes for\n* ZGEQRF, CGERQF, ZUNMQR and CUNMRQ.\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* = 1: the upper triangular factor R associated with B in the\n* generalized RQ factorization of the pair (B, A) is\n* singular, so that rank(B) < P; the least squares\n* solution could not be computed.\n* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n* T associated with A in the generalized RQ factorization\n* of the pair (B, A) is singular, so that\n* rank( (A) ) < N; the least squares solution could not\n* ( (B) )\n* be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
- rb_d = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- p = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = n;
- rb_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[1];
- shape[0] = p;
- rb_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublecomplex*);
- MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
-
- zgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_work, rb_info, rb_a, rb_b, rb_c, rb_d);
-}
-
-void
-init_lapack_zgglse(VALUE mLapack){
- rb_define_module_function(mLapack, "zgglse", rb_zgglse, -1);
-}
diff --git a/zggqrf.c b/zggqrf.c
deleted file mode 100644
index 135abf8..0000000
--- a/zggqrf.c
+++ /dev/null
@@ -1,112 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggqrf_(integer *n, integer *m, integer *p, doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b, integer *ldb, doublecomplex *taub, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zggqrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- doublecomplex *taua;
- VALUE rb_taub;
- doublecomplex *taub;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.zggqrf( n, a, b, lwork)\n or\n NumRu::Lapack.zggqrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGQRF computes a generalized QR factorization of an N-by-M matrix A\n* and an N-by-P matrix B:\n*\n* A = Q*R, B = Q*T*Z,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n* and R and T assume one of the forms:\n*\n* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n* ( 0 ) N-M N M-N\n* M\n*\n* where R11 is upper triangular, and\n*\n* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n* P-N N ( T21 ) P\n* P\n*\n* where T12 or T21 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GQR factorization\n* of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n* inv(B)*A = Z'*(inv(T)*R)\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of matrix Z.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of rows of the matrices A and B. N >= 0.\n*\n* M (input) INTEGER\n* The number of columns of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of columns of the matrix B. P >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,M)\n* On entry, the N-by-M matrix A.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n* upper triangular if N >= M); the elements below the diagonal,\n* with the array TAUA, represent the unitary matrix Q as a\n* product of min(N,M) elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAUA (output) COMPLEX*16 array, dimension (min(N,M))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,P)\n* On entry, the N-by-P matrix B.\n* On exit, if N <= P, the upper triangle of the subarray\n* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n* if N > P, the elements on and above the (N-P)-th subdiagonal\n* contain the N-by-P upper trapezoidal matrix T; the remaining\n* elements, with the array TAUB, represent the unitary\n* matrix Z as a product of elementary reflectors (see Further\n* Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* TAUB (output) COMPLEX*16 array, dimension (min(N,P))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the QR factorization\n* of an N-by-M matrix, NB2 is the optimal blocksize for the\n* RQ factorization of an N-by-P matrix, and NB3 is the optimal\n* blocksize for a call of ZUNMQR.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(n,m).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine ZUNGQR.\n* To use Q to update another matrix, use LAPACK subroutine ZUNMQR.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine ZUNGRQ.\n* To use Z to update another matrix, use LAPACK subroutine ZUNMRQ.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMQR\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- p = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- n = NUM2INT(rb_n);
- lwork = NUM2INT(rb_lwork);
- {
- int shape[1];
- shape[0] = MIN(n,m);
- rb_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, doublecomplex*);
- {
- int shape[1];
- shape[0] = MIN(n,p);
- rb_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = m;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = p;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggqrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zggqrf", rb_zggqrf, -1);
-}
diff --git a/zggrqf.c b/zggrqf.c
deleted file mode 100644
index ec07e63..0000000
--- a/zggrqf.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggrqf_(integer *m, integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex *taua, doublecomplex *b, integer *ldb, doublecomplex *taub, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zggrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_p;
- integer p;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_taua;
- doublecomplex *taua;
- VALUE rb_taub;
- doublecomplex *taub;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n taua, taub, work, info, a, b = NumRu::Lapack.zggrqf( m, p, a, b, lwork)\n or\n NumRu::Lapack.zggrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n* and a P-by-N matrix B:\n*\n* A = R*Q, B = Z*T*Q,\n*\n* where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n* matrix, and R and T assume one of the forms:\n*\n* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n* N-M M ( R21 ) N\n* N\n*\n* where R12 or R21 is upper triangular, and\n*\n* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n* ( 0 ) P-N P N-P\n* N\n*\n* where T11 is upper triangular.\n*\n* In particular, if B is square and nonsingular, the GRQ factorization\n* of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n* A*inv(B) = (R*inv(T))*Z'\n*\n* where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n* conjugate transpose of the matrix Z.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, if M <= N, the upper triangle of the subarray\n* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n* if M > N, the elements on and above the (M-N)-th subdiagonal\n* contain the M-by-N upper trapezoidal matrix R; the remaining\n* elements, with the array TAUA, represent the unitary\n* matrix Q as a product of elementary reflectors (see Further\n* Details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAUA (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q (see Further Details).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, the elements on and above the diagonal of the array\n* contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n* upper triangular if P >= N); the elements below the diagonal,\n* with the array TAUB, represent the unitary matrix Z as a\n* product of elementary reflectors (see Further Details).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TAUB (output) COMPLEX*16 array, dimension (min(P,N))\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Z (see Further Details).\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N,M,P).\n* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n* where NB1 is the optimal blocksize for the RQ factorization\n* of an M-by-N matrix, NB2 is the optimal blocksize for the\n* QR factorization of a P-by-N matrix, and NB3 is the optimal\n* blocksize for a call of ZUNMRQ.\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 matrix Q is represented as a product of elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k), where k = min(m,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taua * v * v'\n*\n* where taua is a complex scalar, and v is a complex vector with\n* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n* To form Q explicitly, use LAPACK subroutine ZUNGRQ.\n* To use Q to update another matrix, use LAPACK subroutine ZUNMRQ.\n*\n* The matrix Z is represented as a product of elementary reflectors\n*\n* Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n* Each H(i) has the form\n*\n* H(i) = I - taub * v * v'\n*\n* where taub is a complex scalar, and v is a complex vector with\n* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n* and taub in TAUB(i).\n* To form Z explicitly, use LAPACK subroutine ZUNGQR.\n* To use Z to update another matrix, use LAPACK subroutine ZUNMQR.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMRQ\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_m = argv[0];
- rb_p = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- p = NUM2INT(rb_p);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taua = NA_PTR_TYPE(rb_taua, doublecomplex*);
- {
- int shape[1];
- shape[0] = MIN(p,n);
- rb_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taub = NA_PTR_TYPE(rb_taub, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_taua, rb_taub, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "zggrqf", rb_zggrqf, -1);
-}
diff --git a/zggsvd.c b/zggsvd.c
deleted file mode 100644
index e14fe8a..0000000
--- a/zggsvd.c
+++ /dev/null
@@ -1,171 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggsvd_(char *jobu, char *jobv, char *jobq, integer *m, integer *n, integer *p, integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *alpha, doublereal *beta, doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q, integer *ldq, doublecomplex *work, doublereal *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zggsvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_alpha;
- doublereal *alpha;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_u;
- doublecomplex *u;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.zggsvd( jobu, jobv, jobq, a, b)\n or\n NumRu::Lapack.zggsvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGSVD computes the generalized singular value decomposition (GSVD)\n* of an M-by-N complex matrix A and P-by-N complex matrix B:\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n*\n* where U, V and Q are unitary matrices, and Z' means the conjugate\n* transpose of Z. Let K+L = the effective numerical rank of the\n* matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n* triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n* matrices and of the following structures, respectively:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 )\n* L ( 0 0 R22 )\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The routine computes C, S, R, and optionally the unitary\n* transformation matrices U, V and Q.\n*\n* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n* A and B implicitly gives the SVD of A*inv(B):\n* A*inv(B) = U*(D1*inv(D2))*V'.\n* If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n* equal to the CS decomposition of A and B. Furthermore, the GSVD can\n* be used to derive the solution of the eigenvalue problem:\n* A'*A x = lambda* B'*B x.\n* In some literature, the GSVD of A and B is presented in the form\n* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n* where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n* ``diagonal''. The former GSVD form can be converted to the latter\n* form by taking the nonsingular matrix X as\n*\n* X = Q*( I 0 )\n* ( 0 inv(R) )\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose.\n* K + L = effective numerical rank of (A',B')'.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular matrix R, or part of R.\n* See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains part of the triangular matrix R if\n* M-K-L < 0. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = C,\n* BETA(K+1:K+L) = S,\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n* and\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0\n*\n* U (output) COMPLEX*16 array, dimension (LDU,M)\n* If JOBU = 'U', U contains the M-by-M unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX*16 array, dimension (LDV,P)\n* If JOBV = 'V', V contains the P-by-P unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)+N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* IWORK (workspace/output) INTEGER array, dimension (N)\n* On exit, IWORK stores the sorting information. More\n* precisely, the following loop will sort ALPHA\n* for I = K+1, min(M,K+L)\n* swap ALPHA(I) and ALPHA(IWORK(I))\n* endfor\n* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = 1, the Jacobi-type procedure failed to\n* converge. For further details, see subroutine ZTGSJA.\n*\n* Internal Parameters\n* ===================\n*\n* TOLA DOUBLE PRECISION\n* TOLB DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* rank of (A',B')'. Generally, they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n\n* Further Details\n* ===============\n*\n* 2-96 Based on modifications by\n* Ming Gu and Huan Ren, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n DOUBLE PRECISION DLAMCH, ZLANGE\n EXTERNAL LSAME, DLAMCH, ZLANGE\n* ..\n* .. External Subroutines ..\n EXTERNAL DCOPY, XERBLA, ZGGSVP, ZTGSJA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (m))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", m);
- m = lda;
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- lda = m;
- ldb = p;
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublecomplex, (MAX(3*n,m)*(p)+n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, rwork, iwork, &info);
-
- free(work);
- free(rwork);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_k, rb_l, rb_alpha, rb_beta, rb_u, rb_v, rb_q, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggsvd(VALUE mLapack){
- rb_define_module_function(mLapack, "zggsvd", rb_zggsvd, -1);
-}
diff --git a/zggsvp.c b/zggsvp.c
deleted file mode 100644
index 83520f3..0000000
--- a/zggsvp.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal *rwork, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zggsvp(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_tola;
- doublereal tola;
- VALUE rb_tolb;
- doublereal tolb;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_u;
- doublecomplex *u;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- integer *iwork;
- doublereal *rwork;
- doublecomplex *tau;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, l, u, v, q, info, a, b = NumRu::Lapack.zggsvp( jobu, jobv, jobq, a, b, tola, tolb)\n or\n NumRu::Lapack.zggsvp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGGSVP computes unitary matrices U, V and Q such that\n*\n* N-K-L K L\n* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* V'*B*Q = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n* conjugate transpose of Z.\n*\n* This decomposition is the preprocessing step for computing the\n* Generalized Singular Value Decomposition (GSVD), see subroutine\n* ZGGSVD.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': Unitary matrix U is computed;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': Unitary matrix V is computed;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Unitary matrix Q is computed;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A contains the triangular (or trapezoidal) matrix\n* described in the Purpose section.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, B contains the triangular matrix described in\n* the Purpose section.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the thresholds to determine the effective\n* numerical rank of matrix B and a subblock of A. Generally,\n* they are set to\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n* The size of TOLA and TOLB may affect the size of backward\n* errors of the decomposition.\n*\n* K (output) INTEGER\n* L (output) INTEGER\n* On exit, K and L specify the dimension of the subblocks\n* described in Purpose section.\n* K + L = effective numerical rank of (A',B')'.\n*\n* U (output) COMPLEX*16 array, dimension (LDU,M)\n* If JOBU = 'U', U contains the unitary matrix U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (output) COMPLEX*16 array, dimension (LDV,P)\n* If JOBV = 'V', V contains the unitary matrix V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,N)\n* If JOBQ = 'Q', Q contains the unitary matrix Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* TAU (workspace) COMPLEX*16 array, dimension (N)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine ZGEQPF for the QR factorization\n* with column pivoting to detect the effective numerical rank of the\n* a matrix. It may be replaced by a better rank determination strategy.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_tola = argv[5];
- rb_tolb = argv[6];
-
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- tolb = NUM2DBL(rb_tolb);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (ldb != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", p);
- p = ldb;
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- tola = NUM2DBL(rb_tola);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
- ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
- ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
- m = lda;
- ldb = p;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u = NA_PTR_TYPE(rb_u, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- iwork = ALLOC_N(integer, (n));
- rwork = ALLOC_N(doublereal, (2*n));
- tau = ALLOC_N(doublecomplex, (n));
- work = ALLOC_N(doublecomplex, (MAX(3*n,m)*(p)));
-
- zggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, rwork, tau, work, &info);
-
- free(iwork);
- free(rwork);
- free(tau);
- free(work);
- rb_k = INT2NUM(k);
- rb_l = INT2NUM(l);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_k, rb_l, rb_u, rb_v, rb_q, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zggsvp(VALUE mLapack){
- rb_define_module_function(mLapack, "zggsvp", rb_zggsvp, -1);
-}
diff --git a/zgtcon.c b/zgtcon.c
deleted file mode 100644
index 8b48d82..0000000
--- a/zgtcon.c
+++ /dev/null
@@ -1,102 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgtcon_(char *norm, integer *n, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zgtcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_du2;
- doublecomplex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zgtcon( norm, dl, d, du, du2, ipiv, anorm)\n or\n NumRu::Lapack.zgtcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGTCON estimates the reciprocal of the condition number of a complex\n* tridiagonal matrix A using the LU factorization as computed by\n* ZGTTRF.\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by ZGTTRF.\n*\n* D (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX*16 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) DOUBLE PRECISION\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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_anorm = argv[6];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_DCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- work = ALLOC_N(doublecomplex, (2*n));
-
- zgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zgtcon(VALUE mLapack){
- rb_define_module_function(mLapack, "zgtcon", rb_zgtcon, -1);
-}
diff --git a/zgtrfs.c b/zgtrfs.c
deleted file mode 100644
index a5d55a8..0000000
--- a/zgtrfs.c
+++ /dev/null
@@ -1,190 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgtrfs_(char *trans, integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *dlf, doublecomplex *df, doublecomplex *duf, doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgtrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_dlf;
- doublecomplex *dlf;
- VALUE rb_df;
- doublecomplex *df;
- VALUE rb_duf;
- doublecomplex *duf;
- VALUE rb_du2;
- doublecomplex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x)\n or\n NumRu::Lapack.zgtrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGTRFS 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)\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A as computed by ZGTTRF.\n*\n* DF (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZGTTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_dlf = argv[4];
- rb_df = argv[5];
- rb_duf = argv[6];
- rb_du2 = argv[7];
- rb_ipiv = argv[8];
- rb_b = argv[9];
- rb_x = argv[10];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (11th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (6th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_DCOMPLEX)
- rb_df = na_change_type(rb_df, NA_DCOMPLEX);
- df = NA_PTR_TYPE(rb_df, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_DCOMPLEX)
- rb_dlf = na_change_type(rb_dlf, NA_DCOMPLEX);
- dlf = NA_PTR_TYPE(rb_dlf, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_DCOMPLEX)
- rb_duf = na_change_type(rb_duf, NA_DCOMPLEX);
- duf = NA_PTR_TYPE(rb_duf, doublecomplex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_DCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zgtrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zgtrfs", rb_zgtrfs, -1);
-}
diff --git a/zgtsv.c b/zgtsv.c
deleted file mode 100644
index 0d5fb5f..0000000
--- a/zgtsv.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgtsv_(integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zgtsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- doublecomplex *dl_out__;
- VALUE rb_d_out__;
- doublecomplex *d_out__;
- VALUE rb_du_out__;
- doublecomplex *du_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, dl, d, du, b = NumRu::Lapack.zgtsv( dl, d, du, b)\n or\n NumRu::Lapack.zgtsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGTSV solves the equation\n*\n* A*X = B,\n*\n* where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n* partial pivoting.\n*\n* Note that the equation A'*X = B may be solved by interchanging the\n* order of the arguments DU and DL.\n*\n\n* Arguments\n* =========\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/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DL must contain the (n-1) subdiagonal elements of\n* A.\n* On exit, DL is overwritten by the (n-2) elements of the\n* second superdiagonal of the upper triangular matrix U from\n* the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n* D (input/output) COMPLEX*16 array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n* On exit, D is overwritten by the n diagonal elements of U.\n*\n* DU (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DU must contain the (n-1) superdiagonal elements\n* of A.\n* On exit, DU is overwritten by the (n-1) elements of the first\n* superdiagonal of U.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, U(i,i) is exactly zero, and the solution\n* has not been computed. The factorization has not been\n* completed unless i = N.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, doublecomplex*);
- MEMCPY(dl_out__, dl, doublecomplex, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublecomplex*);
- MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, doublecomplex*);
- MEMCPY(du_out__, du, doublecomplex, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_dl, rb_d, rb_du, rb_b);
-}
-
-void
-init_lapack_zgtsv(VALUE mLapack){
- rb_define_module_function(mLapack, "zgtsv", rb_zgtsv, -1);
-}
diff --git a/zgtsvx.c b/zgtsvx.c
deleted file mode 100644
index ad0d761..0000000
--- a/zgtsvx.c
+++ /dev/null
@@ -1,237 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgtsvx_(char *fact, char *trans, integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *dlf, doublecomplex *df, doublecomplex *duf, doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zgtsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_dlf;
- doublecomplex *dlf;
- VALUE rb_df;
- doublecomplex *df;
- VALUE rb_duf;
- doublecomplex *duf;
- VALUE rb_du2;
- doublecomplex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_dlf_out__;
- doublecomplex *dlf_out__;
- VALUE rb_df_out__;
- doublecomplex *df_out__;
- VALUE rb_duf_out__;
- doublecomplex *duf_out__;
- VALUE rb_du2_out__;
- doublecomplex *du2_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.zgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b)\n or\n NumRu::Lapack.zgtsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZGTSVX uses the LU factorization to compute the solution to a complex\n* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n* as A = L * U, where L is a product of permutation and unit lower\n* bidiagonal matrices and U is upper triangular with nonzeros in\n* only the main diagonal and first two superdiagonals.\n*\n* 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form\n* of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n* be modified.\n* = 'N': The matrix will be copied to DLF, DF, and DUF\n* and factored.\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)\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) subdiagonal elements of A.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The n diagonal elements of A.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) superdiagonal elements of A.\n*\n* DLF (input or output) COMPLEX*16 array, dimension (N-1)\n* If FACT = 'F', then DLF is an input argument and on entry\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A as computed by ZGTTRF.\n*\n* If FACT = 'N', then DLF is an output argument and on exit\n* contains the (n-1) multipliers that define the matrix L from\n* the LU factorization of A.\n*\n* DF (input or output) COMPLEX*16 array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the upper triangular\n* matrix U from the LU factorization of A.\n*\n* DUF (input or output) COMPLEX*16 array, dimension (N-1)\n* If FACT = 'F', then DUF is an input argument and on entry\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* If FACT = 'N', then DUF is an output argument and on exit\n* contains the (n-1) elements of the first superdiagonal of U.\n*\n* DU2 (input or output) COMPLEX*16 array, dimension (N-2)\n* If FACT = 'F', then DU2 is an input argument and on entry\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* If FACT = 'N', then DU2 is an output argument and on exit\n* contains the (n-2) elements of the second superdiagonal of\n* U.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains the pivot indices from the LU factorization of A as\n* computed by ZGTTRF.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains the pivot indices from the LU factorization of A;\n* row i of the matrix was interchanged with row IPIV(i).\n* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n* a row interchange was not required.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: U(i,i) is exactly zero. The factorization\n* has not been completed unless i = N, but the\n* factor U is exactly singular, so the solution\n* and error bounds could not be computed.\n* RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_fact = argv[0];
- rb_trans = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_dlf = argv[5];
- rb_df = argv[6];
- rb_duf = argv[7];
- rb_du2 = argv[8];
- rb_ipiv = argv[9];
- rb_b = argv[10];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (11th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (7th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_df) != NA_DCOMPLEX)
- rb_df = na_change_type(rb_df, NA_DCOMPLEX);
- df = NA_PTR_TYPE(rb_df, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_DCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_dlf))
- rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
- if (NA_RANK(rb_dlf) != 1)
- rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dlf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
- if (NA_TYPE(rb_dlf) != NA_DCOMPLEX)
- rb_dlf = na_change_type(rb_dlf, NA_DCOMPLEX);
- dlf = NA_PTR_TYPE(rb_dlf, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- if (!NA_IsNArray(rb_duf))
- rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
- if (NA_RANK(rb_duf) != 1)
- rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_duf) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
- if (NA_TYPE(rb_duf) != NA_DCOMPLEX)
- rb_duf = na_change_type(rb_duf, NA_DCOMPLEX);
- duf = NA_PTR_TYPE(rb_duf, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dlf_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- dlf_out__ = NA_PTR_TYPE(rb_dlf_out__, doublecomplex*);
- MEMCPY(dlf_out__, dlf, doublecomplex, NA_TOTAL(rb_dlf));
- rb_dlf = rb_dlf_out__;
- dlf = dlf_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, doublecomplex*);
- MEMCPY(df_out__, df, doublecomplex, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_duf_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- duf_out__ = NA_PTR_TYPE(rb_duf_out__, doublecomplex*);
- MEMCPY(duf_out__, duf, doublecomplex, NA_TOTAL(rb_duf));
- rb_duf = rb_duf_out__;
- duf = duf_out__;
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- du2_out__ = NA_PTR_TYPE(rb_du2_out__, doublecomplex*);
- MEMCPY(du2_out__, du2, doublecomplex, NA_TOTAL(rb_du2));
- rb_du2 = rb_du2_out__;
- du2 = du2_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_dlf, rb_df, rb_duf, rb_du2, rb_ipiv);
-}
-
-void
-init_lapack_zgtsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zgtsvx", rb_zgtsvx, -1);
-}
diff --git a/zgttrf.c b/zgttrf.c
deleted file mode 100644
index 2add774..0000000
--- a/zgttrf.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgttrf_(integer *n, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, integer *ipiv, integer *info);
-
-static VALUE
-rb_zgttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_du2;
- doublecomplex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_dl_out__;
- doublecomplex *dl_out__;
- VALUE rb_d_out__;
- doublecomplex *d_out__;
- VALUE rb_du_out__;
- doublecomplex *du_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n du2, ipiv, info, dl, d, du = NumRu::Lapack.zgttrf( dl, d, du)\n or\n NumRu::Lapack.zgttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZGTTRF computes an LU factorization of a complex tridiagonal matrix A\n* using elimination with partial pivoting and row interchanges.\n*\n* The factorization has the form\n* A = L * U\n* where L is a product of permutation and unit lower bidiagonal\n* matrices and U is upper triangular with nonzeros in only the main\n* diagonal and first two superdiagonals.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* DL (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DL must contain the (n-1) sub-diagonal elements of\n* A.\n*\n* On exit, DL is overwritten by the (n-1) multipliers that\n* define the matrix L from the LU factorization of A.\n*\n* D (input/output) COMPLEX*16 array, dimension (N)\n* On entry, D must contain the diagonal elements of A.\n*\n* On exit, D is overwritten by the n diagonal elements of the\n* upper triangular matrix U from the LU factorization of A.\n*\n* DU (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, DU must contain the (n-1) super-diagonal elements\n* of A.\n*\n* On exit, DU is overwritten by the (n-1) elements of the first\n* super-diagonal of U.\n*\n* DU2 (output) COMPLEX*16 array, dimension (N-2)\n* On exit, DU2 is overwritten by the (n-2) elements of the\n* second super-diagonal of U.\n*\n* IPIV (output) 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* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n* has been completed, but the factor U is exactly\n* singular, and division by zero will occur if it is used\n* to solve a system of equations.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_dl = argv[0];
- rb_d = argv[1];
- rb_du = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (3th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- {
- int shape[1];
- shape[0] = n-2;
- rb_du2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- du2 = NA_PTR_TYPE(rb_du2, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_dl_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- dl_out__ = NA_PTR_TYPE(rb_dl_out__, doublecomplex*);
- MEMCPY(dl_out__, dl, doublecomplex, NA_TOTAL(rb_dl));
- rb_dl = rb_dl_out__;
- dl = dl_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublecomplex*);
- MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_du_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- du_out__ = NA_PTR_TYPE(rb_du_out__, doublecomplex*);
- MEMCPY(du_out__, du, doublecomplex, NA_TOTAL(rb_du));
- rb_du = rb_du_out__;
- du = du_out__;
-
- zgttrf_(&n, dl, d, du, du2, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_du2, rb_ipiv, rb_info, rb_dl, rb_d, rb_du);
-}
-
-void
-init_lapack_zgttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zgttrf", rb_zgttrf, -1);
-}
diff --git a/zgttrs.c b/zgttrs.c
deleted file mode 100644
index ef6eeb9..0000000
--- a/zgttrs.c
+++ /dev/null
@@ -1,118 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgttrs_(char *trans, integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zgttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_du2;
- doublecomplex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zgttrs( trans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.zgttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZGTTRS solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by ZGTTRF.\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)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX*16 array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZGTTS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_trans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_DCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zgttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zgttrs", rb_zgttrs, -1);
-}
diff --git a/zgtts2.c b/zgtts2.c
deleted file mode 100644
index 5b840da..0000000
--- a/zgtts2.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zgtts2_(integer *itrans, integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb);
-
-static VALUE
-rb_zgtts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itrans;
- integer itrans;
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_du2;
- doublecomplex *du2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.zgtts2( itrans, dl, d, du, du2, ipiv, b)\n or\n NumRu::Lapack.zgtts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n* Purpose\n* =======\n*\n* ZGTTS2 solves one of the systems of equations\n* A * X = B, A**T * X = B, or A**H * X = B,\n* with a tridiagonal matrix A using the LU factorization computed\n* by ZGTTRF.\n*\n\n* Arguments\n* =========\n*\n* ITRANS (input) INTEGER\n* Specifies the form of the system of equations.\n* = 0: A * X = B (No transpose)\n* = 1: A**T * X = B (Transpose)\n* = 2: A**H * X = B (Conjugate transpose)\n*\n* N (input) INTEGER\n* The order of the matrix A.\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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) multipliers that define the matrix L from the\n* LU factorization of A.\n*\n* D (input) COMPLEX*16 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) COMPLEX*16 array, dimension (N-1)\n* The (n-1) elements of the first super-diagonal of U.\n*\n* DU2 (input) COMPLEX*16 array, dimension (N-2)\n* The (n-2) elements of the second super-diagonal 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/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the matrix of right hand side vectors B.\n* On exit, B is overwritten by the solution vectors X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n COMPLEX*16 TEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_itrans = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
- rb_du2 = argv[4];
- rb_ipiv = argv[5];
- rb_b = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- itrans = NUM2INT(rb_itrans);
- if (!NA_IsNArray(rb_du2))
- rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
- if (NA_RANK(rb_du2) != 1)
- rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du2) != (n-2))
- rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
- if (NA_TYPE(rb_du2) != NA_DCOMPLEX)
- rb_du2 = na_change_type(rb_du2, NA_DCOMPLEX);
- du2 = NA_PTR_TYPE(rb_du2, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_zgtts2(VALUE mLapack){
- rb_define_module_function(mLapack, "zgtts2", rb_zgtts2, -1);
-}
diff --git a/zhbev.c b/zhbev.c
deleted file mode 100644
index 4542b09..0000000
--- a/zhbev.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbev_(char *jobz, char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhbev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab = NumRu::Lapack.zhbev( jobz, uplo, kd, ab)\n or\n NumRu::Lapack.zhbev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBEV computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (MAX(1,3*n-2)));
-
- zhbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ab);
-}
-
-void
-init_lapack_zhbev(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbev", rb_zhbev, -1);
-}
diff --git a/zhbevd.c b/zhbevd.c
deleted file mode 100644
index e659771..0000000
--- a/zhbevd.c
+++ /dev/null
@@ -1,121 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbevd_(char *jobz, char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zhbevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab = NumRu::Lapack.zhbevd( jobz, uplo, kd, ab, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zhbevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian band matrix A. If eigenvectors are desired, it\n* uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the first\n* superdiagonal and the diagonal of the tridiagonal matrix T\n* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n* the diagonal and first subdiagonal of T are returned in the\n* first two rows of AB.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_lwork = argv[4];
- rb_lrwork = argv[5];
- rb_liwork = argv[6];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- jobz = StringValueCStr(rb_jobz)[0];
- lwork = NUM2INT(rb_lwork);
- kd = NUM2INT(rb_kd);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zhbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_rwork, rb_iwork, rb_info, rb_ab);
-}
-
-void
-init_lapack_zhbevd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbevd", rb_zhbevd, -1);
-}
diff --git a/zhbevx.c b/zhbevx.c
deleted file mode 100644
index 54272d4..0000000
--- a/zhbevx.c
+++ /dev/null
@@ -1,141 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbevx_(char *jobz, char *range, char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublecomplex *q, integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_zhbevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- doublecomplex *work;
- doublereal *rwork;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab = NumRu::Lapack.zhbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.zhbevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHBEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian band matrix A. Eigenvalues and eigenvectors\n* can be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, AB is overwritten by values generated during the\n* reduction to tridiagonal form.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD + 1.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ, N)\n* If JOBZ = 'V', the N-by-N unitary matrix used in the\n* reduction to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'V', then\n* LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AB to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_vl = argv[5];
- rb_vu = argv[6];
- rb_il = argv[7];
- rb_iu = argv[8];
- rb_abstol = argv[9];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- zhbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_q, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ab);
-}
-
-void
-init_lapack_zhbevx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbevx", rb_zhbevx, -1);
-}
diff --git a/zhbgst.c b/zhbgst.c
deleted file mode 100644
index 16f1507..0000000
--- a/zhbgst.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbgst_(char *vect, char *uplo, integer *n, integer *ka, integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb, integer *ldbb, doublecomplex *x, integer *ldx, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhbgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_bb;
- doublecomplex *bb;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, info, ab = NumRu::Lapack.zhbgst( vect, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.zhbgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGST reduces a complex Hermitian-definite banded generalized\n* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n* such that C has the same bandwidth as A.\n*\n* B must have been previously factorized as S**H*S by ZPBSTF, using a\n* split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n* X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n* bandwidth of A.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form the transformation matrix X;\n* = 'V': form X.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the transformed matrix X**H*A*X, stored in the same\n* format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input) COMPLEX*16 array, dimension (LDBB,N)\n* The banded factor S from the split Cholesky factorization of\n* B, as returned by ZPBSTF, stored in the first kb+1 rows of\n* the array.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* X (output) COMPLEX*16 array, dimension (LDX,N)\n* If VECT = 'V', the n-by-n matrix X.\n* If VECT = 'N', the array X is not referenced.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X.\n* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_DCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, doublecomplex*);
- ka = NUM2INT(rb_ka);
- vect = StringValueCStr(rb_vect)[0];
- kb = NUM2INT(rb_kb);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (n));
-
- zhbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_x, rb_info, rb_ab);
-}
-
-void
-init_lapack_zhbgst(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbgst", rb_zhbgst, -1);
-}
diff --git a/zhbgv.c b/zhbgv.c
deleted file mode 100644
index ef10c4e..0000000
--- a/zhbgv.c
+++ /dev/null
@@ -1,121 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbgv_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb, integer *ldbb, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhbgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_bb;
- doublecomplex *bb;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_bb_out__;
- doublecomplex *bb_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ab, bb = NumRu::Lapack.zhbgv( jobz, uplo, ka, kb, ab, bb)\n or\n NumRu::Lapack.zhbgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by ZPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL DSTERF, XERBLA, ZHBGST, ZHBTRD, ZPBSTF, ZSTEQR\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_DCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, doublecomplex*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- kb = NUM2INT(rb_kb);
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, doublecomplex*);
- MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (3*n));
-
- zhbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_zhbgv(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbgv", rb_zhbgv, -1);
-}
diff --git a/zhbgvd.c b/zhbgvd.c
deleted file mode 100644
index 43c7a9b..0000000
--- a/zhbgvd.c
+++ /dev/null
@@ -1,151 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbgvd_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb, integer *ldbb, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zhbgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_bb;
- doublecomplex *bb;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_bb_out__;
- doublecomplex *bb_out__;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.zhbgvd( jobz, uplo, ka, kb, ab, bb, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zhbgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by ZPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, and i is:\n* <= N: the algorithm failed to converge:\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ka = argv[2];
- rb_kb = argv[3];
- rb_ab = argv[4];
- rb_bb = argv[5];
- rb_lwork = argv[6];
- rb_lrwork = argv[7];
- rb_liwork = argv[8];
-
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_DCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, doublecomplex*);
- ka = NUM2INT(rb_ka);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kb = NUM2INT(rb_kb);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- liwork = NUM2INT(rb_liwork);
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, doublecomplex*);
- MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
-
- zhbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_w, rb_z, rb_work, rb_rwork, rb_iwork, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_zhbgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbgvd", rb_zhbgvd, -1);
-}
diff --git a/zhbgvx.c b/zhbgvx.c
deleted file mode 100644
index 6445d48..0000000
--- a/zhbgvx.c
+++ /dev/null
@@ -1,170 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbgvx_(char *jobz, char *range, char *uplo, integer *n, integer *ka, integer *kb, doublecomplex *ab, integer *ldab, doublecomplex *bb, integer *ldbb, doublecomplex *q, integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_zhbgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ka;
- integer ka;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_bb;
- doublecomplex *bb;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_bb_out__;
- doublecomplex *bb_out__;
- doublecomplex *work;
- doublereal *rwork;
- integer *iwork;
-
- integer ldab;
- integer n;
- integer ldbb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.zhbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.zhbgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite banded eigenproblem, of\n* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n* and banded, and B is also positive definite. Eigenvalues and\n* eigenvectors can be selected by specifying either all eigenvalues,\n* a range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* KA (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n* KB (input) INTEGER\n* The number of superdiagonals of the matrix B if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first ka+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n*\n* On exit, the contents of AB are destroyed.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KA+1.\n*\n* BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix B, stored in the first kb+1 rows of the array. The\n* j-th column of B is stored in the j-th column of the array BB\n* as follows:\n* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n*\n* On exit, the factor S from the split Cholesky factorization\n* B = S**H*S, as returned by ZPBSTF.\n*\n* LDBB (input) INTEGER\n* The leading dimension of the array BB. LDBB >= KB+1.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ, N)\n* If JOBZ = 'V', the n-by-n matrix used in the reduction of\n* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n* and consequently C to tridiagonal form.\n* If JOBZ = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. If JOBZ = 'N',\n* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors, with the i-th column of Z holding the\n* eigenvector associated with W(i). The eigenvectors are\n* normalized so that Z**H*B*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= N.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n* <= N: then i eigenvectors failed to converge. Their\n* indices are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n* returned INFO = i: B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ka = argv[3];
- rb_kb = argv[4];
- rb_ab = argv[5];
- rb_bb = argv[6];
- rb_vl = argv[7];
- rb_vu = argv[8];
- rb_il = argv[9];
- rb_iu = argv[10];
- rb_abstol = argv[11];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_bb))
- rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
- if (NA_RANK(rb_bb) != 2)
- rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_bb);
- ldbb = NA_SHAPE0(rb_bb);
- if (NA_TYPE(rb_bb) != NA_DCOMPLEX)
- rb_bb = na_change_type(rb_bb, NA_DCOMPLEX);
- bb = NA_PTR_TYPE(rb_bb, doublecomplex*);
- ka = NUM2INT(rb_ka);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kb = NUM2INT(rb_kb);
- vu = NUM2DBL(rb_vu);
- jobz = StringValueCStr(rb_jobz)[0];
- il = NUM2INT(rb_il);
- range = StringValueCStr(rb_range)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- ldq = 1 ? jobz = 'n' : max(1,n) ? jobz = 'v' : 0;
- ldz = lsame_(&jobz,"V") ? n : 1;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldbb;
- shape[1] = n;
- rb_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- bb_out__ = NA_PTR_TYPE(rb_bb_out__, doublecomplex*);
- MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rb_bb));
- rb_bb = rb_bb_out__;
- bb = bb_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- zhbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_q, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ab, rb_bb);
-}
-
-void
-init_lapack_zhbgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbgvx", rb_zhbgvx, -1);
-}
diff --git a/zhbtrd.c b/zhbtrd.c
deleted file mode 100644
index 7d7ec1b..0000000
--- a/zhbtrd.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhbtrd_(char *vect, char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *d, doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zhbtrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- doublecomplex *work;
-
- integer ldab;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, info, ab, q = NumRu::Lapack.zhbtrd( vect, uplo, kd, ab, q)\n or\n NumRu::Lapack.zhbtrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHBTRD reduces a complex Hermitian band matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'N': do not form Q;\n* = 'V': form Q;\n* = 'U': update a matrix X, by forming X*Q.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* On exit, the diagonal elements of AB are overwritten by the\n* diagonal elements of the tridiagonal matrix T; if KD > 0, the\n* elements on the first superdiagonal (if UPLO = 'U') or the\n* first subdiagonal (if UPLO = 'L') are overwritten by the\n* off-diagonal elements of T; the rest of AB is overwritten by\n* values generated during the reduction.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T.\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if VECT = 'U', then Q must contain an N-by-N\n* matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n* On exit:\n* if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n* if VECT = 'U', Q contains the product X*Q;\n* if VECT = 'N', the array Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* Modified by Linda Kaufman, Bell Labs.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_vect = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_q = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- vect = StringValueCStr(rb_vect)[0];
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of ab");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zhbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_info, rb_ab, rb_q);
-}
-
-void
-init_lapack_zhbtrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhbtrd", rb_zhbtrd, -1);
-}
diff --git a/zhecon.c b/zhecon.c
deleted file mode 100644
index 01bbcb7..0000000
--- a/zhecon.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhecon_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zhecon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zhecon( uplo, a, ipiv, anorm)\n or\n NumRu::Lapack.zhecon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHECON estimates the reciprocal of the condition number of a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHETRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublecomplex, (2*n));
-
- zhecon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zhecon(VALUE mLapack){
- rb_define_module_function(mLapack, "zhecon", rb_zhecon, -1);
-}
diff --git a/zheequb.c b/zheequb.c
deleted file mode 100644
index 14ec499..0000000
--- a/zheequb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zheequb_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zheequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zheequb( uplo, a)\n or\n NumRu::Lapack.zheequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- work = ALLOC_N(doublecomplex, (3*n));
-
- zheequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
-
- free(work);
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_zheequb(VALUE mLapack){
- rb_define_module_function(mLapack, "zheequb", rb_zheequb, -1);
-}
diff --git a/zheev.c b/zheev.c
deleted file mode 100644
index a17b826..0000000
--- a/zheev.c
+++ /dev/null
@@ -1,85 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zheev_(char *jobz, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zheev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a = NumRu::Lapack.zheev( jobz, uplo, a, lwork)\n or\n NumRu::Lapack.zheev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEV computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for ZHETRD returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
-
- zheev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zheev(VALUE mLapack){
- rb_define_module_function(mLapack, "zheev", rb_zheev, -1);
-}
diff --git a/zheevd.c b/zheevd.c
deleted file mode 100644
index d89a6fd..0000000
--- a/zheevd.c
+++ /dev/null
@@ -1,106 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zheevd_(char *jobz, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zheevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a = NumRu::Lapack.zheevd( jobz, uplo, a, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zheevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix A. If eigenvectors are desired, it uses a\n* divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* orthonormal eigenvectors of the matrix A.\n* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n* or the upper triangle (if UPLO='U') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed\n* to converge; i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* if INFO = i and JOBZ = 'V', then the algorithm failed\n* to compute an eigenvalue while working on the submatrix\n* lying in rows and columns INFO/(N+1) through\n* mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* Modified description of INFO. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_lwork = argv[3];
- rb_lrwork = argv[4];
- rb_liwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zheevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_work, rb_rwork, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_zheevd(VALUE mLapack){
- rb_define_module_function(mLapack, "zheevd", rb_zheevd, -1);
-}
diff --git a/zheevr.c b/zheevr.c
deleted file mode 100644
index 2866d35..0000000
--- a/zheevr.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zheevr_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, integer *isuppz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zheevr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.zheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zheevr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEVR computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n* ZHEEVR first reduces the matrix A to tridiagonal form T with a call\n* to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute\n* eigenspectrum using Relatively Robust Representations. ZSTEMR\n* computes eigenvalues by the dqds algorithm, while orthogonal\n* eigenvectors are computed from various \"good\" L D L^T representations\n* (also known as Relatively Robust Representations). Gram-Schmidt\n* orthogonalization is avoided as far as possible. More specifically,\n* the various steps of the algorithm are as follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* The desired accuracy of the output can be specified by the input\n* parameter ABSTOL.\n*\n* For more details, see DSTEMR's documentation and:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n*\n* Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested\n* on machines which conform to the ieee-754 floating point standard.\n* ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and\n* when partial spectrum requests are made.\n*\n* Normal execution of ZSTEMR may create NaNs and infinities and\n* hence may abort due to a floating point exception in environments\n* which do not handle NaNs and infinities in the ieee standard default\n* manner.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** ZSTEIN are called\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* If high relative accuracy is important, set ABSTOL to\n* DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n* eigenvalues are computed to high relative accuracy when\n* possible in future releases. The current code does not\n* make any guarantees about high relative accuracy, but\n* furutre releases will. See J. Barlow and J. Demmel,\n* \"Computing Accurate Eigensystems of Scaled Diagonally\n* Dominant Matrices\", LAPACK Working Note #7, for a discussion\n* of which matrices define their eigenvalues to high relative\n* accuracy.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for ZHETRD and for\n* ZUNMTR as returned by ILAENV.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal\n* (and minimal) LRWORK.\n*\n* LRWORK (input) INTEGER\n* The length of the array RWORK. LRWORK >= max(1,24*N).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal\n* (and minimal) LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N).\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: Internal error\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Ken Stanley, Computer Science Division, University of\n* California at Berkeley, USA\n* Jason Riedy, Computer Science Division, University of\n* California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_lrwork = argv[10];
- rb_liwork = argv[11];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- vu = NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- lrwork = NUM2INT(rb_lrwork);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zheevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_rwork, rb_iwork, rb_info, rb_a);
-}
-
-void
-init_lapack_zheevr(VALUE mLapack){
- rb_define_module_function(mLapack, "zheevr", rb_zheevr, -1);
-}
diff --git a/zheevx.c b/zheevx.c
deleted file mode 100644
index cbf9fd3..0000000
--- a/zheevx.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zheevx_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_zheevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a = NumRu::Lapack.zheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, lwork)\n or\n NumRu::Lapack.zheevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHEEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n* be selected by specifying either a range of values or a range of\n* indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= 1, when N <= 1;\n* otherwise 2*N.\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the max of the blocksize for ZHETRD and for\n* ZUNMTR as returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- rwork = ALLOC_N(doublereal, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- zheevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
-
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a);
-}
-
-void
-init_lapack_zheevx(VALUE mLapack){
- rb_define_module_function(mLapack, "zheevx", rb_zheevx, -1);
-}
diff --git a/zhegs2.c b/zhegs2.c
deleted file mode 100644
index efdf8c4..0000000
--- a/zhegs2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhegs2_(integer *itype, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zhegs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zhegs2( itype, uplo, a, b)\n or\n NumRu::Lapack.zhegs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGS2 reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n* B must have been previously factorized as U'*U or L*L' by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n* = 2 or 3: compute U*A*U' or L'*A*L.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian matrix A is stored, and how B has been factorized.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by ZPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zhegs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zhegs2(VALUE mLapack){
- rb_define_module_function(mLapack, "zhegs2", rb_zhegs2, -1);
-}
diff --git a/zhegst.c b/zhegst.c
deleted file mode 100644
index 01a7fc4..0000000
--- a/zhegst.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhegst_(integer *itype, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zhegst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zhegst( itype, uplo, a, b)\n or\n NumRu::Lapack.zhegst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The triangular factor from the Cholesky factorization of B,\n* as returned by ZPOTRF.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- itype = NUM2INT(rb_itype);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zhegst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zhegst(VALUE mLapack){
- rb_define_module_function(mLapack, "zhegst", rb_zhegst, -1);
-}
diff --git a/zhegv.c b/zhegv.c
deleted file mode 100644
index 5c26d06..0000000
--- a/zhegv.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhegv_(integer *itype, char *jobz, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhegv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, a, b = NumRu::Lapack.zhegv( itype, jobz, uplo, a, b, lwork)\n or\n NumRu::Lapack.zhegv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGV computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian and B is also\n* positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the Hermitian positive definite matrix B.\n* If UPLO = 'U', the leading N-by-N upper triangular part of B\n* contains the upper triangular part of the matrix B.\n* If UPLO = 'L', the leading N-by-N lower triangular part of B\n* contains the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N-1).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for ZHETRD returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPOTRF or ZHEEV returned an error code:\n* <= N: if INFO = i, ZHEEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not converge to zero;\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
-
- zhegv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zhegv(VALUE mLapack){
- rb_define_module_function(mLapack, "zhegv", rb_zhegv, -1);
-}
diff --git a/zhegvd.c b/zhegvd.c
deleted file mode 100644
index 1379a83..0000000
--- a/zhegvd.c
+++ /dev/null
@@ -1,136 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhegvd_(integer *itype, char *jobz, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zhegvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, rwork, iwork, info, a, b = NumRu::Lapack.zhegvd( itype, jobz, uplo, a, b, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zhegvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n* matrix Z of eigenvectors. The eigenvectors are normalized\n* as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n* or the lower triangle (if UPLO='L') of A, including the\n* diagonal, is destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N + 1.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If N <= 1, LIWORK >= 1.\n* If JOBZ = 'N' and N > 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: ZPOTRF or ZHEEVD returned an error code:\n* <= N: if INFO = i and JOBZ = 'N', then the algorithm\n* failed to converge; i off-diagonal elements of an\n* intermediate tridiagonal form did not converge to\n* zero;\n* if INFO = i and JOBZ = 'V', then the algorithm\n* failed to compute an eigenvalue while working on\n* the submatrix lying in rows and columns INFO/(N+1)\n* through mod(INFO,N+1);\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* Modified so that no backsubstitution is performed if ZHEEVD fails to\n* converge (NEIG in old code could be greater than N causing out of\n* bounds reference to A - reported by Ralf Meyer). Also corrected the\n* description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_lwork = argv[5];
- rb_lrwork = argv[6];
- rb_liwork = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- jobz = StringValueCStr(rb_jobz)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zhegvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_work, rb_rwork, rb_iwork, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zhegvd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhegvd", rb_zhegvd, -1);
-}
diff --git a/zhegvx.c b/zhegvx.c
deleted file mode 100644
index 51fc1eb..0000000
--- a/zhegvx.c
+++ /dev/null
@@ -1,167 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhegvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_zhegvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
- integer *iwork;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, work, ifail, info, a, b = NumRu::Lapack.zhegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, ldz, lwork)\n or\n NumRu::Lapack.zhegvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHEGVX computes selected eigenvalues, and optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian and B is also positive definite.\n* Eigenvalues and eigenvectors can be selected by specifying either a\n* range of values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n**\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA, N)\n* On entry, the Hermitian matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of A contains the\n* upper triangular part of the matrix A. If UPLO = 'L',\n* the leading N-by-N lower triangular part of A contains\n* the lower triangular part of the matrix A.\n*\n* On exit, the lower triangle (if UPLO='L') or the upper\n* triangle (if UPLO='U') of A, including the diagonal, is\n* destroyed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB, N)\n* On entry, the Hermitian matrix B. If UPLO = 'U', the\n* leading N-by-N upper triangular part of B contains the\n* upper triangular part of the matrix B. If UPLO = 'L',\n* the leading N-by-N lower triangular part of B contains\n* the lower triangular part of the matrix B.\n*\n* On exit, if INFO <= N, the part of B containing the matrix is\n* overwritten by the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing A to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**T*B*Z = I;\n* if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of the array WORK. LWORK >= max(1,2*N).\n* For optimal efficiency, LWORK >= (NB+1)*N,\n* where NB is the blocksize for ZHETRD returned by ILAENV.\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* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPOTRF or ZHEEVX returned an error code:\n* <= N: if INFO = i, ZHEEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= N, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_vl = argv[6];
- rb_vu = argv[7];
- rb_il = argv[8];
- rb_iu = argv[9];
- rb_abstol = argv[10];
- rb_ldz = argv[11];
- rb_lwork = argv[12];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- vu = NUM2DBL(rb_vu);
- itype = NUM2INT(rb_itype);
- lwork = NUM2INT(rb_lwork);
- range = StringValueCStr(rb_range)[0];
- il = NUM2INT(rb_il);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- zhegvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);
-
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_m, rb_w, rb_z, rb_work, rb_ifail, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zhegvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhegvx", rb_zhegvx, -1);
-}
diff --git a/zherfs.c b/zherfs.c
deleted file mode 100644
index 87f7570..0000000
--- a/zherfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zherfs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zherfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zherfs( uplo, a, af, ipiv, b, x)\n or\n NumRu::Lapack.zherfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHERFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZHETRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zherfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zherfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zherfs", rb_zherfs, -1);
-}
diff --git a/zherfsx.c b/zherfsx.c
deleted file mode 100644
index b9640f8..0000000
--- a/zherfsx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zherfsx_(char *uplo, char *equed, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zherfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zherfsx( uplo, equed, a, af, ipiv, s, b, x, params)\n or\n NumRu::Lapack.zherfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHERFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
- rb_params = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zherfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_zherfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "zherfsx", rb_zherfsx, -1);
-}
diff --git a/zhesv.c b/zhesv.c
deleted file mode 100644
index 39801c7..0000000
--- a/zhesv.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhesv_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zhesv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.zhesv( uplo, a, b, lwork)\n or\n NumRu::Lapack.zhesv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHESV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**H or A = L*D*L**H as computed by\n* ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZHETRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* ZHETRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHETRF, ZHETRS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zhesv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zhesv(VALUE mLapack){
- rb_define_module_function(mLapack, "zhesv", rb_zhesv, -1);
-}
diff --git a/zhesvx.c b/zhesvx.c
deleted file mode 100644
index bfaf703..0000000
--- a/zhesvx.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhesvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhesvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zhesvx( fact, uplo, a, af, ipiv, b, lwork)\n or\n NumRu::Lapack.zhesvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHESVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHETRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHETRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHETRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for ZHETRF.\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* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- rwork = ALLOC_N(doublereal, (n));
-
- zhesvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_af, rb_ipiv);
-}
-
-void
-init_lapack_zhesvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhesvx", rb_zhesvx, -1);
-}
diff --git a/zhesvxx.c b/zhesvxx.c
deleted file mode 100644
index c04119f..0000000
--- a/zhesvxx.c
+++ /dev/null
@@ -1,239 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhesvxx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhesvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zhesvxx( fact, uplo, a, af, ipiv, equed, s, b, params)\n or\n NumRu::Lapack.zhesvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHESVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex*16 system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZHESVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZHESVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZHESVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZHESVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by ZHETRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by ZHETRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
- rb_params = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zhesvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(14, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_zhesvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhesvxx", rb_zhesvxx, -1);
-}
diff --git a/zhetd2.c b/zhetd2.c
deleted file mode 100644
index 8ce6e71..0000000
--- a/zhetd2.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhetd2_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *d, doublereal *e, doublecomplex *tau, integer *info);
-
-static VALUE
-rb_zhetd2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, a = NumRu::Lapack.zhetd2( uplo, a)\n or\n NumRu::Lapack.zhetd2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* ZHETD2 reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q' * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zhetd2_(&uplo, &n, a, &lda, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_zhetd2(VALUE mLapack){
- rb_define_module_function(mLapack, "zhetd2", rb_zhetd2, -1);
-}
diff --git a/zhetf2.c b/zhetf2.c
deleted file mode 100644
index 7e1d51a..0000000
--- a/zhetf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhetf2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_zhetf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zhetf2( uplo, a)\n or\n NumRu::Lapack.zhetf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZHETF2 computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the conjugate transpose of U, and D is\n* Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.210 and l.393\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n* 01-01-96 - Based on modifications by\n* J. Lewis, Boeing Computer Services Company\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zhetf2_(&uplo, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_zhetf2(VALUE mLapack){
- rb_define_module_function(mLapack, "zhetf2", rb_zhetf2, -1);
-}
diff --git a/zhetrd.c b/zhetrd.c
deleted file mode 100644
index 1ec52f4..0000000
--- a/zhetrd.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhetrd_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *d, doublereal *e, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zhetrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, work, info, a = NumRu::Lapack.zhetrd( uplo, a, lwork)\n or\n NumRu::Lapack.zhetrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRD reduces a complex Hermitian matrix A to real symmetric\n* tridiagonal form T by a unitary similarity transformation:\n* Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\n*\n* WORK (workspace/output) COMPLEX*16 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* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n* A(1:i-1,i+1), and tau in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n* and tau in TAU(i).\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( d e v2 v3 v4 ) ( d )\n* ( d e v3 v4 ) ( e d )\n* ( d e v4 ) ( v1 e d )\n* ( d e ) ( v1 v2 e d )\n* ( d ) ( v1 v2 v3 e d )\n*\n* where d and e denote diagonal and off-diagonal elements of T, and vi\n* denotes an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zhetrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_d, rb_e, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zhetrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhetrd", rb_zhetrd, -1);
-}
diff --git a/zhetrf.c b/zhetrf.c
deleted file mode 100644
index bb41cb8..0000000
--- a/zhetrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhetrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zhetrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.zhetrf( uplo, a, lwork)\n or\n NumRu::Lapack.zhetrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRF computes the factorization of a complex Hermitian matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian 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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHETF2, ZLAHEF\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zhetrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zhetrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zhetrf", rb_zhetrf, -1);
-}
diff --git a/zhetri.c b/zhetri.c
deleted file mode 100644
index 4ab0f22..0000000
--- a/zhetri.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhetri_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zhetri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zhetri( uplo, a, ipiv)\n or\n NumRu::Lapack.zhetri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRI computes the inverse of a complex Hermitian indefinite matrix\n* A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n* ZHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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 block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZHETRF.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* WORK (workspace) COMPLEX*16 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zhetri_(&uplo, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zhetri(VALUE mLapack){
- rb_define_module_function(mLapack, "zhetri", rb_zhetri, -1);
-}
diff --git a/zhetrs.c b/zhetrs.c
deleted file mode 100644
index c5c8789..0000000
--- a/zhetrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhetrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zhetrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zhetrs( uplo, a, ipiv, b)\n or\n NumRu::Lapack.zhetrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHETRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zhetrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zhetrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zhetrs", rb_zhetrs, -1);
-}
diff --git a/zhetrs2.c b/zhetrs2.c
deleted file mode 100644
index b6d4d59..0000000
--- a/zhetrs2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhetrs2_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, real *work, integer *info);
-
-static VALUE
-rb_zhetrs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zhetrs2( uplo, a, ipiv, b)\n or\n NumRu::Lapack.zhetrs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHETRS2 solves a system of linear equations A*X = B with a real\n* Hermitian matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (n));
-
- zhetrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zhetrs2(VALUE mLapack){
- rb_define_module_function(mLapack, "zhetrs2", rb_zhetrs2, -1);
-}
diff --git a/zhfrk.c b/zhfrk.c
deleted file mode 100644
index 7d23caa..0000000
--- a/zhfrk.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhfrk_(char *transr, char *uplo, char *trans, integer *n, integer *k, doublereal *alpha, doublecomplex *a, integer *lda, doublereal *beta, doublecomplex *c);
-
-static VALUE
-rb_zhfrk(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zhfrk( transr, uplo, trans, n, k, alpha, a, beta, c)\n or\n NumRu::Lapack.zhfrk # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for C in RFP Format.\n*\n* ZHFRK performs one of the Hermitian rank--k operations\n*\n* C := alpha*A*conjg( A' ) + beta*C,\n*\n* or\n*\n* C := alpha*conjg( A' )*A + beta*C,\n*\n* where alpha and beta are real scalars, C is an n--by--n Hermitian\n* matrix and A is an n--by--k matrix in the first case and a k--by--n\n* matrix in the second case.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array C is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of C\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of C\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.\n*\n* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix C. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* K (input) INTEGER\n* On entry with TRANS = 'N' or 'n', K specifies the number\n* of columns of the matrix A, and on entry with\n* TRANS = 'C' or 'c', K specifies the number of rows of the\n* matrix A. K must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX*16 array of DIMENSION (LDA,ka)\n* where KA\n* is K when TRANS = 'N' or 'n', and is N otherwise. Before\n* entry with TRANS = 'N' or 'n', the leading N--by--K part of\n* the array A must contain the matrix A, otherwise the leading\n* K--by--N part of the array A must contain the matrix A.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. When TRANS = 'N' or 'n'\n* then LDA must be at least max( 1, n ), otherwise LDA must\n* be at least max( 1, k ).\n* Unchanged on exit.\n*\n* BETA (input) DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta.\n* Unchanged on exit.\n*\n* C (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the matrix A in RFP Format. RFP Format is\n* described by TRANSR, UPLO and N. Note that the imaginary\n* parts of the diagonal elements need not be set, they are\n* assumed to be zero, and on exit they are set to zero.\n*\n* Arguments\n* ==========\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_n = argv[3];
- rb_k = argv[4];
- rb_alpha = argv[5];
- rb_a = argv[6];
- rb_beta = argv[7];
- rb_c = argv[8];
-
- k = NUM2INT(rb_k);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- trans = StringValueCStr(rb_trans)[0];
- alpha = NUM2DBL(rb_alpha);
- beta = NUM2DBL(rb_beta);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (lsame_(&trans,"N") ? k : n))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zhfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);
-
- return rb_c;
-}
-
-void
-init_lapack_zhfrk(VALUE mLapack){
- rb_define_module_function(mLapack, "zhfrk", rb_zhfrk, -1);
-}
diff --git a/zhgeqz.c b/zhgeqz.c
deleted file mode 100644
index 5dca9c7..0000000
--- a/zhgeqz.c
+++ /dev/null
@@ -1,183 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhgeqz_(char *job, char *compq, char *compz, integer *n, integer *ilo, integer *ihi, doublecomplex *h, integer *ldh, doublecomplex *t, integer *ldt, doublecomplex *alpha, doublecomplex *beta, doublecomplex *q, integer *ldq, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhgeqz(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_t_out__;
- doublecomplex *t_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
- doublereal *rwork;
-
- integer ldh;
- integer n;
- integer ldt;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, work, info, h, t, q, z = NumRu::Lapack.zhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, lwork)\n or\n NumRu::Lapack.zhgeqz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n* where H is an upper Hessenberg matrix and T is upper triangular,\n* using the single-shift QZ method.\n* Matrix pairs of this type are produced by the reduction to\n* generalized upper Hessenberg form of a complex matrix pair (A,B):\n* \n* A = Q1*H*Z1**H, B = Q1*T*Z1**H,\n* \n* as computed by ZGGHRD.\n* \n* If JOB='S', then the Hessenberg-triangular pair (H,T) is\n* also reduced to generalized Schur form,\n* \n* H = Q*S*Z**H, T = Q*P*Z**H,\n* \n* where Q and Z are unitary matrices and S and P are upper triangular.\n* \n* Optionally, the unitary matrix Q from the generalized Schur\n* factorization may be postmultiplied into an input matrix Q1, and the\n* unitary matrix Z may be postmultiplied into an input matrix Z1.\n* If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced\n* the matrix pair (A,B) to generalized Hessenberg form, then the output\n* matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n* Schur factorization of (A,B):\n* \n* A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.\n* \n* To avoid overflow, eigenvalues of the matrix pair (H,T)\n* (equivalently, of (A,B)) are computed as a pair of complex values\n* (alpha,beta). If beta is nonzero, lambda = alpha / beta is an\n* eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n* A*x = lambda*B*x\n* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n* alternate form of the GNEP\n* mu*A*y = B*y.\n* The values of alpha and beta for the i-th eigenvalue can be read\n* directly from the generalized Schur form: alpha = S(i,i),\n* beta = P(i,i).\n*\n* Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n* Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n* pp. 241--256.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': Compute eigenvalues only;\n* = 'S': Computer eigenvalues and the Schur form.\n*\n* COMPQ (input) CHARACTER*1\n* = 'N': Left Schur vectors (Q) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Q\n* of left Schur vectors of (H,T) is returned;\n* = 'V': Q must contain a unitary matrix Q1 on entry and\n* the product Q1*Q is returned.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Right Schur vectors (Z) are not computed;\n* = 'I': Q is initialized to the unit matrix and the matrix Z\n* of right Schur vectors of (H,T) is returned;\n* = 'V': Z must contain a unitary matrix Z1 on entry and\n* the product Z1*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrices H, T, Q, and Z. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI mark the rows and columns of H which are in\n* Hessenberg form. It is assumed that A is already upper\n* triangular in rows and columns 1:ILO-1 and IHI+1:N.\n* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH, N)\n* On entry, the N-by-N upper Hessenberg matrix H.\n* On exit, if JOB = 'S', H contains the upper triangular\n* matrix S from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of H matches that of S, but\n* the rest of H is unspecified.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max( 1, N ).\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT, N)\n* On entry, the N-by-N upper triangular matrix T.\n* On exit, if JOB = 'S', T contains the upper triangular\n* matrix P from the generalized Schur factorization.\n* If JOB = 'E', the diagonal of T matches that of P, but\n* the rest of T is unspecified.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max( 1, N ).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* The complex scalars alpha that define the eigenvalues of\n* GNEP. ALPHA(i) = S(i,i) in the generalized Schur\n* factorization.\n*\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The real non-negative scalars beta that define the\n* eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized\n* Schur factorization.\n*\n* Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n* represent the j-th eigenvalue of the matrix pair (A,B), in\n* one of the forms lambda = alpha/beta or mu = beta/alpha.\n* Since either lambda or mu may overflow, they should not,\n* in general, be computed.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of left Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* left Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If COMPQ='V' or 'I', then LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n* reduction of (A,B) to generalized Hessenberg form.\n* On exit, if COMPZ = 'I', the unitary matrix of right Schur\n* vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n* right Schur vectors of (A,B).\n* Not referenced if COMPZ = 'N'.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If COMPZ='V' or 'I', then LDZ >= N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,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* RWORK (workspace) DOUBLE PRECISION 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* = 1,...,N: the QZ iteration did not converge. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO+1,...,N should be correct.\n* = N+1,...,2*N: the shift calculation failed. (H,T) is not\n* in Schur form, but ALPHA(i) and BETA(i),\n* i=INFO-N+1,...,N should be correct.\n*\n\n* Further Details\n* ===============\n*\n* We assume that complex ABS works as long as its value is less than\n* overflow.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_compz = argv[2];
- rb_ilo = argv[3];
- rb_ihi = argv[4];
- rb_h = argv[5];
- rb_t = argv[6];
- rb_q = argv[7];
- rb_z = argv[8];
- rb_lwork = argv[9];
-
- ilo = NUM2INT(rb_ilo);
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (8th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of z");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of z");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DCOMPLEX)
- rb_t = na_change_type(rb_t, NA_DCOMPLEX);
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- ihi = NUM2INT(rb_ihi);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublecomplex*);
- MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- rwork = ALLOC_N(doublereal, (n));
-
- zhgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alpha, beta, q, &ldq, z, &ldz, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_alpha, rb_beta, rb_work, rb_info, rb_h, rb_t, rb_q, rb_z);
-}
-
-void
-init_lapack_zhgeqz(VALUE mLapack){
- rb_define_module_function(mLapack, "zhgeqz", rb_zhgeqz, -1);
-}
diff --git a/zhpcon.c b/zhpcon.c
deleted file mode 100644
index 2dcc623..0000000
--- a/zhpcon.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpcon_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zhpcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zhpcon( uplo, ap, ipiv, anorm)\n or\n NumRu::Lapack.zhpcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPCON estimates the reciprocal of the condition number of a complex\n* Hermitian packed matrix A using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- work = ALLOC_N(doublecomplex, (2*n));
-
- zhpcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zhpcon(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpcon", rb_zhpcon, -1);
-}
diff --git a/zhpev.c b/zhpev.c
deleted file mode 100644
index d6e2511..0000000
--- a/zhpev.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpev_(char *jobz, char *uplo, integer *n, doublecomplex *ap, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhpev(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap = NumRu::Lapack.zhpev( jobz, uplo, ap)\n or\n NumRu::Lapack.zhpev # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n* complex Hermitian matrix in packed storage.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(doublecomplex, (MAX(1, 2*n-1)));
- rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
-
- zhpev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_z, rb_info, rb_ap);
-}
-
-void
-init_lapack_zhpev(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpev", rb_zhpev, -1);
-}
diff --git a/zhpevd.c b/zhpevd.c
deleted file mode 100644
index 02de18d..0000000
--- a/zhpevd.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpevd_(char *jobz, char *uplo, integer *n, doublecomplex *ap, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zhpevd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, work, rwork, iwork, info, ap = NumRu::Lapack.zhpevd( jobz, uplo, ap, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zhpevd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n* a complex Hermitian matrix A in packed storage. If eigenvectors are\n* desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n* eigenvectors of the matrix A, with the i-th column of Z\n* holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK must be at least 1.\n* If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n* If JOBZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: if INFO = i, the algorithm failed to converge; i\n* off-diagonal elements of an intermediate tridiagonal\n* form did not converge to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_jobz = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_lwork = argv[3];
- rb_lrwork = argv[4];
- rb_liwork = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zhpevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_w, rb_z, rb_work, rb_rwork, rb_iwork, rb_info, rb_ap);
-}
-
-void
-init_lapack_zhpevd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpevd", rb_zhpevd, -1);
-}
diff --git a/zhpevx.c b/zhpevx.c
deleted file mode 100644
index aa0c422..0000000
--- a/zhpevx.c
+++ /dev/null
@@ -1,125 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpevx_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *ap, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_zhpevx(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- doublecomplex *work;
- doublereal *rwork;
- integer *iwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap = NumRu::Lapack.zhpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol)\n or\n NumRu::Lapack.zhpevx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex Hermitian matrix A in packed storage.\n* Eigenvalues/vectors can be selected by specifying either a range of\n* values or a range of indices for the desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, AP is overwritten by values generated during the\n* reduction to tridiagonal form. If UPLO = 'U', the diagonal\n* and first superdiagonal of the tridiagonal matrix T overwrite\n* the corresponding elements of A, and if UPLO = 'L', the\n* diagonal and first subdiagonal of T overwrite the\n* corresponding elements of A.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* See \"Computing Small Singular Values of Bidiagonal Matrices\n* with Guaranteed High Relative Accuracy,\" by Demmel and\n* Kahan, LAPACK Working Note #3.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the selected eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and\n* the index of the eigenvector is returned in IFAIL.\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n* Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- il = NUM2INT(rb_il);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- zhpevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap);
-}
-
-void
-init_lapack_zhpevx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpevx", rb_zhpevx, -1);
-}
diff --git a/zhpgst.c b/zhpgst.c
deleted file mode 100644
index bf3b1e9..0000000
--- a/zhpgst.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpgst_(integer *itype, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, integer *info);
-
-static VALUE
-rb_zhpgst(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_bp;
- doublecomplex *bp;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zhpgst( itype, uplo, n, ap, bp)\n or\n NumRu::Lapack.zhpgst # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGST reduces a complex Hermitian-definite generalized\n* eigenproblem to standard form, using packed storage.\n*\n* If ITYPE = 1, the problem is A*x = lambda*B*x,\n* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n* B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n* = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored and B is factored as\n* U**H*U;\n* = 'L': Lower triangle of A is stored and B is factored as\n* L*L**H.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, if INFO = 0, the transformed matrix, stored in the\n* same format as A.\n*\n* BP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor from the Cholesky factorization of B,\n* stored in the same format as A, as returned by ZPPTRF.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- itype = NUM2INT(rb_itype);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_DCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zhpgst_(&itype, &uplo, &n, ap, bp, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_zhpgst(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpgst", rb_zhpgst, -1);
-}
diff --git a/zhpgv.c b/zhpgv.c
deleted file mode 100644
index e42bad2..0000000
--- a/zhpgv.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpgv_(integer *itype, char *jobz, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhpgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_bp;
- doublecomplex *bp;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- VALUE rb_bp_out__;
- doublecomplex *bp_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, info, ap, bp = NumRu::Lapack.zhpgv( itype, jobz, uplo, ap, bp)\n or\n NumRu::Lapack.zhpgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGV computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n* Here A and B are assumed to be Hermitian, stored in packed format,\n* and B is also positive definite.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPPTRF or ZHPEV returned an error code:\n* <= N: if INFO = i, ZHPEV failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEV, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_DCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, doublecomplex*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, doublecomplex*);
- MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(doublecomplex, (MAX(1, 2*n-1)));
- rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));
-
- zhpgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_z, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_zhpgv(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpgv", rb_zhpgv, -1);
-}
diff --git a/zhpgvd.c b/zhpgvd.c
deleted file mode 100644
index 3b4f3e1..0000000
--- a/zhpgvd.c
+++ /dev/null
@@ -1,133 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpgvd_(integer *itype, char *jobz, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zhpgvd(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_bp;
- doublecomplex *bp;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- VALUE rb_bp_out__;
- doublecomplex *bp_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldap;
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, z, iwork, info, ap, bp = NumRu::Lapack.zhpgvd( itype, jobz, uplo, ap, bp, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zhpgvd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite.\n* If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n* The divide and conquer algorithm makes very mild assumptions about\n* floating point arithmetic. It will work on machines with a guard\n* digit in add/subtract, or on those binary machines without guard\n* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n* Cray-2. It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, the eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n* eigenvectors. The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n* If JOBZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of array WORK.\n* If N <= 1, LWORK >= 1.\n* If JOBZ = 'N' and N > 1, LWORK >= N.\n* If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the required sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n* On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of array RWORK.\n* If N <= 1, LRWORK >= 1.\n* If JOBZ = 'N' and N > 1, LRWORK >= N.\n* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of array IWORK.\n* If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the required sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: ZPPTRF or ZHPEVD returned an error code:\n* <= N: if INFO = i, ZHPEVD failed to converge;\n* i off-diagonal elements of an intermediate\n* tridiagonal form did not convergeto zero;\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEVD, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_uplo = argv[2];
- rb_ap = argv[3];
- rb_bp = argv[4];
- rb_lwork = argv[5];
- rb_lrwork = argv[6];
- rb_liwork = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- jobz = StringValueCStr(rb_jobz)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- itype = NUM2INT(rb_itype);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_DCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, doublecomplex*);
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, doublecomplex*);
- MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
- rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
-
- zhpgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_w, rb_z, rb_iwork, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_zhpgvd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpgvd", rb_zhpgvd, -1);
-}
diff --git a/zhpgvx.c b/zhpgvx.c
deleted file mode 100644
index 8fcb652..0000000
--- a/zhpgvx.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpgvx_(integer *itype, char *jobz, char *range, char *uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, doublecomplex *work, doublereal *rwork, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_zhpgvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_itype;
- integer itype;
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_bp;
- doublecomplex *bp;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- VALUE rb_bp_out__;
- doublecomplex *bp_out__;
- doublecomplex *work;
- doublereal *rwork;
- integer *iwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, ifail, info, ap, bp = NumRu::Lapack.zhpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, ldz)\n or\n NumRu::Lapack.zhpgvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZHPGVX computes selected eigenvalues and, optionally, eigenvectors\n* of a complex generalized Hermitian-definite eigenproblem, of the form\n* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n* B are assumed to be Hermitian, stored in packed format, and B is also\n* positive definite. Eigenvalues and eigenvectors can be selected by\n* specifying either a range of values or a range of indices for the\n* desired eigenvalues.\n*\n\n* Arguments\n* =========\n*\n* ITYPE (input) INTEGER\n* Specifies the problem type to be solved:\n* = 1: A*x = (lambda)*B*x\n* = 2: A*B*x = (lambda)*x\n* = 3: B*A*x = (lambda)*x\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found;\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found;\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangles of A and B are stored;\n* = 'L': Lower triangles of A and B are stored.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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*\n* On exit, the contents of AP are destroyed.\n*\n* BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* B, packed columnwise in a linear array. The j-th column of B\n* is stored in the array BP as follows:\n* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n* On exit, the triangular factor U or L from the Cholesky\n* factorization B = U**H*U or B = L*L**H, in the same storage\n* format as B.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* The absolute error tolerance for the eigenvalues.\n* An approximate eigenvalue is accepted as converged\n* when it is determined to lie in an interval [a,b]\n* of width less than or equal to\n*\n* ABSTOL + EPS * max( |a|,|b| ) ,\n*\n* where EPS is the machine precision. If ABSTOL is less than\n* or equal to zero, then EPS*|T| will be used in its place,\n* where |T| is the 1-norm of the tridiagonal matrix obtained\n* by reducing AP to tridiagonal form.\n*\n* Eigenvalues will be computed most accurately when ABSTOL is\n* set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n* If this routine returns with INFO>0, indicating that some\n* eigenvectors did not converge, try setting ABSTOL to\n* 2*DLAMCH('S').\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* On normal exit, the first M elements contain the selected\n* eigenvalues in ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, N)\n* If JOBZ = 'N', then Z is not referenced.\n* If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix A\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* The eigenvectors are normalized as follows:\n* if ITYPE = 1 or 2, Z**H*B*Z = I;\n* if ITYPE = 3, Z**H*inv(B)*Z = I.\n*\n* If an eigenvector fails to converge, then that column of Z\n* contains the latest approximation to the eigenvector, and the\n* index of the eigenvector is returned in IFAIL.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n* IWORK (workspace) INTEGER array, dimension (5*N)\n*\n* IFAIL (output) INTEGER array, dimension (N)\n* If JOBZ = 'V', then if INFO = 0, the first M elements of\n* IFAIL are zero. If INFO > 0, then IFAIL contains the\n* indices of the eigenvectors that failed to converge.\n* If JOBZ = 'N', then IFAIL is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: ZPPTRF or ZHPEVX returned an error code:\n* <= N: if INFO = i, ZHPEVX failed to converge;\n* i eigenvectors failed to converge. Their indices\n* are stored in array IFAIL.\n* > N: if INFO = N + i, for 1 <= i <= n, then the leading\n* minor of order i of B is not positive definite.\n* The factorization of B could not be completed and\n* no eigenvalues or eigenvectors were computed.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEVX, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_itype = argv[0];
- rb_jobz = argv[1];
- rb_range = argv[2];
- rb_uplo = argv[3];
- rb_ap = argv[4];
- rb_bp = argv[5];
- rb_vl = argv[6];
- rb_vu = argv[7];
- rb_il = argv[8];
- rb_iu = argv[9];
- rb_abstol = argv[10];
- rb_ldz = argv[11];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- il = NUM2INT(rb_il);
- range = StringValueCStr(rb_range)[0];
- itype = NUM2INT(rb_itype);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- if (!NA_IsNArray(rb_bp))
- rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
- if (NA_RANK(rb_bp) != 1)
- rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_bp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_bp) != NA_DCOMPLEX)
- rb_bp = na_change_type(rb_bp, NA_DCOMPLEX);
- bp = NA_PTR_TYPE(rb_bp, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
- shape[1] = lsame_(&jobz,"N") ? 0 : n;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- bp_out__ = NA_PTR_TYPE(rb_bp_out__, doublecomplex*);
- MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rb_bp));
- rb_bp = rb_bp_out__;
- bp = bp_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (7*n));
- iwork = ALLOC_N(integer, (5*n));
-
- zhpgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_w, rb_z, rb_ifail, rb_info, rb_ap, rb_bp);
-}
-
-void
-init_lapack_zhpgvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpgvx", rb_zhpgvx, -1);
-}
diff --git a/zhprfs.c b/zhprfs.c
deleted file mode 100644
index 9d79d6d..0000000
--- a/zhprfs.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhprfs_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_afp;
- doublecomplex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zhprfs( uplo, ap, afp, ipiv, b, x)\n or\n NumRu::Lapack.zhprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**H or\n* A = L*D*L**H as computed by ZHPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZHPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_DCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zhprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zhprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zhprfs", rb_zhprfs, -1);
-}
diff --git a/zhpsv.c b/zhpsv.c
deleted file mode 100644
index 0da0983..0000000
--- a/zhpsv.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpsv_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zhpsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldb;
- integer nrhs;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.zhpsv( uplo, ap, b)\n or\n NumRu::Lapack.zhpsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is Hermitian and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZHPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZHPTRF, ZHPTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zhpsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_zhpsv(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpsv", rb_zhpsv, -1);
-}
diff --git a/zhpsvx.c b/zhpsvx.c
deleted file mode 100644
index bfa5377..0000000
--- a/zhpsvx.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhpsvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zhpsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_afp;
- doublecomplex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_afp_out__;
- doublecomplex *afp_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zhpsvx( fact, uplo, ap, afp, ipiv, b)\n or\n NumRu::Lapack.zhpsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n* A = L*D*L**H to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N Hermitian matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**H, if UPLO = 'U', or\n* A = L * D * L**H, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form of\n* A. AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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*\n* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZHPTRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_DCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, doublecomplex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, doublecomplex*);
- MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zhpsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_afp, rb_ipiv);
-}
-
-void
-init_lapack_zhpsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zhpsvx", rb_zhpsvx, -1);
-}
diff --git a/zhptrd.c b/zhptrd.c
deleted file mode 100644
index ea7fe33..0000000
--- a/zhptrd.c
+++ /dev/null
@@ -1,81 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhptrd_(char *uplo, integer *n, doublecomplex *ap, doublereal *d, doublereal *e, doublecomplex *tau, integer *info);
-
-static VALUE
-rb_zhptrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tau, info, ap = NumRu::Lapack.zhptrd( uplo, ap)\n or\n NumRu::Lapack.zhptrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRD reduces a complex Hermitian matrix A stored in packed form to\n* real symmetric tridiagonal form T by a unitary similarity\n* transformation: Q**H * A * Q = T.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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* On exit, if UPLO = 'U', the diagonal and first superdiagonal\n* of A are overwritten by the corresponding elements of the\n* tridiagonal matrix T, and the elements above the first\n* superdiagonal, with the array TAU, represent the unitary\n* matrix Q as a product of elementary reflectors; if UPLO\n* = 'L', the diagonal and first subdiagonal of A are over-\n* written by the corresponding elements of the tridiagonal\n* matrix T, and the elements below the first subdiagonal, with\n* the array TAU, represent the unitary matrix Q as a product\n* of elementary reflectors. See Further Details.\n*\n* D (output) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of the tridiagonal matrix T:\n* D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* The off-diagonal elements of the tridiagonal matrix T:\n* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors (see Further\n* Details).\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* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n-1) . . . H(2) H(1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(n-1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n* overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zhptrd_(&uplo, &n, ap, d, e, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_d, rb_e, rb_tau, rb_info, rb_ap);
-}
-
-void
-init_lapack_zhptrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zhptrd", rb_zhptrd, -1);
-}
diff --git a/zhptrf.c b/zhptrf.c
deleted file mode 100644
index 6a6b6cc..0000000
--- a/zhptrf.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhptrf_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, integer *info);
-
-static VALUE
-rb_zhptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.zhptrf( uplo, ap)\n or\n NumRu::Lapack.zhptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRF computes the factorization of a complex Hermitian packed\n* matrix A using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U**H or A = L*D*L**H\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is Hermitian and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zhptrf_(&uplo, &n, ap, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ap);
-}
-
-void
-init_lapack_zhptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zhptrf", rb_zhptrf, -1);
-}
diff --git a/zhptri.c b/zhptri.c
deleted file mode 100644
index a8e3d3a..0000000
--- a/zhptri.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhptri_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zhptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- doublecomplex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zhptri( uplo, ap, ipiv)\n or\n NumRu::Lapack.zhptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRI computes the inverse of a complex Hermitian indefinite matrix\n* A in packed storage using the factorization A = U*D*U**H or\n* A = L*D*L**H computed by ZHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZHPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (Hermitian) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* WORK (workspace) COMPLEX*16 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zhptri_(&uplo, &n, ap, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_zhptri(VALUE mLapack){
- rb_define_module_function(mLapack, "zhptri", rb_zhptri, -1);
-}
diff --git a/zhptrs.c b/zhptrs.c
deleted file mode 100644
index 3802144..0000000
--- a/zhptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhptrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zhptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zhptrs( uplo, ap, ipiv, b)\n or\n NumRu::Lapack.zhptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZHPTRS solves a system of linear equations A*X = B with a complex\n* Hermitian matrix A stored in packed format using the factorization\n* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**H;\n* = 'L': Lower triangular, form is A = L*D*L**H.\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* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHPTRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zhptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zhptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zhptrs", rb_zhptrs, -1);
-}
diff --git a/zhsein.c b/zhsein.c
deleted file mode 100644
index 64cd7b2..0000000
--- a/zhsein.c
+++ /dev/null
@@ -1,166 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhsein_(char *side, char *eigsrc, char *initv, logical *select, integer *n, doublecomplex *h, integer *ldh, doublecomplex *w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork, integer *ifaill, integer *ifailr, integer *info);
-
-static VALUE
-rb_zhsein(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_eigsrc;
- char eigsrc;
- VALUE rb_initv;
- char initv;
- VALUE rb_select;
- logical *select;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_ifaill;
- integer *ifaill;
- VALUE rb_ifailr;
- integer *ifailr;
- VALUE rb_info;
- integer info;
- VALUE rb_w_out__;
- doublecomplex *w_out__;
- VALUE rb_vl_out__;
- doublecomplex *vl_out__;
- VALUE rb_vr_out__;
- doublecomplex *vr_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldh;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.zhsein( side, eigsrc, initv, select, h, w, vl, vr)\n or\n NumRu::Lapack.zhsein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n* Purpose\n* =======\n*\n* ZHSEIN uses inverse iteration to find specified right and/or left\n* eigenvectors of a complex upper Hessenberg matrix H.\n*\n* The right eigenvector x and the left eigenvector y of the matrix H\n* corresponding to an eigenvalue w are defined by:\n*\n* H * x = w * x, y**h * H = w * y**h\n*\n* where y**h denotes the conjugate transpose of the vector y.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* EIGSRC (input) CHARACTER*1\n* Specifies the source of eigenvalues supplied in W:\n* = 'Q': the eigenvalues were found using ZHSEQR; thus, if\n* H has zero subdiagonal elements, and so is\n* block-triangular, then the j-th eigenvalue can be\n* assumed to be an eigenvalue of the block containing\n* the j-th row/column. This property allows ZHSEIN to\n* perform inverse iteration on just one diagonal block.\n* = 'N': no assumptions are made on the correspondence\n* between eigenvalues and diagonal blocks. In this\n* case, ZHSEIN must always perform inverse iteration\n* using the whole matrix H.\n*\n* INITV (input) CHARACTER*1\n* = 'N': no initial vectors are supplied;\n* = 'U': user-supplied initial vectors are stored in the arrays\n* VL and/or VR.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* Specifies the eigenvectors to be computed. To select the\n* eigenvector corresponding to the eigenvalue W(j),\n* SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX*16 array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the eigenvalues of H.\n* On exit, the real parts of W may have been altered since\n* close eigenvalues are perturbed slightly in searching for\n* independent eigenvectors.\n*\n* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n* contain starting vectors for the inverse iteration for the\n* left eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'L' or 'B', the left eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VL, in the same order as their eigenvalues.\n* If SIDE = 'R', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n* contain starting vectors for the inverse iteration for the\n* right eigenvectors; the starting vector for each eigenvector\n* must be in the same column in which the eigenvector will be\n* stored.\n* On exit, if SIDE = 'R' or 'B', the right eigenvectors\n* specified by SELECT will be stored consecutively in the\n* columns of VR, in the same order as their eigenvalues.\n* If SIDE = 'L', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR required to\n* store the eigenvectors (= the number of .TRUE. elements in\n* SELECT).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* IFAILL (output) INTEGER array, dimension (MM)\n* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n* eigenvector in the i-th column of VL (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'R', IFAILL is not referenced.\n*\n* IFAILR (output) INTEGER array, dimension (MM)\n* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n* eigenvector in the i-th column of VR (corresponding to the\n* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n* eigenvector converged satisfactorily.\n* If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n* failed to converge; see IFAILL and IFAILR for further\n* details.\n*\n\n* Further Details\n* ===============\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x|+|y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_eigsrc = argv[1];
- rb_initv = argv[2];
- rb_select = argv[3];
- rb_h = argv[4];
- rb_w = argv[5];
- rb_vl = argv[6];
- rb_vr = argv[7];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_DCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (6th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DCOMPLEX)
- rb_w = na_change_type(rb_w, NA_DCOMPLEX);
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- eigsrc = StringValueCStr(rb_eigsrc)[0];
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (8th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_DCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- initv = StringValueCStr(rb_initv)[0];
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of w");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 0 of w");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifaill = NA_PTR_TYPE(rb_ifaill, integer*);
- {
- int shape[1];
- shape[0] = mm;
- rb_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifailr = NA_PTR_TYPE(rb_ifailr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, doublecomplex*);
- MEMCPY(w_out__, w, doublecomplex, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublecomplex*);
- MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, doublecomplex*);
- MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(doublecomplex, (n*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zhsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, w, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, ifaill, ifailr, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_m, rb_ifaill, rb_ifailr, rb_info, rb_w, rb_vl, rb_vr);
-}
-
-void
-init_lapack_zhsein(VALUE mLapack){
- rb_define_module_function(mLapack, "zhsein", rb_zhsein, -1);
-}
diff --git a/zhseqr.c b/zhseqr.c
deleted file mode 100644
index 08a977b..0000000
--- a/zhseqr.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zhseqr_(char *job, char *compz, integer *n, integer *ilo, integer *ihi, doublecomplex *h, integer *ldh, doublecomplex *w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zhseqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compz;
- char compz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.zhseqr( job, compz, ilo, ihi, h, z, ldz, lwork)\n or\n NumRu::Lapack.zhseqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZHSEQR computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* = 'E': compute eigenvalues only;\n* = 'S': compute eigenvalues and the Schur form T.\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': no Schur vectors are computed;\n* = 'I': Z is initialized to the unit matrix and the matrix Z\n* of Schur vectors of H is returned;\n* = 'V': Z must contain an unitary matrix Q on entry, and\n* the product Q*Z is returned.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n* set by a previous call to ZGEBAL, and then passed to ZGEHRD\n* when the matrix output by ZGEBAL is reduced to Hessenberg\n* form. Otherwise ILO and IHI should be set to 1 and N\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and JOB = 'S', H contains the upper\n* triangular matrix T from the Schur decomposition (the\n* Schur form). If INFO = 0 and JOB = 'E', the contents of\n* H are unspecified on exit. (The output value of H when\n* INFO.GT.0 is given under the description of INFO below.)\n*\n* Unlike earlier versions of ZHSEQR, this subroutine may\n* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n* or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues. If JOB = 'S', the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If COMPZ = 'N', Z is not referenced.\n* If COMPZ = 'I', on entry Z need not be set and on exit,\n* if INFO = 0, Z contains the unitary matrix Z of the Schur\n* vectors of H. If COMPZ = 'V', on entry Z must contain an\n* N-by-N matrix Q, which is assumed to be equal to the unit\n* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n* if INFO = 0, Z contains Q*Z.\n* Normally Q is the unitary matrix generated by ZUNGHR\n* after the call to ZGEHRD which formed the Hessenberg matrix\n* H. (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if COMPZ = 'I' or\n* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient and delivers very good and sometimes\n* optimal performance. However, LWORK as large as 11*N\n* may be required for optimal performance. A workspace\n* query is recommended to determine the optimal workspace\n* size.\n*\n* If LWORK = -1, then ZHSEQR does a workspace query.\n* In this case, ZHSEQR checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .LT. 0: if INFO = -i, the i-th argument had an illegal\n* value\n* .GT. 0: if INFO = i, ZHSEQR failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and JOB = 'E', then on exit, the\n* remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and JOB = 'S', then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n* (final value of Z) = (initial value of Z)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'I', then on exit\n* (final value of Z) = U\n* where U is the unitary matrix in (*) (regard-\n* less of the value of JOB.)\n*\n* If INFO .GT. 0 and COMPZ = 'N', then Z is not\n* accessed.\n*\n\n* ================================================================\n* Default values supplied by\n* ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n* It is suggested that these defaults be adjusted in order\n* to attain best performance in each particular\n* computational environment.\n*\n* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.\n* Default: 75. (Must be at least 11.)\n*\n* ISPEC=13: Recommended deflation window size.\n* This depends on ILO, IHI and NS. NS is the\n* number of simultaneous shifts returned\n* by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n* The default for (IHI-ILO+1).LE.500 is NS.\n* The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n* ISPEC=14: Nibble crossover point. (See IPARMQ for\n* details.) Default: 14% of deflation window\n* size.\n*\n* ISPEC=15: Number of simultaneous shifts in a multishift\n* QR iteration.\n*\n* If IHI-ILO+1 is ...\n*\n* greater than ...but less ... the\n* or equal to ... than default is\n*\n* 1 30 NS = 2(+)\n* 30 60 NS = 4(+)\n* 60 150 NS = 10(+)\n* 150 590 NS = **\n* 590 3000 NS = 64\n* 3000 6000 NS = 128\n* 6000 infinity NS = 256\n*\n* (+) By default some or all matrices of this order\n* are passed to the implicit double shift routine\n* ZLAHQR and this parameter is ignored. See\n* ISPEC=12 above and comments in IPARMQ for\n* details.\n*\n* (**) The asterisks (**) indicate an ad-hoc\n* function of N increasing from 10 to 64.\n*\n* ISPEC=16: Select structured matrix multiply.\n* If the number of simultaneous shifts (specified\n* by ISPEC=15) is less than 14, then the default\n* for ISPEC=16 is 0. Otherwise the default for\n* ISPEC=16 is 2.\n*\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_compz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_z = argv[5];
- rb_ldz = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- ldz = NUM2INT(rb_ldz);
- compz = StringValueCStr(rb_compz)[0];
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (lsame_(&compz,"N") ? 0 : n))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
- if (NA_SHAPE0(rb_z) != (lsame_(&compz,"N") ? 0 : ldz))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = lsame_(&compz,"N") ? 0 : ldz;
- shape[1] = lsame_(&compz,"N") ? 0 : n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- zhseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, w, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_zhseqr(VALUE mLapack){
- rb_define_module_function(mLapack, "zhseqr", rb_zhseqr, -1);
-}
diff --git a/zla_gbamv.c b/zla_gbamv.c
deleted file mode 100644
index d341007..0000000
--- a/zla_gbamv.c
+++ /dev/null
@@ -1,109 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_gbamv_(integer *trans, integer *m, integer *n, integer *kl, integer *ku, doublereal *alpha, doublereal *ab, integer *ldab, doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy);
-
-static VALUE
-rb_zla_gbamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb_m;
- integer m;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_ab;
- doublereal *ab;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy)\n or\n NumRu::Lapack.zla_gbamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* DLA_GBAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X (input) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_alpha = argv[4];
- rb_ab = argv[5];
- rb_x = argv[6];
- rb_incx = argv[7];
- rb_beta = argv[8];
- rb_y = argv[9];
- rb_incy = argv[10];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (MAX(1, m)))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", MAX(1, m));
- if (NA_TYPE(rb_ab) != NA_DFLOAT)
- rb_ab = na_change_type(rb_ab, NA_DFLOAT);
- ab = NA_PTR_TYPE(rb_ab, doublereal*);
- kl = NUM2INT(rb_kl);
- trans = NUM2INT(rb_trans);
- m = NUM2INT(rb_m);
- ku = NUM2INT(rb_ku);
- beta = NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- alpha = NUM2DBL(rb_alpha);
- incx = NUM2INT(rb_incx);
- ldab = MAX(1, m);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (10th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_zla_gbamv(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gbamv", rb_zla_gbamv, -1);
-}
diff --git a/zla_gbrcond_c.c b/zla_gbrcond_c.c
deleted file mode 100644
index f1f5c8e..0000000
--- a/zla_gbrcond_c.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_gbrcond_c_(char *trans, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, integer *ipiv, doublereal *c, logical *capply, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_gbrcond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.zla_gbrcond_c # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GBRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_c = argv[6];
- rb_capply = argv[7];
- rb_work = argv[8];
- rb_rwork = argv[9];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (10th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (9th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_gbrcond_c_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_gbrcond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gbrcond_c", rb_zla_gbrcond_c, -1);
-}
diff --git a/zla_gbrcond_x.c b/zla_gbrcond_x.c
deleted file mode 100644
index a6363bb..0000000
--- a/zla_gbrcond_x.c
+++ /dev/null
@@ -1,119 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_gbrcond_x_(char *trans, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_gbrcond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork)\n or\n NumRu::Lapack.zla_gbrcond_x # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GBRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGBTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_ipiv = argv[5];
- rb_x = argv[6];
- rb_work = argv[7];
- rb_rwork = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of ipiv");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (9th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (8th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_gbrcond_x_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_gbrcond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gbrcond_x", rb_zla_gbrcond_x, -1);
-}
diff --git a/zla_gbrfsx_extended.c b/zla_gbrfsx_extended.c
deleted file mode 100644
index bc1ac56..0000000
--- a/zla_gbrfsx_extended.c
+++ /dev/null
@@ -1,278 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_gbrfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, integer *ipiv, logical *colequ, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *err_bnds_norm, doublereal *err_bnds_comp, doublecomplex *res, doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_zla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_res;
- doublecomplex *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublecomplex *dy;
- VALUE rb_y_tail;
- doublecomplex *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- doublereal *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- doublereal *err_bnds_comp_out__;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.zla_gbrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_GBRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZGBRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* AB (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGBTRF.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGBTRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZGBTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZGBTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 23)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 23)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_kl = argv[2];
- rb_ku = argv[3];
- rb_ab = argv[4];
- rb_afb = argv[5];
- rb_ipiv = argv[6];
- rb_colequ = argv[7];
- rb_c = argv[8];
- rb_b = argv[9];
- rb_y = argv[10];
- rb_n_norms = argv[11];
- rb_err_bnds_norm = argv[12];
- rb_err_bnds_comp = argv[13];
- rb_res = argv[14];
- rb_ayb = argv[15];
- rb_dy = argv[16];
- rb_y_tail = argv[17];
- rb_rcond = argv[18];
- rb_ithresh = argv[19];
- rb_rthresh = argv[20];
- rb_dz_ub = argv[21];
- rb_ignore_cwise = argv[22];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (15th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (15th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DCOMPLEX)
- rb_res = na_change_type(rb_res, NA_DCOMPLEX);
- res = NA_PTR_TYPE(rb_res, doublecomplex*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of res");
- ldab = NA_SHAPE0(rb_ab);
- if (ldab != (ldab = MAX(1,n)))
- rb_raise(rb_eRuntimeError, "shape 0 of ab must be %d", ldab = MAX(1,n));
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (10th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (11th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (18th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_DCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublecomplex*);
- ku = NUM2INT(rb_ku);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (13th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (13th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_norm);
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_DFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_DFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- n_norms = NUM2INT(rb_n_norms);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (14th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_comp) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_DFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_DFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 0 of res");
- ldafb = NA_SHAPE0(rb_afb);
- if (ldafb != (ldafb = MAX(1,n)))
- rb_raise(rb_eRuntimeError, "shape 0 of afb must be %d", ldafb = MAX(1,n));
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (17th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (17th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_DCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, doublecomplex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (16th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- prec_type = NUM2INT(rb_prec_type);
- ldab = ldab = MAX(1,n);
- ldafb = ldafb = MAX(1,n);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, doublereal*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, doublereal*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- zla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_zla_gbrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gbrfsx_extended", rb_zla_gbrfsx_extended, -1);
-}
diff --git a/zla_gbrpvgrw.c b/zla_gbrpvgrw.c
deleted file mode 100644
index 6c7e5e1..0000000
--- a/zla_gbrpvgrw.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_gbrpvgrw_(integer *n, integer *kl, integer *ku, integer *ncols, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb);
-
-static VALUE
-rb_zla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb___out__;
- doublereal __out__;
-
- integer ldab;
- integer n;
- integer ldafb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_gbrpvgrw( kl, ku, ncols, ab, afb)\n or\n NumRu::Lapack.zla_gbrpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n* Purpose\n* =======\n*\n* ZLA_GBRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* Details of the LU factorization of the band matrix A, as\n* computed by ZGBTRF. U is stored as an upper triangular\n* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n* and the multipliers used during the factorization are stored\n* in rows KL+KU+2 to 2*KL+KU+1.\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J, KD\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ncols = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- ku = NUM2INT(rb_ku);
-
- __out__ = zla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zla_gbrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gbrpvgrw", rb_zla_gbrpvgrw, -1);
-}
diff --git a/zla_geamv.c b/zla_geamv.c
deleted file mode 100644
index f842ad3..0000000
--- a/zla_geamv.c
+++ /dev/null
@@ -1,101 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_geamv_(integer *trans, integer *m, integer *n, doublereal *alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal *beta, doublereal *y, integer *incy);
-
-static VALUE
-rb_zla_geamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- integer trans;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_x;
- doublereal *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_geamv( trans, m, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.zla_geamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZLA_GEAMV performs one of the matrix-vector operations\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n* or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* m by n matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* TRANS (input) INTEGER\n* On entry, TRANS specifies the operation to be performed as\n* follows:\n*\n* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of the matrix A.\n* M must be at least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX*16 array of DIMENSION ( LDA, n )\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n* X - COMPLEX*16 array of DIMENSION at least\n* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n* and at least\n* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n*\n* Level 2 Blas routine.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_a = argv[3];
- rb_x = argv[4];
- rb_incx = argv[5];
- rb_beta = argv[6];
- rb_y = argv[7];
- rb_incy = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1, m)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, m));
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- trans = NUM2INT(rb_trans);
- m = NUM2INT(rb_m);
- alpha = NUM2DBL(rb_alpha);
- beta = NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1, m);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (lsame_(&trans,"N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", lsame_(&trans,"N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DFLOAT)
- rb_x = na_change_type(rb_x, NA_DFLOAT);
- x = NA_PTR_TYPE(rb_x, doublereal*);
- {
- int shape[1];
- shape[0] = ((lsame_(&trans,"N")) || (lsame_(&trans,"n"))) ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_zla_geamv(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_geamv", rb_zla_geamv, -1);
-}
diff --git a/zla_gercond_c.c b/zla_gercond_c.c
deleted file mode 100644
index db55088..0000000
--- a/zla_gercond_c.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_gercond_c_(char *trans, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c, logical *capply, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_gercond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.zla_gercond_c # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_c = argv[4];
- rb_capply = argv[5];
- rb_work = argv[6];
- rb_rwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_gercond_c_(&trans, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_gercond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gercond_c", rb_zla_gercond_c, -1);
-}
diff --git a/zla_gercond_x.c b/zla_gercond_x.c
deleted file mode 100644
index e9d91ba..0000000
--- a/zla_gercond_x.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_gercond_x_(char *trans, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_gercond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_gercond_x( trans, a, af, ipiv, x, work, rwork)\n or\n NumRu::Lapack.zla_gercond_x # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_GERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\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 number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZGETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_trans = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_x = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_gercond_x_(&trans, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_gercond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gercond_x", rb_zla_gercond_x, -1);
-}
diff --git a/zla_gerfsx_extended.c b/zla_gerfsx_extended.c
deleted file mode 100644
index e2501d0..0000000
--- a/zla_gerfsx_extended.c
+++ /dev/null
@@ -1,263 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_gerfsx_extended_(integer *prec_type, integer *trans_type, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *errs_n, doublereal *errs_c, doublecomplex *res, doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_zla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_trans_type;
- integer trans_type;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_errs_n;
- doublereal *errs_n;
- VALUE rb_errs_c;
- doublereal *errs_c;
- VALUE rb_res;
- doublecomplex *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublecomplex *dy;
- VALUE rb_y_tail;
- doublecomplex *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
- VALUE rb_errs_n_out__;
- doublereal *errs_n_out__;
- VALUE rb_errs_c_out__;
- doublereal *errs_c_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_norms;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, errs_n, errs_c = NumRu::Lapack.zla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.zla_gerfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_GERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZGERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* TRANS_TYPE (input) INTEGER\n* Specifies the transposition operation on A.\n* The value is defined by ILATRANS(T) where T is a CHARACTER and\n* T = 'N': No transpose\n* = 'T': Transpose\n* = 'C': Conjugate transpose\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* The pivot indices from the factorization A = P*L*U\n* as computed by ZGETRF; row i of the matrix was interchanged\n* with row IPIV(i).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZGETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZGETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 20)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
- rb_prec_type = argv[0];
- rb_trans_type = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_errs_n = argv[9];
- rb_errs_c = argv[10];
- rb_res = argv[11];
- rb_ayb = argv[12];
- rb_dy = argv[13];
- rb_y_tail = argv[14];
- rb_rcond = argv[15];
- rb_ithresh = argv[16];
- rb_rthresh = argv[17];
- rb_dz_ub = argv[18];
- rb_ignore_cwise = argv[19];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (12th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DCOMPLEX)
- rb_res = na_change_type(rb_res, NA_DCOMPLEX);
- res = NA_PTR_TYPE(rb_res, doublecomplex*);
- if (!NA_IsNArray(rb_errs_c))
- rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
- if (NA_RANK(rb_errs_c) != 2)
- rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
- n_norms = NA_SHAPE1(rb_errs_c);
- if (n_norms != (3))
- rb_raise(rb_eRuntimeError, "shape 1 of errs_c must be %d", 3);
- nrhs = NA_SHAPE0(rb_errs_c);
- if (NA_TYPE(rb_errs_c) != NA_DFLOAT)
- rb_errs_c = na_change_type(rb_errs_c, NA_DFLOAT);
- errs_c = NA_PTR_TYPE(rb_errs_c, doublereal*);
- if (!NA_IsNArray(rb_errs_n))
- rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
- if (NA_RANK(rb_errs_n) != 2)
- rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_errs_n) != n_norms)
- rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be the same as shape 1 of errs_c");
- if (NA_SHAPE0(rb_errs_n) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 0 of errs_c");
- if (NA_TYPE(rb_errs_n) != NA_DFLOAT)
- rb_errs_n = na_change_type(rb_errs_n, NA_DFLOAT);
- errs_n = NA_PTR_TYPE(rb_errs_n, doublereal*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of errs_c");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 0 of errs_c");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_DCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- trans_type = NUM2INT(rb_trans_type);
- n_norms = 3;
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_DCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, doublecomplex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_errs_n_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- errs_n_out__ = NA_PTR_TYPE(rb_errs_n_out__, doublereal*);
- MEMCPY(errs_n_out__, errs_n, doublereal, NA_TOTAL(rb_errs_n));
- rb_errs_n = rb_errs_n_out__;
- errs_n = errs_n_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_norms;
- rb_errs_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- errs_c_out__ = NA_PTR_TYPE(rb_errs_c_out__, doublereal*);
- MEMCPY(errs_c_out__, errs_c, doublereal, NA_TOTAL(rb_errs_c));
- rb_errs_c = rb_errs_c_out__;
- errs_c = errs_c_out__;
-
- zla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_errs_n, rb_errs_c);
-}
-
-void
-init_lapack_zla_gerfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_gerfsx_extended", rb_zla_gerfsx_extended, -1);
-}
diff --git a/zla_heamv.c b/zla_heamv.c
deleted file mode 100644
index 340806e..0000000
--- a/zla_heamv.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_heamv_(integer *uplo, integer *n, doublereal *alpha, doublereal *a, integer *lda, doublecomplex *x, integer *incx, doublereal *beta, doublereal *y, integer *incy);
-
-static VALUE
-rb_zla_heamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- integer uplo;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_heamv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.zla_heamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX*16 array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X - COMPLEX*16 array of DIMENSION at least\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1, n)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = NUM2INT(rb_uplo);
- alpha = NUM2DBL(rb_alpha);
- beta = NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1, n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + (n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + (n-1)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zla_heamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_zla_heamv(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_heamv", rb_zla_heamv, -1);
-}
diff --git a/zla_hercond_c.c b/zla_hercond_c.c
deleted file mode 100644
index d631f9a..0000000
--- a/zla_hercond_c.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_hercond_c_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c, logical *capply, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_hercond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.zla_hercond_c # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_HERCOND_C computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_c = argv[4];
- rb_capply = argv[5];
- rb_work = argv[6];
- rb_rwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_hercond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_hercond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_hercond_c", rb_zla_hercond_c, -1);
-}
diff --git a/zla_hercond_x.c b/zla_hercond_x.c
deleted file mode 100644
index a16a189..0000000
--- a/zla_hercond_x.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_hercond_x_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_hercond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_hercond_x( uplo, a, af, ipiv, x, work, rwork)\n or\n NumRu::Lapack.zla_hercond_x # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_HERCOND_X computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by CHETRF.\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZHETRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_x = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_hercond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_hercond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_hercond_x", rb_zla_hercond_x, -1);
-}
diff --git a/zla_herfsx_extended.c b/zla_herfsx_extended.c
deleted file mode 100644
index d0467d1..0000000
--- a/zla_herfsx_extended.c
+++ /dev/null
@@ -1,264 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_herfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *err_bnds_norm, doublereal *err_bnds_comp, doublecomplex *res, doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_zla_herfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_res;
- doublecomplex *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublecomplex *dy;
- VALUE rb_y_tail;
- doublecomplex *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- doublereal *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- doublereal *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.zla_herfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_HERFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZHERFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZHETRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZHETRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_n_norms = argv[9];
- rb_err_bnds_norm = argv[10];
- rb_err_bnds_comp = argv[11];
- rb_res = argv[12];
- rb_ayb = argv[13];
- rb_dy = argv[14];
- rb_y_tail = argv[15];
- rb_rcond = argv[16];
- rb_ithresh = argv[17];
- rb_rthresh = argv[18];
- rb_dz_ub = argv[19];
- rb_ignore_cwise = argv[20];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (13th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DCOMPLEX)
- rb_res = na_change_type(rb_res, NA_DCOMPLEX);
- res = NA_PTR_TYPE(rb_res, doublecomplex*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_DCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_DFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_DFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_DCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, doublecomplex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_DFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_DFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, doublereal*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, doublereal*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- zla_herfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_zla_herfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_herfsx_extended", rb_zla_herfsx_extended, -1);
-}
diff --git a/zla_herpvgrw.c b/zla_herpvgrw.c
deleted file mode 100644
index 9d07756..0000000
--- a/zla_herpvgrw.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_herpvgrw_(char *uplo, integer *n, integer *info, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *work);
-
-static VALUE
-rb_zla_herpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_info;
- integer info;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_herpvgrw( uplo, info, a, af, ipiv, work)\n or\n NumRu::Lapack.zla_herpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* ZLA_HERPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from ZHETRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZHETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZHETRF.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER, LSAME\n COMPLEX*16 ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, ZLASET\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX, MIN\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_info = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_work = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- info = NUM2INT(rb_info);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_herpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zla_herpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_herpvgrw", rb_zla_herpvgrw, -1);
-}
diff --git a/zla_lin_berr.c b/zla_lin_berr.c
deleted file mode 100644
index 8c04480..0000000
--- a/zla_lin_berr.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_lin_berr_(integer *n, integer *nz, integer *nrhs, doublereal *res, doublereal *ayb, doublecomplex *berr);
-
-static VALUE
-rb_zla_lin_berr(int argc, VALUE *argv, VALUE self){
- VALUE rb_nz;
- integer nz;
- VALUE rb_res;
- doublereal *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_berr;
- doublecomplex *berr;
-
- integer n;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr = NumRu::Lapack.zla_lin_berr( nz, res, ayb)\n or\n NumRu::Lapack.zla_lin_berr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n* Purpose\n* =======\n*\n* ZLA_LIN_BERR computes componentwise relative backward error from\n* the formula\n* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z.\n*\n\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NZ (input) INTEGER\n* We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n* guard against spuriously zero residuals. Default value is N.\n*\n* NRHS (input) INTEGER\n* The number of right hand sides, i.e., the number of columns\n* of the matrices AYB, RES, and BERR. NRHS >= 0.\n*\n* RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n* The residual matrix, i.e., the matrix R in the relative backward\n* error formula above.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n* The denominator in the relative backward error formula above, i.e.,\n* the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n* are from iterative refinement (see zla_gerfsx_extended.f).\n* \n* BERR (output) COMPLEX*16 array, dimension (NRHS)\n* The componentwise relative backward error from the formula above.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION TMP\n INTEGER I, J\n COMPLEX*16 CDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX\n* ..\n* .. External Functions ..\n EXTERNAL DLAMCH\n DOUBLE PRECISION DLAMCH\n DOUBLE PRECISION SAFE1\n* ..\n* .. Statement Functions ..\n COMPLEX*16 CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_nz = argv[0];
- rb_res = argv[1];
- rb_ayb = argv[2];
-
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (2th argument) must be NArray");
- if (NA_RANK(rb_res) != 2)
- rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_res);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DFLOAT)
- rb_res = na_change_type(rb_res, NA_DFLOAT);
- res = NA_PTR_TYPE(rb_res, doublereal*);
- nz = NUM2INT(rb_nz);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 2)
- rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ayb) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of ayb must be the same as shape 1 of res");
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublecomplex*);
-
- zla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);
-
- return rb_berr;
-}
-
-void
-init_lapack_zla_lin_berr(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_lin_berr", rb_zla_lin_berr, -1);
-}
diff --git a/zla_porcond_c.c b/zla_porcond_c.c
deleted file mode 100644
index e19098e..0000000
--- a/zla_porcond_c.c
+++ /dev/null
@@ -1,103 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_porcond_c_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, doublereal *c, logical *capply, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_porcond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_porcond_c( uplo, a, af, c, capply, work, rwork)\n or\n NumRu::Lapack.zla_porcond_c # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_PORCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_c = argv[3];
- rb_capply = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of a");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_porcond_c_(&uplo, &n, a, &lda, af, &ldaf, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_porcond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_porcond_c", rb_zla_porcond_c, -1);
-}
diff --git a/zla_porcond_x.c b/zla_porcond_x.c
deleted file mode 100644
index 618672e..0000000
--- a/zla_porcond_x.c
+++ /dev/null
@@ -1,99 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_porcond_x_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, doublecomplex *x, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_porcond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_porcond_x( uplo, a, af, x, work, rwork)\n or\n NumRu::Lapack.zla_porcond_x # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_PORCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZPOTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_x = argv[3];
- rb_work = argv[4];
- rb_rwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (6th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of a");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (5th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_porcond_x_(&uplo, &n, a, &lda, af, &ldaf, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_porcond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_porcond_x", rb_zla_porcond_x, -1);
-}
diff --git a/zla_porfsx_extended.c b/zla_porfsx_extended.c
deleted file mode 100644
index 32f6c55..0000000
--- a/zla_porfsx_extended.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_porfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, logical *colequ, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *err_bnds_norm, doublereal *err_bnds_comp, doublecomplex *res, doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_zla_porfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_res;
- doublecomplex *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublecomplex *dy;
- VALUE rb_y_tail;
- doublecomplex *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- doublereal *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- doublereal *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.zla_porfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_PORFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZPORFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZPOTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 PRECISION array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZPOTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 20)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_colequ = argv[4];
- rb_c = argv[5];
- rb_b = argv[6];
- rb_y = argv[7];
- rb_n_norms = argv[8];
- rb_err_bnds_norm = argv[9];
- rb_err_bnds_comp = argv[10];
- rb_res = argv[11];
- rb_ayb = argv[12];
- rb_dy = argv[13];
- rb_y_tail = argv[14];
- rb_rcond = argv[15];
- rb_ithresh = argv[16];
- rb_rthresh = argv[17];
- rb_dz_ub = argv[18];
- rb_ignore_cwise = argv[19];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (12th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DCOMPLEX)
- rb_res = na_change_type(rb_res, NA_DCOMPLEX);
- res = NA_PTR_TYPE(rb_res, doublecomplex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_DCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_DFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_DFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_DCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, doublecomplex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_DFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_DFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, doublereal*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, doublereal*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- zla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_zla_porfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_porfsx_extended", rb_zla_porfsx_extended, -1);
-}
diff --git a/zla_porpvgrw.c b/zla_porpvgrw.c
deleted file mode 100644
index 7c1992b..0000000
--- a/zla_porpvgrw.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_porpvgrw_(char *uplo, integer *ncols, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, doublecomplex *work);
-
-static VALUE
-rb_zla_porpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_porpvgrw( uplo, ncols, a, af, work)\n or\n NumRu::Lapack.zla_porpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n* Purpose\n* =======\n* \n* ZLA_PORPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n COMPLEX*16 ZDUM\n* ..\n* .. External Functions ..\n EXTERNAL LSAME, ZLASET\n LOGICAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ncols = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_work = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ncols = NUM2INT(rb_ncols);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (5th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zla_porpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_porpvgrw", rb_zla_porpvgrw, -1);
-}
diff --git a/zla_rpvgrw.c b/zla_rpvgrw.c
deleted file mode 100644
index fdfd371..0000000
--- a/zla_rpvgrw.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_rpvgrw_(integer *n, integer *ncols, doublereal *a, integer *lda, doublereal *af, integer *ldaf);
-
-static VALUE
-rb_zla_rpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_ncols;
- integer ncols;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_af;
- doublereal *af;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_rpvgrw( ncols, a, af)\n or\n NumRu::Lapack.zla_rpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n* Purpose\n* =======\n* \n* ZLA_RPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n* The factors L and U from the factorization\n* A = P*L*U as computed by ZGETRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN, ABS, REAL, DIMAG\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_ncols = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ncols = NUM2INT(rb_ncols);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DFLOAT)
- rb_af = na_change_type(rb_af, NA_DFLOAT);
- af = NA_PTR_TYPE(rb_af, doublereal*);
-
- __out__ = zla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zla_rpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_rpvgrw", rb_zla_rpvgrw, -1);
-}
diff --git a/zla_syamv.c b/zla_syamv.c
deleted file mode 100644
index 9e6ead6..0000000
--- a/zla_syamv.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_syamv_(integer *uplo, integer *n, doublereal *alpha, doublereal *a, integer *lda, doublecomplex *x, integer *incx, doublereal *beta, doublereal *y, integer *incy);
-
-static VALUE
-rb_zla_syamv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- integer uplo;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_y;
- doublereal *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublereal *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.zla_syamv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.zla_syamv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZLA_SYAMV performs the matrix-vector operation\n*\n* y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n* where alpha and beta are scalars, x and y are vectors and A is an\n* n by n symmetric matrix.\n*\n* This function is primarily used in calculating error bounds.\n* To protect against underflow during evaluation, components in\n* the resulting vector are perturbed away from zero by (N+1)\n* times the underflow threshold. To prevent unnecessarily large\n* errors for block-structure embedded in general matrices,\n* \"symbolically\" zero components are not perturbed. A zero\n* entry is considered \"symbolic\" if all multiplications involved\n* in computing that entry have at least one zero multiplicand.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) INTEGER\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = BLAS_UPPER Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = BLAS_LOWER Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA - DOUBLE PRECISION .\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A - COMPLEX*16 array of DIMENSION ( LDA, n ).\n* Before entry, the leading m by n part of the array A must\n* contain the matrix of coefficients.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, n ).\n* Unchanged on exit.\n*\n* X - COMPLEX*16 array of DIMENSION at least\n* ( 1 + ( n - 1 )*abs( INCX ) )\n* Before entry, the incremented array X must contain the\n* vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA - DOUBLE PRECISION .\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) DOUBLE PRECISION array, dimension\n* ( 1 + ( n - 1 )*abs( INCY ) )\n* Before entry with BETA non-zero, the incremented array Y\n* must contain the vector y. On exit, Y is overwritten by the\n* updated vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* Level 2 Blas routine.\n*\n* -- Written on 22-October-1986.\n* Jack Dongarra, Argonne National Lab.\n* Jeremy Du Croz, Nag Central Office.\n* Sven Hammarling, Nag Central Office.\n* Richard Hanson, Sandia National Labs.\n* -- Modified for the absolute-value product, April 2006\n* Jason Riedy, UC Berkeley\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (lda != (MAX(1, n)))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- uplo = NUM2INT(rb_uplo);
- alpha = NUM2DBL(rb_alpha);
- beta = NUM2DBL(rb_beta);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- lda = MAX(1, n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DFLOAT)
- rb_y = na_change_type(rb_y, NA_DFLOAT);
- y = NA_PTR_TYPE(rb_y, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublereal*);
- MEMCPY(y_out__, y, doublereal, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_zla_syamv(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_syamv", rb_zla_syamv, -1);
-}
diff --git a/zla_syrcond_c.c b/zla_syrcond_c.c
deleted file mode 100644
index fd12b73..0000000
--- a/zla_syrcond_c.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_syrcond_c_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c, logical *capply, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_syrcond_c(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_capply;
- logical capply;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork)\n or\n NumRu::Lapack.zla_syrcond_c # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_SYRCOND_C Computes the infinity norm condition number of\n* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The vector C in the formula op(A) * inv(diag(C)).\n*\n* CAPPLY (input) LOGICAL\n* If .TRUE. then access the vector C in the formula above.\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_c = argv[4];
- rb_capply = argv[5];
- rb_work = argv[6];
- rb_rwork = argv[7];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- capply = (rb_capply == Qtrue);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (7th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_syrcond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_syrcond_c(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_syrcond_c", rb_zla_syrcond_c, -1);
-}
diff --git a/zla_syrcond_x.c b/zla_syrcond_x.c
deleted file mode 100644
index bba40c7..0000000
--- a/zla_syrcond_x.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_syrcond_x_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work, doublereal *rwork);
-
-static VALUE
-rb_zla_syrcond_x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_info;
- integer info;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, __out__ = NumRu::Lapack.zla_syrcond_x( uplo, a, af, ipiv, x, work, rwork)\n or\n NumRu::Lapack.zla_syrcond_x # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n* Purpose\n* =======\n*\n* ZLA_SYRCOND_X Computes the infinity norm condition number of\n* op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector X in the formula op(A) * diag(X).\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* i > 0: The ith argument is invalid.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N).\n* Workspace.\n*\n* RWORK (input) DOUBLE PRECISION array, dimension (N).\n* Workspace.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n* ..\n* .. Local Arrays ..\n INTEGER ISAVE( 3 )\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZLACN2, ZSYTRS, XERBLA\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_x = argv[4];
- rb_work = argv[5];
- rb_rwork = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- if (!NA_IsNArray(rb_rwork))
- rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
- if (NA_RANK(rb_rwork) != 1)
- rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rwork) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rwork) != NA_DFLOAT)
- rb_rwork = na_change_type(rb_rwork, NA_DFLOAT);
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_syrcond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);
-
- rb_info = INT2NUM(info);
- rb___out__ = rb_float_new((double)__out__);
- return rb_ary_new3(2, rb_info, rb___out__);
-}
-
-void
-init_lapack_zla_syrcond_x(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_syrcond_x", rb_zla_syrcond_x, -1);
-}
diff --git a/zla_syrfsx_extended.c b/zla_syrfsx_extended.c
deleted file mode 100644
index 0191a21..0000000
--- a/zla_syrfsx_extended.c
+++ /dev/null
@@ -1,264 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_syrfsx_extended_(integer *prec_type, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ, doublereal *c, doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out, integer *n_norms, doublereal *err_bnds_norm, doublereal *err_bnds_comp, doublecomplex *res, doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail, doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal *dz_ub, logical *ignore_cwise, integer *info);
-
-static VALUE
-rb_zla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
- VALUE rb_prec_type;
- integer prec_type;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_colequ;
- logical colequ;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_n_norms;
- integer n_norms;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_res;
- doublecomplex *res;
- VALUE rb_ayb;
- doublereal *ayb;
- VALUE rb_dy;
- doublecomplex *dy;
- VALUE rb_y_tail;
- doublecomplex *y_tail;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ithresh;
- integer ithresh;
- VALUE rb_rthresh;
- doublereal rthresh;
- VALUE rb_dz_ub;
- doublereal dz_ub;
- VALUE rb_ignore_cwise;
- logical ignore_cwise;
- VALUE rb_berr_out;
- doublereal *berr_out;
- VALUE rb_info;
- integer info;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
- VALUE rb_err_bnds_norm_out__;
- doublereal *err_bnds_norm_out__;
- VALUE rb_err_bnds_comp_out__;
- doublereal *err_bnds_comp_out__;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldy;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise)\n or\n NumRu::Lapack.zla_syrfsx_extended # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n* Purpose\n* =======\n*\n* ZLA_SYRFSX_EXTENDED improves the computed solution to a system of\n* linear equations by performing extra-precise iterative refinement\n* and provides error bounds and backward error estimates for the solution.\n* This subroutine is called by ZSYRFSX to perform iterative refinement.\n* In addition to normwise error bound, the code provides maximum\n* componentwise error bound if possible. See comments for ERR_BNDS_NORM\n* and ERR_BNDS_COMP for details of the error bounds. Note that this\n* subroutine is only resonsible for setting the second fields of\n* ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n* Arguments\n* =========\n*\n* PREC_TYPE (input) INTEGER\n* Specifies the intermediate precision to be used in refinement.\n* The value is defined by ILAPREC(P) where P is a CHARACTER and\n* P = 'S': Single\n* = 'D': Double\n* = 'I': Indigenous\n* = 'X', 'E': Extra\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of right-hand-sides, i.e., the number of columns of the\n* matrix B.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* COLEQU (input) LOGICAL\n* If .TRUE. then column equilibration was done to A before calling\n* this routine. This is needed to compute the solution and error\n* bounds correctly.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A. If COLEQU = .FALSE., C\n* is not accessed. If C is input, each element of C should be a power\n* of the radix to ensure a reliable solution and error estimates.\n* Scaling by powers of the radix does not cause rounding errors unless\n* the result underflows or overflows. Rounding errors during scaling\n* lead to refining with a matrix that is not equivalent to the\n* input matrix, producing error estimates that may not be\n* reliable.\n*\n* B (input) COMPLEX*16 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* Y (input/output) COMPLEX*16 array, dimension\n* (LDY,NRHS)\n* On entry, the solution matrix X, as computed by ZSYTRS.\n* On exit, the improved solution matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n* BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n* On exit, BERR_OUT(j) contains the componentwise relative backward\n* error for right-hand-side j from the formula\n* max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n* where abs(Z) is the componentwise absolute value of the matrix\n* or vector Z. This is computed by ZLA_LIN_BERR.\n*\n* N_NORMS (input) INTEGER\n* Determines which error bounds to return (see ERR_BNDS_NORM\n* and ERR_BNDS_COMP).\n* If N_NORMS >= 1 return normwise error bounds.\n* If N_NORMS >= 2 return componentwise error bounds.\n*\n* ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n* (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * slamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * slamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * slamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* This subroutine is only responsible for setting the second field\n* above.\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* RES (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate residual.\n*\n* AYB (input) DOUBLE PRECISION array, dimension (N)\n* Workspace.\n*\n* DY (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the intermediate solution.\n*\n* Y_TAIL (input) COMPLEX*16 array, dimension (N)\n* Workspace to hold the trailing bits of the intermediate solution.\n*\n* RCOND (input) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* ITHRESH (input) INTEGER\n* The maximum number of residual computations allowed for\n* refinement. The default is 10. For 'aggressive' set to 100 to\n* permit convergence using approximate factorizations or\n* factorizations other than LU. If the factorization uses a\n* technique other than Gaussian elimination, the guarantees in\n* ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n* RTHRESH (input) DOUBLE PRECISION\n* Determines when to stop refinement if the error estimate stops\n* decreasing. Refinement will stop when the next solution no longer\n* satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n* the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n* default value is 0.5. For 'aggressive' set to 0.9 to permit\n* convergence on extremely ill-conditioned matrices. See LAWN 165\n* for more details.\n*\n* DZ_UB (input) DOUBLE PRECISION\n* Determines when to start considering componentwise convergence.\n* Componentwise convergence is only considered after each component\n* of the solution Y is stable, which we definte as the relative\n* change in each component being less than DZ_UB. The default value\n* is 0.25, requiring the first bit to be stable. See LAWN 165 for\n* more details.\n*\n* IGNORE_CWISE (input) LOGICAL\n* If .TRUE. then ignore componentwise convergence. Default value\n* is .FALSE..\n*\n* INFO (output) INTEGER\n* = 0: Successful exit.\n* < 0: if INFO = -i, the ith argument to ZSYTRS had an illegal\n* value\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n* ..\n\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_prec_type = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_colequ = argv[5];
- rb_c = argv[6];
- rb_b = argv[7];
- rb_y = argv[8];
- rb_n_norms = argv[9];
- rb_err_bnds_norm = argv[10];
- rb_err_bnds_comp = argv[11];
- rb_res = argv[12];
- rb_ayb = argv[13];
- rb_dy = argv[14];
- rb_y_tail = argv[15];
- rb_rcond = argv[16];
- rb_ithresh = argv[17];
- rb_rthresh = argv[18];
- rb_dz_ub = argv[19];
- rb_ignore_cwise = argv[20];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_res))
- rb_raise(rb_eArgError, "res (13th argument) must be NArray");
- if (NA_RANK(rb_res) != 1)
- rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_res);
- if (NA_TYPE(rb_res) != NA_DCOMPLEX)
- rb_res = na_change_type(rb_res, NA_DCOMPLEX);
- res = NA_PTR_TYPE(rb_res, doublecomplex*);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of res");
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of res");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- colequ = (rb_colequ == Qtrue);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (9th argument) must be NArray");
- if (NA_RANK(rb_y) != 2)
- rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_y) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
- ldy = NA_SHAPE0(rb_y);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of res");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- dz_ub = NUM2DBL(rb_dz_ub);
- if (!NA_IsNArray(rb_y_tail))
- rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
- if (NA_RANK(rb_y_tail) != 1)
- rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y_tail) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 0 of res");
- if (NA_TYPE(rb_y_tail) != NA_DCOMPLEX)
- rb_y_tail = na_change_type(rb_y_tail, NA_DCOMPLEX);
- y_tail = NA_PTR_TYPE(rb_y_tail, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of res");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- prec_type = NUM2INT(rb_prec_type);
- rthresh = NUM2DBL(rb_rthresh);
- ithresh = NUM2INT(rb_ithresh);
- if (!NA_IsNArray(rb_err_bnds_comp))
- rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_comp) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
- n_err_bnds = NA_SHAPE1(rb_err_bnds_comp);
- if (NA_SHAPE0(rb_err_bnds_comp) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_comp) != NA_DFLOAT)
- rb_err_bnds_comp = na_change_type(rb_err_bnds_comp, NA_DFLOAT);
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- ignore_cwise = (rb_ignore_cwise == Qtrue);
- if (!NA_IsNArray(rb_dy))
- rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
- if (NA_RANK(rb_dy) != 1)
- rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dy) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 0 of res");
- if (NA_TYPE(rb_dy) != NA_DCOMPLEX)
- rb_dy = na_change_type(rb_dy, NA_DCOMPLEX);
- dy = NA_PTR_TYPE(rb_dy, doublecomplex*);
- if (!NA_IsNArray(rb_ayb))
- rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
- if (NA_RANK(rb_ayb) != 1)
- rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ayb) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 0 of res");
- if (NA_TYPE(rb_ayb) != NA_DFLOAT)
- rb_ayb = na_change_type(rb_ayb, NA_DFLOAT);
- ayb = NA_PTR_TYPE(rb_ayb, doublereal*);
- if (!NA_IsNArray(rb_err_bnds_norm))
- rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
- if (NA_RANK(rb_err_bnds_norm) != 2)
- rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_err_bnds_norm) != n_err_bnds)
- rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
- if (NA_SHAPE0(rb_err_bnds_norm) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
- if (NA_TYPE(rb_err_bnds_norm) != NA_DFLOAT)
- rb_err_bnds_norm = na_change_type(rb_err_bnds_norm, NA_DFLOAT);
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- n_norms = NUM2INT(rb_n_norms);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr_out = NA_PTR_TYPE(rb_berr_out, doublereal*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = nrhs;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm_out__ = NA_PTR_TYPE(rb_err_bnds_norm_out__, doublereal*);
- MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rb_err_bnds_norm));
- rb_err_bnds_norm = rb_err_bnds_norm_out__;
- err_bnds_norm = err_bnds_norm_out__;
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp_out__ = NA_PTR_TYPE(rb_err_bnds_comp_out__, doublereal*);
- MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rb_err_bnds_comp));
- rb_err_bnds_comp = rb_err_bnds_comp_out__;
- err_bnds_comp = err_bnds_comp_out__;
-
- zla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_berr_out, rb_info, rb_y, rb_err_bnds_norm, rb_err_bnds_comp);
-}
-
-void
-init_lapack_zla_syrfsx_extended(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_syrfsx_extended", rb_zla_syrfsx_extended, -1);
-}
diff --git a/zla_syrpvgrw.c b/zla_syrpvgrw.c
deleted file mode 100644
index dc3de4a..0000000
--- a/zla_syrpvgrw.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zla_syrpvgrw_(char *uplo, integer *n, integer *info, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *work);
-
-static VALUE
-rb_zla_syrpvgrw(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_info;
- integer info;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb___out__;
- doublereal __out__;
-
- integer lda;
- integer n;
- integer ldaf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zla_syrpvgrw( uplo, info, a, af, ipiv, work)\n or\n NumRu::Lapack.zla_syrpvgrw # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n* Purpose\n* =======\n* \n* ZLA_SYRPVGRW computes the reciprocal pivot growth factor\n* norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n* much less than 1, the stability of the LU factorization of the\n* (equilibrated) matrix A could be poor. This also means that the\n* solution X, estimated condition numbers, and error bounds could be\n* unreliable.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* INFO (input) INTEGER\n* The value of INFO returned from ZSYTRF, .i.e., the pivot in\n* column INFO is exactly 0.\n*\n* NCOLS (input) INTEGER\n* The number of columns of the matrix A. NCOLS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* WORK (input) COMPLEX*16 array, dimension (2*N)\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n COMPLEX*16 ZDUM\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX, MIN\n* ..\n* .. External Subroutines ..\n EXTERNAL LSAME, ZLASET\n LOGICAL LSAME\n* ..\n* .. Statement Functions ..\n DOUBLE PRECISION CABS1\n* ..\n* .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_info = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_work = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- info = NUM2INT(rb_info);
- if (!NA_IsNArray(rb_work))
- rb_raise(rb_eArgError, "work (6th argument) must be NArray");
- if (NA_RANK(rb_work) != 1)
- rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_work) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
- if (NA_TYPE(rb_work) != NA_DCOMPLEX)
- rb_work = na_change_type(rb_work, NA_DCOMPLEX);
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
-
- __out__ = zla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zla_syrpvgrw(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_syrpvgrw", rb_zla_syrpvgrw, -1);
-}
diff --git a/zla_wwaddw.c b/zla_wwaddw.c
deleted file mode 100644
index e078528..0000000
--- a/zla_wwaddw.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zla_wwaddw_(integer *n, doublecomplex *x, doublecomplex *y, doublecomplex *w);
-
-static VALUE
-rb_zla_wwaddw(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.zla_wwaddw( x, y, w)\n or\n NumRu::Lapack.zla_wwaddw # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLA_WWADDW( N, X, Y, W )\n\n* Purpose\n* =======\n*\n* ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n* This works for all extant IBM's hex and binary floating point\n* arithmetics, but not for decimal.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of vectors X, Y, and W.\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* The first part of the doubled-single accumulation vector.\n*\n* Y (input/output) COMPLEX*16 array, dimension (N)\n* The second part of the doubled-single accumulation vector.\n*\n* W (input) COMPLEX*16 array, dimension (N)\n* The vector to be added.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n COMPLEX*16 S\n INTEGER I\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
- rb_w = argv[2];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DCOMPLEX)
- rb_w = na_change_type(rb_w, NA_DCOMPLEX);
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (2th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of w");
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zla_wwaddw_(&n, x, y, w);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_zla_wwaddw(VALUE mLapack){
- rb_define_module_function(mLapack, "zla_wwaddw", rb_zla_wwaddw, -1);
-}
diff --git a/zlabrd.c b/zlabrd.c
deleted file mode 100644
index da71aee..0000000
--- a/zlabrd.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlabrd_(integer *m, integer *n, integer *nb, doublecomplex *a, integer *lda, doublereal *d, doublereal *e, doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, integer *ldx, doublecomplex *y, integer *ldy);
-
-static VALUE
-rb_zlabrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tauq;
- doublecomplex *tauq;
- VALUE rb_taup;
- doublecomplex *taup;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer ldx;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n d, e, tauq, taup, x, y, a = NumRu::Lapack.zlabrd( m, nb, a)\n or\n NumRu::Lapack.zlabrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n* Purpose\n* =======\n*\n* ZLABRD reduces the first NB rows and columns of a complex general\n* m by n matrix A to upper or lower real bidiagonal form by a unitary\n* transformation Q' * A * P, and returns the matrices X and Y which\n* are needed to apply the transformation to the unreduced part of A.\n*\n* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n* bidiagonal form.\n*\n* This is an auxiliary routine called by ZGEBRD\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows in the matrix A.\n*\n* N (input) INTEGER\n* The number of columns in the matrix A.\n*\n* NB (input) INTEGER\n* The number of leading rows and columns of A to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n general matrix to be reduced.\n* On exit, the first NB rows and columns of the matrix are\n* overwritten; the rest of the array is unchanged.\n* If m >= n, elements on and below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors; and\n* elements above the diagonal in the first NB rows, with the\n* array TAUP, represent the unitary matrix P as a product\n* of elementary reflectors.\n* If m < n, elements below the diagonal in the first NB\n* columns, with the array TAUQ, represent the unitary\n* matrix Q as a product of elementary reflectors, and\n* elements on and above the diagonal in the first NB rows,\n* with the array TAUP, represent the unitary matrix P as\n* a product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* D (output) DOUBLE PRECISION array, dimension (NB)\n* The diagonal elements of the first NB rows and columns of\n* the reduced matrix. D(i) = A(i,i).\n*\n* E (output) DOUBLE PRECISION array, dimension (NB)\n* The off-diagonal elements of the first NB rows and columns of\n* the reduced matrix.\n*\n* TAUQ (output) COMPLEX*16 array dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix Q. See Further Details.\n*\n* TAUP (output) COMPLEX*16 array, dimension (NB)\n* The scalar factors of the elementary reflectors which\n* represent the unitary matrix P. See Further Details.\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NB)\n* The m-by-nb matrix X required to update the unreduced part\n* of A.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,M).\n*\n* Y (output) COMPLEX*16 array, dimension (LDY,NB)\n* The n-by-nb matrix Y required to update the unreduced part\n* of A.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrices Q and P are represented as products of elementary\n* reflectors:\n*\n* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n*\n* Each H(i) and G(i) has the form:\n*\n* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n*\n* where tauq and taup are complex scalars, and v and u are complex\n* vectors.\n*\n* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n* The elements of the vectors v and u together form the m-by-nb matrix\n* V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n* the transformation to the unreduced part of the matrix, using a block\n* update of the form: A := A - V*Y' - X*U'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with nb = 2:\n*\n* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n*\n* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n* ( v1 v2 a a a ) ( v1 1 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a ) ( v1 v2 a a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix which is unchanged,\n* vi denotes an element of the vector defining H(i), and ui an element\n* of the vector defining G(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- nb = NUM2INT(rb_nb);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ldy = MAX(1,n);
- ldx = MAX(1,m);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tauq = NA_PTR_TYPE(rb_tauq, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taup = NA_PTR_TYPE(rb_taup, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = MAX(1,nb);
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);
-
- return rb_ary_new3(7, rb_d, rb_e, rb_tauq, rb_taup, rb_x, rb_y, rb_a);
-}
-
-void
-init_lapack_zlabrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zlabrd", rb_zlabrd, -1);
-}
diff --git a/zlacgv.c b/zlacgv.c
deleted file mode 100644
index 168c6cf..0000000
--- a/zlacgv.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlacgv_(integer *n, doublecomplex *x, integer *incx);
-
-static VALUE
-rb_zlacgv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.zlacgv( n, x, incx)\n or\n NumRu::Lapack.zlacgv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACGV( N, X, INCX )\n\n* Purpose\n* =======\n*\n* ZLACGV conjugates a complex vector of length N.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vector X. N >= 0.\n*\n* X (input/output) COMPLEX*16 array, dimension\n* (1+(N-1)*abs(INCX))\n* On entry, the vector of length N to be conjugated.\n* On exit, X is overwritten with conjg(X).\n*\n* INCX (input) INTEGER\n* The spacing between successive elements of X.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IOFF\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
-
- incx = NUM2INT(rb_incx);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*abs(incx);
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- zlacgv_(&n, x, &incx);
-
- return rb_x;
-}
-
-void
-init_lapack_zlacgv(VALUE mLapack){
- rb_define_module_function(mLapack, "zlacgv", rb_zlacgv, -1);
-}
diff --git a/zlacn2.c b/zlacn2.c
deleted file mode 100644
index 552ce77..0000000
--- a/zlacn2.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlacn2_(integer *n, doublecomplex *v, doublecomplex *x, doublereal *est, integer *kase, integer *isave);
-
-static VALUE
-rb_zlacn2(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_est;
- doublereal est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_isave;
- integer *isave;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_isave_out__;
- integer *isave_out__;
- doublecomplex *v;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase, isave = NumRu::Lapack.zlacn2( x, est, kase, isave)\n or\n NumRu::Lapack.zlacn2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )\n\n* Purpose\n* =======\n*\n* ZLACN2 estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX*16 array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and ZLACN2 must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n* unchanged from the previous call to ZLACN2.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to ZLACN2, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from ZLACN2, KASE will again be 0.\n*\n* ISAVE (input/output) INTEGER array, dimension (3)\n* ISAVE is used to save variables between calls to ZLACN2\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* This is a thread safe version of ZLACON, which uses the array ISAVE\n* in place of a SAVE statement, as follows:\n*\n* ZLACON ZLACN2\n* JUMP ISAVE(1)\n* J ISAVE(2)\n* ITER ISAVE(3)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
- rb_isave = argv[3];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- est = NUM2DBL(rb_est);
- if (!NA_IsNArray(rb_isave))
- rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
- if (NA_RANK(rb_isave) != 1)
- rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isave) != (3))
- rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
- if (NA_TYPE(rb_isave) != NA_LINT)
- rb_isave = na_change_type(rb_isave, NA_LINT);
- isave = NA_PTR_TYPE(rb_isave, integer*);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 3;
- rb_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isave_out__ = NA_PTR_TYPE(rb_isave_out__, integer*);
- MEMCPY(isave_out__, isave, integer, NA_TOTAL(rb_isave));
- rb_isave = rb_isave_out__;
- isave = isave_out__;
- v = ALLOC_N(doublecomplex, (n));
-
- zlacn2_(&n, v, x, &est, &kase, isave);
-
- free(v);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(4, rb_x, rb_est, rb_kase, rb_isave);
-}
-
-void
-init_lapack_zlacn2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlacn2", rb_zlacn2, -1);
-}
diff --git a/zlacon.c b/zlacon.c
deleted file mode 100644
index 50267da..0000000
--- a/zlacon.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlacon_(integer *n, doublecomplex *v, doublecomplex *x, doublereal *est, integer *kase);
-
-static VALUE
-rb_zlacon(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_est;
- doublereal est;
- VALUE rb_kase;
- integer kase;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *v;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, est, kase = NumRu::Lapack.zlacon( x, est, kase)\n or\n NumRu::Lapack.zlacon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACON( N, V, X, EST, KASE )\n\n* Purpose\n* =======\n*\n* ZLACON estimates the 1-norm of a square, complex matrix A.\n* Reverse communication is used for evaluating matrix-vector products.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 1.\n*\n* V (workspace) COMPLEX*16 array, dimension (N)\n* On the final return, V = A*W, where EST = norm(V)/norm(W)\n* (W is not returned).\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On an intermediate return, X should be overwritten by\n* A * X, if KASE=1,\n* A' * X, if KASE=2,\n* where A' is the conjugate transpose of A, and ZLACON must be\n* re-called with all the other parameters unchanged.\n*\n* EST (input/output) DOUBLE PRECISION\n* On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n* unchanged from the previous call to ZLACON.\n* On exit, EST is an estimate (a lower bound) for norm(A). \n*\n* KASE (input/output) INTEGER\n* On the initial call to ZLACON, KASE should be 0.\n* On an intermediate return, KASE will be 1 or 2, indicating\n* whether X should be overwritten by A * X or A' * X.\n* On the final return from ZLACON, KASE will again be 0.\n*\n\n* Further Details\n* ======= =======\n*\n* Contributed by Nick Higham, University of Manchester.\n* Originally named CONEST, dated March 16, 1988.\n*\n* Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n* a real or complex matrix, with applications to condition estimation\",\n* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n* Last modified: April, 1999\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_x = argv[0];
- rb_est = argv[1];
- rb_kase = argv[2];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- est = NUM2DBL(rb_est);
- kase = NUM2INT(rb_kase);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- v = ALLOC_N(doublecomplex, (n));
-
- zlacon_(&n, v, x, &est, &kase);
-
- free(v);
- rb_est = rb_float_new((double)est);
- rb_kase = INT2NUM(kase);
- return rb_ary_new3(3, rb_x, rb_est, rb_kase);
-}
-
-void
-init_lapack_zlacon(VALUE mLapack){
- rb_define_module_function(mLapack, "zlacon", rb_zlacon, -1);
-}
diff --git a/zlacp2.c b/zlacp2.c
deleted file mode 100644
index 2494e97..0000000
--- a/zlacp2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlacp2_(char *uplo, integer *m, integer *n, doublereal *a, integer *lda, doublecomplex *b, integer *ldb);
-
-static VALUE
-rb_zlacp2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublecomplex *b;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.zlacp2( uplo, m, a)\n or\n NumRu::Lapack.zlacp2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* ZLACP2 copies all or part of a real two-dimensional matrix A to a\n* complex matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) DOUBLE PRECISION array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX*16 array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- ldb = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
-
- zlacp2_(&uplo, &m, &n, a, &lda, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_zlacp2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlacp2", rb_zlacp2, -1);
-}
diff --git a/zlacpy.c b/zlacpy.c
deleted file mode 100644
index 8b5379c..0000000
--- a/zlacpy.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlacpy_(char *uplo, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb);
-
-static VALUE
-rb_zlacpy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.zlacpy( uplo, m, a)\n or\n NumRu::Lapack.zlacpy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n* Purpose\n* =======\n*\n* ZLACPY copies all or part of a two-dimensional matrix A to another\n* matrix B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be copied to B.\n* = 'U': Upper triangular part\n* = 'L': Lower triangular part\n* Otherwise: All of the matrix A\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A. If UPLO = 'U', only the upper trapezium\n* is accessed; if UPLO = 'L', only the lower trapezium is\n* accessed.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (output) COMPLEX*16 array, dimension (LDB,N)\n* On exit, B = A in the locations specified by UPLO.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- ldb = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
-
- zlacpy_(&uplo, &m, &n, a, &lda, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_zlacpy(VALUE mLapack){
- rb_define_module_function(mLapack, "zlacpy", rb_zlacpy, -1);
-}
diff --git a/zlacrm.c b/zlacrm.c
deleted file mode 100644
index 1c11eb9..0000000
--- a/zlacrm.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlacrm_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *b, integer *ldb, doublecomplex *c, integer *ldc, doublereal *rwork);
-
-static VALUE
-rb_zlacrm(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublereal *b;
- VALUE rb_c;
- doublecomplex *c;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlacrm( m, a, b)\n or\n NumRu::Lapack.zlacrm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n* Purpose\n* =======\n*\n* ZLACRM performs a very simple matrix-matrix multiplication:\n* C := A * B,\n* where A is M by N and complex; B is N by N and real;\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) COMPLEX*16 array, dimension (LDA, N)\n* A contains the M by N 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 N by N matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >=max(1,N).\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,N).\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N)\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DFLOAT)
- rb_b = na_change_type(rb_b, NA_DFLOAT);
- b = NA_PTR_TYPE(rb_b, doublereal*);
- ldc = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- rwork = ALLOC_N(doublereal, (2*m*n));
-
- zlacrm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
-
- free(rwork);
- return rb_c;
-}
-
-void
-init_lapack_zlacrm(VALUE mLapack){
- rb_define_module_function(mLapack, "zlacrm", rb_zlacrm, -1);
-}
diff --git a/zlacrt.c b/zlacrt.c
deleted file mode 100644
index 146ffb2..0000000
--- a/zlacrt.c
+++ /dev/null
@@ -1,89 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlacrt_(integer *n, doublecomplex *cx, integer *incx, doublecomplex *cy, integer *incy, doublecomplex *c, doublecomplex *s);
-
-static VALUE
-rb_zlacrt(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- doublecomplex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_cy;
- doublecomplex *cy;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- doublecomplex c;
- VALUE rb_s;
- doublecomplex s;
- VALUE rb_cx_out__;
- doublecomplex *cx_out__;
- VALUE rb_cy_out__;
- doublecomplex *cy_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.zlacrt( cx, incx, cy, incy, c, s)\n or\n NumRu::Lapack.zlacrt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* ZLACRT performs the operation\n*\n* ( c s )( x ) ==> ( x )\n* ( -s c )( y ) ( y )\n*\n* where c and s are complex and the vectors x and y are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector x.\n* On output, CX is overwritten with c*x + s*y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CX. INCX <> 0.\n*\n* CY (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector y.\n* On output, CY is overwritten with -s*x + c*y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCY <> 0.\n*\n* C (input) COMPLEX*16\n* S (input) COMPLEX*16\n* C and S define the matrix\n* [ C S ].\n* [ -S C ]\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX*16 CTEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
- rb_cy = argv[2];
- rb_incy = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
-
- if (!NA_IsNArray(rb_cy))
- rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
- if (NA_RANK(rb_cy) != 1)
- rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cy);
- if (NA_TYPE(rb_cy) != NA_DCOMPLEX)
- rb_cy = na_change_type(rb_cy, NA_DCOMPLEX);
- cy = NA_PTR_TYPE(rb_cy, doublecomplex*);
- c.r = NUM2DBL(rb_funcall(rb_c, rb_intern("real"), 0));
- c.i = NUM2DBL(rb_funcall(rb_c, rb_intern("imag"), 0));
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- s.r = NUM2DBL(rb_funcall(rb_s, rb_intern("real"), 0));
- s.i = NUM2DBL(rb_funcall(rb_s, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_cx) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of cx must be the same as shape 0 of cy");
- if (NA_TYPE(rb_cx) != NA_DCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_DCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_cx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- cx_out__ = NA_PTR_TYPE(rb_cx_out__, doublecomplex*);
- MEMCPY(cx_out__, cx, doublecomplex, NA_TOTAL(rb_cx));
- rb_cx = rb_cx_out__;
- cx = cx_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cy_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- cy_out__ = NA_PTR_TYPE(rb_cy_out__, doublecomplex*);
- MEMCPY(cy_out__, cy, doublecomplex, NA_TOTAL(rb_cy));
- rb_cy = rb_cy_out__;
- cy = cy_out__;
-
- zlacrt_(&n, cx, &incx, cy, &incy, &c, &s);
-
- return rb_ary_new3(2, rb_cx, rb_cy);
-}
-
-void
-init_lapack_zlacrt(VALUE mLapack){
- rb_define_module_function(mLapack, "zlacrt", rb_zlacrt, -1);
-}
diff --git a/zladiv.c b/zladiv.c
deleted file mode 100644
index 79b2a34..0000000
--- a/zladiv.c
+++ /dev/null
@@ -1,38 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zladiv_(doublecomplex *__out__, doublecomplex *x, doublecomplex *y);
-
-static VALUE
-rb_zladiv(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublecomplex x;
- VALUE rb_y;
- doublecomplex y;
- VALUE rb___out__;
- doublecomplex __out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zladiv( x, y)\n or\n NumRu::Lapack.zladiv # print help\n\n\nFORTRAN MANUAL\n COMPLEX*16 FUNCTION ZLADIV( X, Y )\n\n* Purpose\n* =======\n*\n* ZLADIV := X / Y, where X and Y are complex. The computation of X / Y\n* will not overflow on an intermediary step unless the results\n* overflows.\n*\n\n* Arguments\n* =========\n*\n* X (input) COMPLEX*16\n* Y (input) COMPLEX*16\n* The complex scalars X and Y.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n DOUBLE PRECISION ZI, ZR\n* ..\n* .. External Subroutines ..\n EXTERNAL DLADIV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, DCMPLX, DIMAG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_x = argv[0];
- rb_y = argv[1];
-
- x.r = NUM2DBL(rb_funcall(rb_x, rb_intern("real"), 0));
- x.i = NUM2DBL(rb_funcall(rb_x, rb_intern("imag"), 0));
- y.r = NUM2DBL(rb_funcall(rb_y, rb_intern("real"), 0));
- y.i = NUM2DBL(rb_funcall(rb_y, rb_intern("imag"), 0));
-
- zladiv_(&__out__, &x, &y);
-
- rb___out__ = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(__out__.r)), rb_float_new((double)(__out__.i)));
- return rb___out__;
-}
-
-void
-init_lapack_zladiv(VALUE mLapack){
- rb_define_module_function(mLapack, "zladiv", rb_zladiv, -1);
-}
diff --git a/zlaed0.c b/zlaed0.c
deleted file mode 100644
index d1b7008..0000000
--- a/zlaed0.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaed0_(integer *qsiz, integer *n, doublereal *d, doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *qstore, integer *ldqs, doublereal *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zlaed0(int argc, VALUE *argv, VALUE self){
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- doublecomplex *qstore;
- doublereal *rwork;
- integer *iwork;
-
- integer n;
- integer ldq;
- integer ldqs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, q = NumRu::Lapack.zlaed0( qsiz, d, e, q)\n or\n NumRu::Lapack.zlaed0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* Using the divide and conquer method, ZLAED0 computes all eigenvalues\n* of a symmetric tridiagonal matrix which is one diagonal block of\n* those from reducing a dense or band Hermitian matrix and\n* corresponding eigenvectors of the dense or band matrix.\n*\n\n* Arguments\n* =========\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the off-diagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, Q must contain an QSIZ x N matrix whose columns\n* unitarily orthonormal. It is a part of the unitary matrix\n* that reduces the full dense Hermitian matrix to a\n* (reducible) symmetric tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IWORK (workspace) INTEGER array,\n* the dimension of IWORK must be at least\n* 6 + 6*N + 5*N*lg N\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* RWORK (workspace) DOUBLE PRECISION array,\n* dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n* ( lg( N ) = smallest integer k\n* such that 2^k >= N )\n*\n* QSTORE (workspace) COMPLEX*16 array, dimension (LDQS, N)\n* Used to store parts of\n* the eigenvector matrix when the updating matrix multiplies\n* take place.\n*\n* LDQS (input) INTEGER\n* The leading dimension of the array QSTORE.\n* LDQS >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* =====================================================================\n*\n* Warning: N could be as big as QSIZ!\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_qsiz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_q = argv[3];
-
- qsiz = NUM2INT(rb_qsiz);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (4th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- ldqs = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- qstore = ALLOC_N(doublecomplex, (ldqs)*(n));
- rwork = ALLOC_N(doublereal, (1 + 3*n + 2*n*LG(n) + 3*pow(n,2)));
- iwork = ALLOC_N(integer, (6 + 6*n + 5*n*LG(n)));
-
- zlaed0_(&qsiz, &n, d, e, q, &ldq, qstore, &ldqs, rwork, iwork, &info);
-
- free(qstore);
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_q);
-}
-
-void
-init_lapack_zlaed0(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaed0", rb_zlaed0, -1);
-}
diff --git a/zlaed7.c b/zlaed7.c
deleted file mode 100644
index 75e80f5..0000000
--- a/zlaed7.c
+++ /dev/null
@@ -1,228 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaed7_(integer *n, integer *cutpnt, integer *qsiz, integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d, doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq, doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, doublecomplex *work, doublereal *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zlaed7(int argc, VALUE *argv, VALUE self){
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_tlvls;
- integer tlvls;
- VALUE rb_curlvl;
- integer curlvl;
- VALUE rb_curpbm;
- integer curpbm;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_qstore;
- doublereal *qstore;
- VALUE rb_qptr;
- integer *qptr;
- VALUE rb_prmptr;
- integer *prmptr;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- VALUE rb_qstore_out__;
- doublereal *qstore_out__;
- VALUE rb_qptr_out__;
- integer *qptr_out__;
- doublecomplex *work;
- doublereal *rwork;
- integer *iwork;
-
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n indxq, info, d, q, qstore, qptr = NumRu::Lapack.zlaed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum)\n or\n NumRu::Lapack.zlaed7 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLAED7 computes the updated eigensystem of a diagonal\n* matrix after modification by a rank-one symmetric matrix. This\n* routine is used only for the eigenproblem which requires all\n* eigenvalues and optionally eigenvectors of a dense or banded\n* Hermitian matrix that has been reduced to tridiagonal form.\n*\n* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n* where Z = Q'u, u is a vector of length N with ones in the\n* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n* The eigenvectors of the original matrix are stored in Q, and the\n* eigenvalues are in D. The algorithm consists of three stages:\n*\n* The first stage consists of deflating the size of the problem\n* when there are multiple eigenvalues or if there is a zero in\n* the Z vector. For each such occurence the dimension of the\n* secular equation problem is reduced by one. This stage is\n* performed by the routine DLAED2.\n*\n* The second stage consists of calculating the updated\n* eigenvalues. This is done by finding the roots of the secular\n* equation via the routine DLAED4 (as called by SLAED3).\n* This routine also calculates the eigenvectors of the current\n* problem.\n*\n* The final stage consists of computing the updated eigenvectors\n* directly using the updated eigenvalues. The eigenvectors for\n* the current problem are multiplied with the eigenvectors from\n* the overall problem.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. min(1,N) <= CUTPNT <= N.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the full matrix to tridiagonal form. QSIZ >= N.\n*\n* TLVLS (input) INTEGER\n* The total number of merging levels in the overall divide and\n* conquer tree.\n*\n* CURLVL (input) INTEGER\n* The current level in the overall merge routine,\n* 0 <= curlvl <= tlvls.\n*\n* CURPBM (input) INTEGER\n* The current problem in the current level in the overall\n* merge routine (counting from upper left to lower right).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the eigenvalues of the rank-1-perturbed matrix.\n* On exit, the eigenvalues of the repaired matrix.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, the eigenvectors of the rank-1-perturbed matrix.\n* On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* RHO (input) DOUBLE PRECISION\n* Contains the subdiagonal element used to create the rank-1\n* modification.\n*\n* INDXQ (output) INTEGER array, dimension (N)\n* This contains the permutation which will reintegrate the\n* subproblem just solved back into sorted order,\n* ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n* IWORK (workspace) INTEGER array, dimension (4*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array,\n* dimension (3*N+2*QSIZ*N)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (QSIZ*N)\n*\n* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n* Stores eigenvectors of submatrices encountered during\n* divide and conquer, packed together. QPTR points to\n* beginning of the submatrices.\n*\n* QPTR (input/output) INTEGER array, dimension (N+2)\n* List of indices pointing to beginning of submatrices stored\n* in QSTORE. The submatrices are numbered starting at the\n* bottom left of the divide and conquer tree, from left to\n* right and bottom to top.\n*\n* PRMPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in PERM a\n* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n* indicates the size of the permutation and also the size of\n* the full, non-deflated problem.\n*\n* PERM (input) INTEGER array, dimension (N lg N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (input) INTEGER array, dimension (N lg N)\n* Contains a list of pointers which indicate where in GIVCOL a\n* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n* indicates the number of Givens rotations.\n*\n* GIVCOL (input) INTEGER array, dimension (2, N lg N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER COLTYP, CURR, I, IDLMDA, INDX,\n $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n* ..\n* .. External Subroutines ..\n EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_cutpnt = argv[0];
- rb_qsiz = argv[1];
- rb_tlvls = argv[2];
- rb_curlvl = argv[3];
- rb_curpbm = argv[4];
- rb_d = argv[5];
- rb_q = argv[6];
- rb_rho = argv[7];
- rb_qstore = argv[8];
- rb_qptr = argv[9];
- rb_prmptr = argv[10];
- rb_perm = argv[11];
- rb_givptr = argv[12];
- rb_givcol = argv[13];
- rb_givnum = argv[14];
-
- qsiz = NUM2INT(rb_qsiz);
- cutpnt = NUM2INT(rb_cutpnt);
- tlvls = NUM2INT(rb_tlvls);
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- curlvl = NUM2INT(rb_curlvl);
- curpbm = NUM2INT(rb_curpbm);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 1);
- if (NA_SHAPE0(rb_perm) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_prmptr))
- rb_raise(rb_eArgError, "prmptr (11th argument) must be NArray");
- if (NA_RANK(rb_prmptr) != 1)
- rb_raise(rb_eArgError, "rank of prmptr (11th argument) must be %d", 1);
- if (NA_SHAPE0(rb_prmptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
- if (NA_TYPE(rb_prmptr) != NA_LINT)
- rb_prmptr = na_change_type(rb_prmptr, NA_LINT);
- prmptr = NA_PTR_TYPE(rb_prmptr, integer*);
- if (!NA_IsNArray(rb_qstore))
- rb_raise(rb_eArgError, "qstore (9th argument) must be NArray");
- if (NA_RANK(rb_qstore) != 1)
- rb_raise(rb_eArgError, "rank of qstore (9th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qstore) != (pow(n,2)+1))
- rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
- if (NA_TYPE(rb_qstore) != NA_DFLOAT)
- rb_qstore = na_change_type(rb_qstore, NA_DFLOAT);
- qstore = NA_PTR_TYPE(rb_qstore, doublereal*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (13th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (14th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (15th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (15th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (n*LG(n)))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
- if (NA_SHAPE0(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
- if (NA_TYPE(rb_givnum) != NA_DFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_DFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- if (!NA_IsNArray(rb_qptr))
- rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
- if (NA_RANK(rb_qptr) != 1)
- rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_qptr) != (n+2))
- rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
- if (NA_TYPE(rb_qptr) != NA_LINT)
- rb_qptr = na_change_type(rb_qptr, NA_LINT);
- qptr = NA_PTR_TYPE(rb_qptr, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = pow(n,2)+1;
- rb_qstore_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- qstore_out__ = NA_PTR_TYPE(rb_qstore_out__, doublereal*);
- MEMCPY(qstore_out__, qstore, doublereal, NA_TOTAL(rb_qstore));
- rb_qstore = rb_qstore_out__;
- qstore = qstore_out__;
- {
- int shape[1];
- shape[0] = n+2;
- rb_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- qptr_out__ = NA_PTR_TYPE(rb_qptr_out__, integer*);
- MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rb_qptr));
- rb_qptr = rb_qptr_out__;
- qptr = qptr_out__;
- work = ALLOC_N(doublecomplex, (qsiz*n));
- rwork = ALLOC_N(doublereal, (3*n+2*qsiz*n));
- iwork = ALLOC_N(integer, (4*n));
-
- zlaed7_(&n, &cutpnt, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, &rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_indxq, rb_info, rb_d, rb_q, rb_qstore, rb_qptr);
-}
-
-void
-init_lapack_zlaed7(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaed7", rb_zlaed7, -1);
-}
diff --git a/zlaed8.c b/zlaed8.c
deleted file mode 100644
index ef0d4e1..0000000
--- a/zlaed8.c
+++ /dev/null
@@ -1,179 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaed8_(integer *k, integer *n, integer *qsiz, doublecomplex *q, integer *ldq, doublereal *d, doublereal *rho, integer *cutpnt, doublereal *z, doublereal *dlamda, doublecomplex *q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx, integer *indxq, integer *perm, integer *givptr, integer *givcol, doublereal *givnum, integer *info);
-
-static VALUE
-rb_zlaed8(int argc, VALUE *argv, VALUE self){
- VALUE rb_qsiz;
- integer qsiz;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_rho;
- doublereal rho;
- VALUE rb_cutpnt;
- integer cutpnt;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_indxq;
- integer *indxq;
- VALUE rb_k;
- integer k;
- VALUE rb_dlamda;
- doublereal *dlamda;
- VALUE rb_q2;
- doublecomplex *q2;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_info;
- integer info;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- VALUE rb_d_out__;
- doublereal *d_out__;
- integer *indxp;
- integer *indx;
-
- integer ldq;
- integer n;
- integer ldq2;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.zlaed8( qsiz, q, d, rho, cutpnt, z, indxq)\n or\n NumRu::Lapack.zlaed8 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n* Purpose\n* =======\n*\n* ZLAED8 merges the two sets of eigenvalues together into a single\n* sorted set. Then it tries to deflate the size of the problem.\n* There are two ways in which deflation can occur: when two or more\n* eigenvalues are close together or if there is a tiny element in the\n* Z vector. For each such occurrence the order of the related secular\n* equation problem is reduced by one.\n*\n\n* Arguments\n* =========\n*\n* K (output) INTEGER\n* Contains the number of non-deflated eigenvalues.\n* This is the order of the related secular equation.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* QSIZ (input) INTEGER\n* The dimension of the unitary matrix used to reduce\n* the dense or band matrix to tridiagonal form.\n* QSIZ >= N if ICOMPQ = 1.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, Q contains the eigenvectors of the partially solved\n* system which has been previously updated in matrix\n* multiplies with other partially solved eigensystems.\n* On exit, Q contains the trailing (N-K) updated eigenvectors\n* (those which were deflated) in its last N-K columns.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max( 1, N ).\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, D contains the eigenvalues of the two submatrices to\n* be combined. On exit, D contains the trailing (N-K) updated\n* eigenvalues (those which were deflated) sorted into increasing\n* order.\n*\n* RHO (input/output) DOUBLE PRECISION\n* Contains the off diagonal element associated with the rank-1\n* cut which originally split the two submatrices which are now\n* being recombined. RHO is modified during the computation to\n* the value required by DLAED3.\n*\n* CUTPNT (input) INTEGER\n* Contains the location of the last eigenvalue in the leading\n* sub-matrix. MIN(1,N) <= CUTPNT <= N.\n*\n* Z (input) DOUBLE PRECISION array, dimension (N)\n* On input this vector contains the updating vector (the last\n* row of the first sub-eigenvector matrix and the first row of\n* the second sub-eigenvector matrix). The contents of Z are\n* destroyed during the updating process.\n*\n* DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n* Contains a copy of the first K eigenvalues which will be used\n* by DLAED3 to form the secular equation.\n*\n* Q2 (output) COMPLEX*16 array, dimension (LDQ2,N)\n* If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n* Contains a copy of the first K eigenvectors which will be used\n* by DLAED7 in a matrix multiply (DGEMM) to update the new\n* eigenvectors.\n*\n* LDQ2 (input) INTEGER\n* The leading dimension of the array Q2. LDQ2 >= max( 1, N ).\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* This will hold the first k values of the final\n* deflation-altered z-vector and will be passed to DLAED3.\n*\n* INDXP (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to place deflated\n* values of D at the end of the array. On output INDXP(1:K)\n* points to the nondeflated D-values and INDXP(K+1:N)\n* points to the deflated eigenvalues.\n*\n* INDX (workspace) INTEGER array, dimension (N)\n* This will contain the permutation used to sort the contents of\n* D into ascending order.\n*\n* INDXQ (input) INTEGER array, dimension (N)\n* This contains the permutation which separately sorts the two\n* sub-problems in D into ascending order. Note that elements in\n* the second half of this permutation must first have CUTPNT\n* added to their values in order to be accurate.\n*\n* PERM (output) INTEGER array, dimension (N)\n* Contains the permutations (from deflation and sorting) to be\n* applied to each eigenblock.\n*\n* GIVPTR (output) INTEGER\n* Contains the number of Givens rotations which took place in\n* this subproblem.\n*\n* GIVCOL (output) INTEGER array, dimension (2, N)\n* Each pair of numbers indicates a pair of columns to take place\n* in a Givens rotation.\n*\n* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n* Each number indicates the S value to be used in the\n* corresponding Givens rotation.\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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_qsiz = argv[0];
- rb_q = argv[1];
- rb_d = argv[2];
- rb_rho = argv[3];
- rb_cutpnt = argv[4];
- rb_z = argv[5];
- rb_indxq = argv[6];
-
- qsiz = NUM2INT(rb_qsiz);
- if (!NA_IsNArray(rb_indxq))
- rb_raise(rb_eArgError, "indxq (7th argument) must be NArray");
- if (NA_RANK(rb_indxq) != 1)
- rb_raise(rb_eArgError, "rank of indxq (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_indxq);
- if (NA_TYPE(rb_indxq) != NA_LINT)
- rb_indxq = na_change_type(rb_indxq, NA_LINT);
- indxq = NA_PTR_TYPE(rb_indxq, integer*);
- cutpnt = NUM2INT(rb_cutpnt);
- rho = NUM2DBL(rb_rho);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (2th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of indxq");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (6th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of indxq");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- ldq2 = MAX( 1, n );
- {
- int shape[1];
- shape[0] = n;
- rb_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dlamda = NA_PTR_TYPE(rb_dlamda, doublereal*);
- {
- int shape[2];
- shape[0] = ldq2;
- shape[1] = n;
- rb_q2 = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q2 = NA_PTR_TYPE(rb_q2, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_perm = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- perm = NA_PTR_TYPE(rb_perm, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
- }
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = 2;
- shape[1] = n;
- rb_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- indxp = ALLOC_N(integer, (n));
- indx = ALLOC_N(integer, (n));
-
- zlaed8_(&k, &n, &qsiz, q, &ldq, d, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, indxp, indx, indxq, perm, &givptr, givcol, givnum, &info);
-
- free(indxp);
- free(indx);
- rb_k = INT2NUM(k);
- rb_givptr = INT2NUM(givptr);
- rb_info = INT2NUM(info);
- rb_rho = rb_float_new((double)rho);
- return rb_ary_new3(12, rb_k, rb_dlamda, rb_q2, rb_w, rb_perm, rb_givptr, rb_givcol, rb_givnum, rb_info, rb_q, rb_d, rb_rho);
-}
-
-void
-init_lapack_zlaed8(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaed8", rb_zlaed8, -1);
-}
diff --git a/zlaein.c b/zlaein.c
deleted file mode 100644
index bfbc693..0000000
--- a/zlaein.c
+++ /dev/null
@@ -1,94 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaein_(logical *rightv, logical *noinit, integer *n, doublecomplex *h, integer *ldh, doublecomplex *w, doublecomplex *v, doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *eps3, doublereal *smlnum, integer *info);
-
-static VALUE
-rb_zlaein(int argc, VALUE *argv, VALUE self){
- VALUE rb_rightv;
- logical rightv;
- VALUE rb_noinit;
- logical noinit;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_w;
- doublecomplex w;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_eps3;
- doublereal eps3;
- VALUE rb_smlnum;
- doublereal smlnum;
- VALUE rb_info;
- integer info;
- VALUE rb_v_out__;
- doublecomplex *v_out__;
- doublecomplex *b;
- doublereal *rwork;
-
- integer ldh;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, v = NumRu::Lapack.zlaein( rightv, noinit, h, w, v, eps3, smlnum)\n or\n NumRu::Lapack.zlaein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n* Purpose\n* =======\n*\n* ZLAEIN uses inverse iteration to find a right or left eigenvector\n* corresponding to the eigenvalue W of a complex upper Hessenberg\n* matrix H.\n*\n\n* Arguments\n* =========\n*\n* RIGHTV (input) LOGICAL\n* = .TRUE. : compute right eigenvector;\n* = .FALSE.: compute left eigenvector.\n*\n* NOINIT (input) LOGICAL\n* = .TRUE. : no initial vector supplied in V\n* = .FALSE.: initial vector supplied in V.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* H (input) COMPLEX*16 array, dimension (LDH,N)\n* The upper Hessenberg matrix H.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (input) COMPLEX*16\n* The eigenvalue of H whose corresponding right or left\n* eigenvector is to be computed.\n*\n* V (input/output) COMPLEX*16 array, dimension (N)\n* On entry, if NOINIT = .FALSE., V must contain a starting\n* vector for inverse iteration; otherwise V need not be set.\n* On exit, V contains the computed eigenvector, normalized so\n* that the component of largest magnitude has magnitude 1; here\n* the magnitude of a complex number (x,y) is taken to be\n* |x| + |y|.\n*\n* B (workspace) COMPLEX*16 array, dimension (LDB,N)\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* EPS3 (input) DOUBLE PRECISION\n* A small machine-dependent value which is used to perturb\n* close eigenvalues, and to replace zero pivots.\n*\n* SMLNUM (input) DOUBLE PRECISION\n* A machine-dependent value close to the underflow threshold.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* = 1: inverse iteration did not converge; V is set to the\n* last iterate.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_rightv = argv[0];
- rb_noinit = argv[1];
- rb_h = argv[2];
- rb_w = argv[3];
- rb_v = argv[4];
- rb_eps3 = argv[5];
- rb_smlnum = argv[6];
-
- smlnum = NUM2DBL(rb_smlnum);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (5th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- w.r = NUM2DBL(rb_funcall(rb_w, rb_intern("real"), 0));
- w.i = NUM2DBL(rb_funcall(rb_w, rb_intern("imag"), 0));
- eps3 = NUM2DBL(rb_eps3);
- noinit = (rb_noinit == Qtrue);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (3th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 0 of v");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- rightv = (rb_rightv == Qtrue);
- ldb = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_v_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublecomplex*);
- MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- b = ALLOC_N(doublecomplex, (ldb)*(n));
- rwork = ALLOC_N(doublereal, (n));
-
- zlaein_(&rightv, &noinit, &n, h, &ldh, &w, v, b, &ldb, rwork, &eps3, &smlnum, &info);
-
- free(b);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_v);
-}
-
-void
-init_lapack_zlaein(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaein", rb_zlaein, -1);
-}
diff --git a/zlaesy.c b/zlaesy.c
deleted file mode 100644
index e28aa34..0000000
--- a/zlaesy.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaesy_(doublecomplex *a, doublecomplex *b, doublecomplex *c, doublecomplex *rt1, doublecomplex *rt2, doublecomplex *evscal, doublecomplex *cs1, doublecomplex *sn1);
-
-static VALUE
-rb_zlaesy(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex a;
- VALUE rb_b;
- doublecomplex b;
- VALUE rb_c;
- doublecomplex c;
- VALUE rb_rt1;
- doublecomplex rt1;
- VALUE rb_rt2;
- doublecomplex rt2;
- VALUE rb_evscal;
- doublecomplex evscal;
- VALUE rb_cs1;
- doublecomplex cs1;
- VALUE rb_sn1;
- doublecomplex sn1;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.zlaesy( a, b, c)\n or\n NumRu::Lapack.zlaesy # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* ZLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n* ( ( A, B );( B, C ) )\n* provided the norm of the matrix of eigenvectors is larger than\n* some threshold value.\n*\n* RT1 is the eigenvalue of larger absolute value, and RT2 of\n* smaller absolute value. If the eigenvectors are computed, then\n* on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n*\n* [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]\n* [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX*16\n* The ( 1, 1 ) element of input matrix.\n*\n* B (input) COMPLEX*16\n* The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element\n* is also given by B, since the 2-by-2 matrix is symmetric.\n*\n* C (input) COMPLEX*16\n* The ( 2, 2 ) element of input matrix.\n*\n* RT1 (output) COMPLEX*16\n* The eigenvalue of larger modulus.\n*\n* RT2 (output) COMPLEX*16\n* The eigenvalue of smaller modulus.\n*\n* EVSCAL (output) COMPLEX*16\n* The complex value by which the eigenvector matrix was scaled\n* to make it orthonormal. If EVSCAL is zero, the eigenvectors\n* were not computed. This means one of two things: the 2-by-2\n* matrix could not be diagonalized, or the norm of the matrix\n* of eigenvectors before scaling was larger than the threshold\n* value THRESH (set below).\n*\n* CS1 (output) COMPLEX*16\n* SN1 (output) COMPLEX*16\n* If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector\n* for RT1.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a.r = NUM2DBL(rb_funcall(rb_a, rb_intern("real"), 0));
- a.i = NUM2DBL(rb_funcall(rb_a, rb_intern("imag"), 0));
- b.r = NUM2DBL(rb_funcall(rb_b, rb_intern("real"), 0));
- b.i = NUM2DBL(rb_funcall(rb_b, rb_intern("imag"), 0));
- c.r = NUM2DBL(rb_funcall(rb_c, rb_intern("real"), 0));
- c.i = NUM2DBL(rb_funcall(rb_c, rb_intern("imag"), 0));
-
- zlaesy_(&a, &b, &c, &rt1, &rt2, &evscal, &cs1, &sn1);
-
- rb_rt1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt1.r)), rb_float_new((double)(rt1.i)));
- rb_rt2 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt2.r)), rb_float_new((double)(rt2.i)));
- rb_evscal = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(evscal.r)), rb_float_new((double)(evscal.i)));
- rb_cs1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(cs1.r)), rb_float_new((double)(cs1.i)));
- rb_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
- return rb_ary_new3(5, rb_rt1, rb_rt2, rb_evscal, rb_cs1, rb_sn1);
-}
-
-void
-init_lapack_zlaesy(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaesy", rb_zlaesy, -1);
-}
diff --git a/zlaev2.c b/zlaev2.c
deleted file mode 100644
index 061b65a..0000000
--- a/zlaev2.c
+++ /dev/null
@@ -1,52 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaev2_(doublecomplex *a, doublecomplex *b, doublecomplex *c, doublereal *rt1, doublereal *rt2, doublereal *cs1, doublecomplex *sn1);
-
-static VALUE
-rb_zlaev2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex a;
- VALUE rb_b;
- doublecomplex b;
- VALUE rb_c;
- doublecomplex c;
- VALUE rb_rt1;
- doublereal rt1;
- VALUE rb_rt2;
- doublereal rt2;
- VALUE rb_cs1;
- doublereal cs1;
- VALUE rb_sn1;
- doublecomplex sn1;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rt1, rt2, cs1, sn1 = NumRu::Lapack.zlaev2( a, b, c)\n or\n NumRu::Lapack.zlaev2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n* Purpose\n* =======\n*\n* ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n* [ A B ]\n* [ CONJG(B) C ].\n* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n* eigenvector for RT1, giving the decomposition\n*\n* [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ]\n* [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ].\n*\n\n* Arguments\n* =========\n*\n* A (input) COMPLEX*16\n* The (1,1) element of the 2-by-2 matrix.\n*\n* B (input) COMPLEX*16\n* The (1,2) element and the conjugate of the (2,1) element of\n* the 2-by-2 matrix.\n*\n* C (input) COMPLEX*16\n* The (2,2) element of the 2-by-2 matrix.\n*\n* RT1 (output) DOUBLE PRECISION\n* The eigenvalue of larger absolute value.\n*\n* RT2 (output) DOUBLE PRECISION\n* The eigenvalue of smaller absolute value.\n*\n* CS1 (output) DOUBLE PRECISION\n* SN1 (output) COMPLEX*16\n* The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n* Further Details\n* ===============\n*\n* RT1 is accurate to a few ulps barring over/underflow.\n*\n* RT2 may be inaccurate if there is massive cancellation in the\n* determinant A*C-B*B; higher precision or correctly rounded or\n* correctly truncated arithmetic would be needed to compute RT2\n* accurately in all cases.\n*\n* CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n* Overflow is possible only if RT1 is within a factor of 5 of overflow.\n* Underflow is harmless if the input data is 0 or exceeds\n* underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
- rb_c = argv[2];
-
- a.r = NUM2DBL(rb_funcall(rb_a, rb_intern("real"), 0));
- a.i = NUM2DBL(rb_funcall(rb_a, rb_intern("imag"), 0));
- b.r = NUM2DBL(rb_funcall(rb_b, rb_intern("real"), 0));
- b.i = NUM2DBL(rb_funcall(rb_b, rb_intern("imag"), 0));
- c.r = NUM2DBL(rb_funcall(rb_c, rb_intern("real"), 0));
- c.i = NUM2DBL(rb_funcall(rb_c, rb_intern("imag"), 0));
-
- zlaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);
-
- rb_rt1 = rb_float_new((double)rt1);
- rb_rt2 = rb_float_new((double)rt2);
- rb_cs1 = rb_float_new((double)cs1);
- rb_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
- return rb_ary_new3(4, rb_rt1, rb_rt2, rb_cs1, rb_sn1);
-}
-
-void
-init_lapack_zlaev2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaev2", rb_zlaev2, -1);
-}
diff --git a/zlag2c.c b/zlag2c.c
deleted file mode 100644
index 73bc831..0000000
--- a/zlag2c.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlag2c_(integer *m, integer *n, doublecomplex *a, integer *lda, complex *sa, integer *ldsa, integer *info);
-
-static VALUE
-rb_zlag2c(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_sa;
- complex *sa;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer ldsa;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.zlag2c( m, a)\n or\n NumRu::Lapack.zlag2c # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* ZLAG2C checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of lines of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* SA (output) COMPLEX array, dimension (LDSA,N)\n* On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n* INFO>0, the content of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, DIMAG\n* ..\n* .. External Functions ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- ldsa = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldsa;
- shape[1] = n;
- rb_sa = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- sa = NA_PTR_TYPE(rb_sa, complex*);
-
- zlag2c_(&m, &n, a, &lda, sa, &ldsa, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_sa, rb_info);
-}
-
-void
-init_lapack_zlag2c(VALUE mLapack){
- rb_define_module_function(mLapack, "zlag2c", rb_zlag2c, -1);
-}
diff --git a/zlags2.c b/zlags2.c
deleted file mode 100644
index 281954e..0000000
--- a/zlags2.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlags2_(logical *upper, doublereal *a1, doublecomplex *a2, doublereal *a3, doublereal *b1, doublecomplex *b2, doublereal *b3, doublereal *csu, doublecomplex *snu, doublereal *csv, doublecomplex *snv, doublereal *csq, doublecomplex *snq);
-
-static VALUE
-rb_zlags2(int argc, VALUE *argv, VALUE self){
- VALUE rb_upper;
- logical upper;
- VALUE rb_a1;
- doublereal a1;
- VALUE rb_a2;
- doublecomplex a2;
- VALUE rb_a3;
- doublereal a3;
- VALUE rb_b1;
- doublereal b1;
- VALUE rb_b2;
- doublecomplex b2;
- VALUE rb_b3;
- doublereal b3;
- VALUE rb_csu;
- doublereal csu;
- VALUE rb_snu;
- doublecomplex snu;
- VALUE rb_csv;
- doublereal csv;
- VALUE rb_snv;
- doublecomplex snv;
- VALUE rb_csq;
- doublereal csq;
- VALUE rb_snq;
- doublecomplex snq;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n csu, snu, csv, snv, csq, snq = NumRu::Lapack.zlags2( upper, a1, a2, a3, b1, b2, b3)\n or\n NumRu::Lapack.zlags2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n* Purpose\n* =======\n*\n* ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n* that if ( UPPER ) then\n*\n* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n* ( 0 A3 ) ( x x )\n* and\n* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n* ( 0 B3 ) ( x x )\n*\n* or if ( .NOT.UPPER ) then\n*\n* U'*A*Q = U'*( A1 0 )*Q = ( x x )\n* ( A2 A3 ) ( 0 x )\n* and\n* V'*B*Q = V'*( B1 0 )*Q = ( x x )\n* ( B2 B3 ) ( 0 x )\n* where\n*\n* U = ( CSU SNU ), V = ( CSV SNV ),\n* ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV )\n*\n* Q = ( CSQ SNQ )\n* ( -CONJG(SNQ) CSQ )\n*\n* Z' denotes the conjugate transpose of Z.\n*\n* The rows of the transformed A and B are parallel. Moreover, if the\n* input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n* of A is not zero. If the input matrices A and B are both not zero,\n* then the transformed (2,2) element of B is not zero, except when the\n* first rows of input A and B are parallel and the second rows are\n* zero.\n*\n\n* Arguments\n* =========\n*\n* UPPER (input) LOGICAL\n* = .TRUE.: the input matrices A and B are upper triangular.\n* = .FALSE.: the input matrices A and B are lower triangular.\n*\n* A1 (input) DOUBLE PRECISION\n* A2 (input) COMPLEX*16\n* A3 (input) DOUBLE PRECISION\n* On entry, A1, A2 and A3 are elements of the input 2-by-2\n* upper (lower) triangular matrix A.\n*\n* B1 (input) DOUBLE PRECISION\n* B2 (input) COMPLEX*16\n* B3 (input) DOUBLE PRECISION\n* On entry, B1, B2 and B3 are elements of the input 2-by-2\n* upper (lower) triangular matrix B.\n*\n* CSU (output) DOUBLE PRECISION\n* SNU (output) COMPLEX*16\n* The desired unitary matrix U.\n*\n* CSV (output) DOUBLE PRECISION\n* SNV (output) COMPLEX*16\n* The desired unitary matrix V.\n*\n* CSQ (output) DOUBLE PRECISION\n* SNQ (output) COMPLEX*16\n* The desired unitary matrix Q.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_upper = argv[0];
- rb_a1 = argv[1];
- rb_a2 = argv[2];
- rb_a3 = argv[3];
- rb_b1 = argv[4];
- rb_b2 = argv[5];
- rb_b3 = argv[6];
-
- b1 = NUM2DBL(rb_b1);
- upper = (rb_upper == Qtrue);
- b2.r = NUM2DBL(rb_funcall(rb_b2, rb_intern("real"), 0));
- b2.i = NUM2DBL(rb_funcall(rb_b2, rb_intern("imag"), 0));
- a1 = NUM2DBL(rb_a1);
- b3 = NUM2DBL(rb_b3);
- a2.r = NUM2DBL(rb_funcall(rb_a2, rb_intern("real"), 0));
- a2.i = NUM2DBL(rb_funcall(rb_a2, rb_intern("imag"), 0));
- a3 = NUM2DBL(rb_a3);
-
- zlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);
-
- rb_csu = rb_float_new((double)csu);
- rb_snu = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snu.r)), rb_float_new((double)(snu.i)));
- rb_csv = rb_float_new((double)csv);
- rb_snv = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snv.r)), rb_float_new((double)(snv.i)));
- rb_csq = rb_float_new((double)csq);
- rb_snq = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snq.r)), rb_float_new((double)(snq.i)));
- return rb_ary_new3(6, rb_csu, rb_snu, rb_csv, rb_snv, rb_csq, rb_snq);
-}
-
-void
-init_lapack_zlags2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlags2", rb_zlags2, -1);
-}
diff --git a/zlagtm.c b/zlagtm.c
deleted file mode 100644
index e612ddf..0000000
--- a/zlagtm.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlagtm_(char *trans, integer *n, integer *nrhs, doublereal *alpha, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *x, integer *ldx, doublereal *beta, doublecomplex *b, integer *ldb);
-
-static VALUE
-rb_zlagtm(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_alpha;
- doublereal alpha;
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_beta;
- doublereal beta;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldx;
- integer nrhs;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.zlagtm( trans, alpha, dl, d, du, x, beta, b)\n or\n NumRu::Lapack.zlagtm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n* Purpose\n* =======\n*\n* ZLAGTM performs a matrix-vector product of the form\n*\n* B := alpha * A * X + beta * B\n*\n* where A is a tridiagonal matrix of order N, B and X are N by NRHS\n* matrices, and alpha and beta are real scalars, each of which may be\n* 0., 1., or -1.\n*\n\n* Arguments\n* =========\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': No transpose, B := alpha * A * X + beta * B\n* = 'T': Transpose, B := alpha * A**T * X + beta * B\n* = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B\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 X and B.\n*\n* ALPHA (input) DOUBLE PRECISION\n* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 0.\n*\n* DL (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) sub-diagonal elements of T.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The diagonal elements of T.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) super-diagonal elements of T.\n*\n* X (input) COMPLEX*16 array, dimension (LDX,NRHS)\n* The N by NRHS matrix X.\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(N,1).\n*\n* BETA (input) DOUBLE PRECISION\n* The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n* it is assumed to be 1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N by NRHS matrix B.\n* On exit, B is overwritten by the matrix expression\n* B := alpha * A * X + beta * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(N,1).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_alpha = argv[1];
- rb_dl = argv[2];
- rb_d = argv[3];
- rb_du = argv[4];
- rb_x = argv[5];
- rb_beta = argv[6];
- rb_b = argv[7];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- beta = NUM2DBL(rb_beta);
- alpha = NUM2DBL(rb_alpha);
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (5th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zlagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_zlagtm(VALUE mLapack){
- rb_define_module_function(mLapack, "zlagtm", rb_zlagtm, -1);
-}
diff --git a/zlahef.c b/zlahef.c
deleted file mode 100644
index b21874b..0000000
--- a/zlahef.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlahef_(char *uplo, integer *n, integer *nb, integer *kb, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w, integer *ldw, integer *info);
-
-static VALUE
-rb_zlahef(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *w;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.zlahef( uplo, nb, a)\n or\n NumRu::Lapack.zlahef # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* ZLAHEF computes a partial factorization of a complex Hermitian\n* matrix A using the Bunch-Kaufman diagonal pivoting method. The\n* partial factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the conjugate transpose of U.\n*\n* ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX*16 array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- w = ALLOC_N(doublecomplex, (ldw)*(MAX(n,nb)));
-
- zlahef_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
-
- free(w);
- rb_kb = INT2NUM(kb);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_kb, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_zlahef(VALUE mLapack){
- rb_define_module_function(mLapack, "zlahef", rb_zlahef, -1);
-}
diff --git a/zlahqr.c b/zlahqr.c
deleted file mode 100644
index e2add60..0000000
--- a/zlahqr.c
+++ /dev/null
@@ -1,116 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlahqr_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublecomplex *h, integer *ldh, doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z, integer *ldz, integer *info);
-
-static VALUE
-rb_zlahqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, info, h, z = NumRu::Lapack.zlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz)\n or\n NumRu::Lapack.zlahqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n* Purpose\n* =======\n*\n* ZLAHQR is an auxiliary routine called by CHSEQR to update the\n* eigenvalues and Schur decomposition already computed by CHSEQR, by\n* dealing with the Hessenberg submatrix in rows and columns ILO to\n* IHI.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows and\n* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n* ZLAHQR works primarily with the Hessenberg submatrix in rows\n* and columns ILO to IHI, but applies transformations to all of\n* H if WANTT is .TRUE..\n* 1 <= ILO <= max(1,IHI); IHI <= N.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO is zero and if WANTT is .TRUE., then H\n* is upper triangular in rows and columns ILO:IHI. If INFO\n* is zero and if WANTT is .FALSE., then the contents of H\n* are unspecified on exit. The output state of H in case\n* INF is positive is below under the description of INFO.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH >= max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues ILO to IHI are stored in the\n* corresponding elements of W. If WANTT is .TRUE., the\n* eigenvalues are stored in the same order as on the diagonal\n* of the Schur form returned in H, with W(i) = H(i,i).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE..\n* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If WANTZ is .TRUE., on entry Z must contain the current\n* matrix Z of transformations accumulated by CHSEQR, and on\n* exit Z has been updated; transformations are applied only to\n* the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n* If WANTZ is .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, ZLAHQR failed to compute all the\n* eigenvalues ILO to IHI in a total of 30 iterations\n* per eigenvalue; elements i+1:ihi of W contain\n* those eigenvalues which have been successfully\n* computed.\n*\n* If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the\n* eigenvalues of the upper Hessenberg matrix\n* rows and columns ILO thorugh INFO of the final,\n* output value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n* (*) (initial value of H)*U = U*(final value of H)\n* where U is an orthognal matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n* (final value of Z) = (initial value of Z)*U\n* where U is the orthogonal matrix in (*)\n* (regardless of the value of WANTT.)\n*\n\n* Further Details\n* ===============\n*\n* 02-96 Based on modifications by\n* David Day, Sandia National Laboratory, USA\n*\n* 12-04 Further modifications by\n* Ralph Byers, University of Kansas, USA\n* This is a modified version of ZLAHQR from LAPACK version 3.0.\n* It is (1) more robust against overflow and underflow and\n* (2) adopts the more conservative Ahues & Tisseur stopping\n* criterion (LAWN 122, 1997).\n*\n* =========================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_iloz = argv[5];
- rb_ihiz = argv[6];
- rb_z = argv[7];
- rb_ldz = argv[8];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- ldz = NUM2INT(rb_ldz);
- ihi = NUM2INT(rb_ihi);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? n : 0;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- zlahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_w, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_zlahqr(VALUE mLapack){
- rb_define_module_function(mLapack, "zlahqr", rb_zlahqr, -1);
-}
diff --git a/zlahr2.c b/zlahr2.c
deleted file mode 100644
index 2f9a6ee..0000000
--- a/zlahr2.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlahr2_(integer *n, integer *k, integer *nb, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t, integer *ldt, doublecomplex *y, integer *ldy);
-
-static VALUE
-rb_zlahr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.zlahr2( n, k, nb, a)\n or\n NumRu::Lapack.zlahr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by an unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an auxiliary routine called by ZGEHRD.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n* K < N.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX*16 array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX*16 array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= N.\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a a a a a )\n* ( a a a a a )\n* ( a a a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n* incorporating improvements proposed by Quintana-Orti and Van de\n* Gejin. Note that the entries of A(1:K,2:NB) differ from those\n* returned by the original LAPACK-3.0's DLAHRD routine. (This\n* subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n* References\n* ==========\n*\n* Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n* performance of reduction to Hessenberg form,\" ACM Transactions on\n* Mathematical Software, 32(2):180-194, June 2006.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ldt = nb;
- ldy = n;
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_zlahr2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlahr2", rb_zlahr2, -1);
-}
diff --git a/zlahrd.c b/zlahrd.c
deleted file mode 100644
index d82edc6..0000000
--- a/zlahrd.c
+++ /dev/null
@@ -1,93 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlahrd_(integer *n, integer *k, integer *nb, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t, integer *ldt, doublecomplex *y, integer *ldy);
-
-static VALUE
-rb_zlahrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_k;
- integer k;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer ldt;
- integer ldy;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, t, y, a = NumRu::Lapack.zlahrd( n, k, nb, a)\n or\n NumRu::Lapack.zlahrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n* Purpose\n* =======\n*\n* ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n* matrix A so that elements below the k-th subdiagonal are zero. The\n* reduction is performed by a unitary similarity transformation\n* Q' * A * Q. The routine returns the matrices V and T which determine\n* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n* This is an OBSOLETE auxiliary routine. \n* This routine will be 'deprecated' in a future release.\n* Please use the new routine ZLAHR2 instead.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A.\n*\n* K (input) INTEGER\n* The offset for the reduction. Elements below the k-th\n* subdiagonal in the first NB columns are reduced to zero.\n*\n* NB (input) INTEGER\n* The number of columns to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n* On entry, the n-by-(n-k+1) general matrix A.\n* On exit, the elements on and above the k-th subdiagonal in\n* the first NB columns are overwritten with the corresponding\n* elements of the reduced matrix; the elements below the k-th\n* subdiagonal, with the array TAU, represent the matrix Q as a\n* product of elementary reflectors. The other columns of A are\n* unchanged. See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (output) COMPLEX*16 array, dimension (NB)\n* The scalar factors of the elementary reflectors. See Further\n* Details.\n*\n* T (output) COMPLEX*16 array, dimension (LDT,NB)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= NB.\n*\n* Y (output) COMPLEX*16 array, dimension (LDY,NB)\n* The n-by-nb matrix Y.\n*\n* LDY (input) INTEGER\n* The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* The matrix Q is represented as a product of nb elementary reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n* A(i+k+1:n,i), and tau in TAU(i).\n*\n* The elements of the vectors v together form the (n-k+1)-by-nb matrix\n* V which is needed, with T and Y, to apply the transformation to the\n* unreduced part of the matrix, using an update of the form:\n* A := (I - V*T*V') * (A - Y*V').\n*\n* The contents of A on exit are illustrated by the following example\n* with n = 7, k = 3 and nb = 2:\n*\n* ( a h a a a )\n* ( a h a a a )\n* ( a h a a a )\n* ( h h a a a )\n* ( v1 h a a a )\n* ( v1 v2 a a a )\n* ( v1 v2 a a a )\n*\n* where a denotes an element of the original matrix A, h denotes a\n* modified element of the upper Hessenberg matrix H, and vi denotes an\n* element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_k = argv[1];
- rb_nb = argv[2];
- rb_a = argv[3];
-
- k = NUM2INT(rb_k);
- nb = NUM2INT(rb_nb);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (n-k+1))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ldt = nb;
- ldy = MAX(1,n);
- {
- int shape[1];
- shape[0] = MAX(1,nb);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = MAX(1,nb);
- rb_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldy;
- shape[1] = MAX(1,nb);
- rb_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n-k+1;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);
-
- return rb_ary_new3(4, rb_tau, rb_t, rb_y, rb_a);
-}
-
-void
-init_lapack_zlahrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zlahrd", rb_zlahrd, -1);
-}
diff --git a/zlaic1.c b/zlaic1.c
deleted file mode 100644
index 33ae96e..0000000
--- a/zlaic1.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaic1_(integer *job, integer *j, doublecomplex *x, doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal *sestpr, doublecomplex *s, doublecomplex *c);
-
-static VALUE
-rb_zlaic1(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- integer job;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_sest;
- doublereal sest;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_gamma;
- doublecomplex gamma;
- VALUE rb_sestpr;
- doublereal sestpr;
- VALUE rb_s;
- doublecomplex s;
- VALUE rb_c;
- doublecomplex c;
-
- integer j;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sestpr, s, c = NumRu::Lapack.zlaic1( job, x, sest, w, gamma)\n or\n NumRu::Lapack.zlaic1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n* Purpose\n* =======\n*\n* ZLAIC1 applies one step of incremental condition estimation in\n* its simplest version:\n*\n* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n* lower triangular matrix L, such that\n* twonorm(L*x) = sest\n* Then ZLAIC1 computes sestpr, s, c such that\n* the vector\n* [ s*x ]\n* xhat = [ c ]\n* is an approximate singular vector of\n* [ L 0 ]\n* Lhat = [ w' gamma ]\n* in the sense that\n* twonorm(Lhat*xhat) = sestpr.\n*\n* Depending on JOB, an estimate for the largest or smallest singular\n* value is computed.\n*\n* Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n* diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]\n* [ conjg(gamma) ]\n*\n* where alpha = conjg(x)'*w.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) INTEGER\n* = 1: an estimate for the largest singular value is computed.\n* = 2: an estimate for the smallest singular value is computed.\n*\n* J (input) INTEGER\n* Length of X and W\n*\n* X (input) COMPLEX*16 array, dimension (J)\n* The j-vector x.\n*\n* SEST (input) DOUBLE PRECISION\n* Estimated singular value of j by j matrix L\n*\n* W (input) COMPLEX*16 array, dimension (J)\n* The j-vector w.\n*\n* GAMMA (input) COMPLEX*16\n* The diagonal element gamma.\n*\n* SESTPR (output) DOUBLE PRECISION\n* Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n* S (output) COMPLEX*16\n* Sine needed in forming xhat.\n*\n* C (output) COMPLEX*16\n* Cosine needed in forming xhat.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_job = argv[0];
- rb_x = argv[1];
- rb_sest = argv[2];
- rb_w = argv[3];
- rb_gamma = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (4th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
- j = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DCOMPLEX)
- rb_w = na_change_type(rb_w, NA_DCOMPLEX);
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != j)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of w");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- gamma.r = NUM2DBL(rb_funcall(rb_gamma, rb_intern("real"), 0));
- gamma.i = NUM2DBL(rb_funcall(rb_gamma, rb_intern("imag"), 0));
- job = NUM2INT(rb_job);
- sest = NUM2DBL(rb_sest);
-
- zlaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);
-
- rb_sestpr = rb_float_new((double)sestpr);
- rb_s = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(s.r)), rb_float_new((double)(s.i)));
- rb_c = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(c.r)), rb_float_new((double)(c.i)));
- return rb_ary_new3(3, rb_sestpr, rb_s, rb_c);
-}
-
-void
-init_lapack_zlaic1(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaic1", rb_zlaic1, -1);
-}
diff --git a/zlals0.c b/zlals0.c
deleted file mode 100644
index 7e81ed3..0000000
--- a/zlals0.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlals0_(integer *icompq, integer *nl, integer *nr, integer *sqre, integer *nrhs, doublecomplex *b, integer *ldb, doublecomplex *bx, integer *ldbx, integer *perm, integer *givptr, integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum, doublereal *poles, doublereal *difl, doublereal *difr, doublereal *z, integer *k, doublereal *c, doublereal *s, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zlals0(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_nl;
- integer nl;
- VALUE rb_nr;
- integer nr;
- VALUE rb_sqre;
- integer sqre;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givptr;
- integer givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_poles;
- doublereal *poles;
- VALUE rb_difl;
- doublereal *difl;
- VALUE rb_difr;
- doublereal *difr;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_c;
- doublereal c;
- VALUE rb_s;
- doublereal s;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *bx;
- doublereal *rwork;
-
- integer ldb;
- integer nrhs;
- integer n;
- integer ldgcol;
- integer ldgnum;
- integer k;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s)\n or\n NumRu::Lapack.zlals0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLALS0 applies back the multiplying factors of either the left or the\n* right singular vector matrix of a diagonal matrix appended by a row\n* to the right hand side matrix B in solving the least squares problem\n* using the divide-and-conquer SVD approach.\n*\n* For the left singular vector matrix, three types of orthogonal\n* matrices are involved:\n*\n* (1L) Givens rotations: the number of such rotations is GIVPTR; the\n* pairs of columns/rows they were applied to are stored in GIVCOL;\n* and the C- and S-values of these rotations are stored in GIVNUM.\n*\n* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n* row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n* J-th row.\n*\n* (3L) The left singular vector matrix of the remaining matrix.\n*\n* For the right singular vector matrix, four types of orthogonal\n* matrices are involved:\n*\n* (1R) The right singular vector matrix of the remaining matrix.\n*\n* (2R) If SQRE = 1, one extra Givens rotation to generate the right\n* null space.\n*\n* (3R) The inverse transformation of (2L).\n*\n* (4R) The inverse transformation of (1L).\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether singular vectors are to be computed in\n* factored form:\n* = 0: Left singular vector matrix.\n* = 1: Right singular vector matrix.\n*\n* NL (input) INTEGER\n* The row dimension of the upper block. NL >= 1.\n*\n* NR (input) INTEGER\n* The row dimension of the lower block. NR >= 1.\n*\n* SQRE (input) INTEGER\n* = 0: the lower block is an NR-by-NR square matrix.\n* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n* The bidiagonal matrix has row dimension N = NL + NR + 1,\n* and column dimension M = N + SQRE.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M. On output, B contains\n* the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B. LDB must be at least\n* max(1,MAX( M, N ) ).\n*\n* BX (workspace) COMPLEX*16 array, dimension ( LDBX, NRHS )\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* PERM (input) INTEGER array, dimension ( N )\n* The permutations (from deflation and sorting) applied\n* to the two blocks.\n*\n* GIVPTR (input) INTEGER\n* The number of Givens rotations which took place in this\n* subproblem.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n* Each pair of numbers indicates a pair of rows/columns\n* involved in a Givens rotation.\n*\n* LDGCOL (input) INTEGER\n* The leading dimension of GIVCOL, must be at least N.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* Each number indicates the C or S value used in the\n* corresponding Givens rotation.\n*\n* LDGNUM (input) INTEGER\n* The leading dimension of arrays DIFR, POLES and\n* GIVNUM, must be at least K.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n* On entry, POLES(1:K, 1) contains the new singular\n* values obtained from solving the secular equation, and\n* POLES(1:K, 2) is an array containing the poles in the secular\n* equation.\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( K ).\n* On entry, DIFL(I) is the distance between I-th updated\n* (undeflated) singular value and the I-th (undeflated) old\n* singular value.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n* On entry, DIFR(I, 1) contains the distances between I-th\n* updated (undeflated) singular value and the I+1-th\n* (undeflated) old singular value. And DIFR(I, 2) is the\n* normalizing factor for the I-th right singular vector.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( K )\n* Contain the components of the deflation-adjusted updating row\n* vector.\n*\n* K (input) INTEGER\n* Contains the dimension of the non-deflated matrix,\n* This is the order of the related secular equation. 1 <= K <=N.\n*\n* C (input) DOUBLE PRECISION\n* C contains garbage if SQRE =0 and the C-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* S (input) DOUBLE PRECISION\n* S contains garbage if SQRE =0 and the S-value of a Givens\n* rotation related to the right null space if SQRE = 1.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension\n* ( K*(1+NRHS) + 2*NRHS )\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* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_nl = argv[1];
- rb_nr = argv[2];
- rb_sqre = argv[3];
- rb_b = argv[4];
- rb_perm = argv[5];
- rb_givptr = argv[6];
- rb_givcol = argv[7];
- rb_givnum = argv[8];
- rb_poles = argv[9];
- rb_difl = argv[10];
- rb_difr = argv[11];
- rb_z = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
- if (NA_RANK(rb_difl) != 1)
- rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
- k = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_DFLOAT)
- rb_difl = na_change_type(rb_difl, NA_DFLOAT);
- difl = NA_PTR_TYPE(rb_difl, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- c = NUM2DBL(rb_c);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
- ldgcol = NA_SHAPE0(rb_givcol);
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (13th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- nr = NUM2INT(rb_nr);
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
- ldgnum = NA_SHAPE0(rb_poles);
- if (NA_TYPE(rb_poles) != NA_DFLOAT)
- rb_poles = na_change_type(rb_poles, NA_DFLOAT);
- poles = NA_PTR_TYPE(rb_poles, doublereal*);
- icompq = NUM2INT(rb_icompq);
- nl = NUM2INT(rb_nl);
- sqre = NUM2INT(rb_sqre);
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
- if (NA_SHAPE0(rb_givnum) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of poles");
- if (NA_TYPE(rb_givnum) != NA_DFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_DFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
- if (NA_RANK(rb_perm) != 1)
- rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- s = NUM2DBL(rb_s);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
- if (NA_SHAPE0(rb_difr) != ldgnum)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of poles");
- if (NA_TYPE(rb_difr) != NA_DFLOAT)
- rb_difr = na_change_type(rb_difr, NA_DFLOAT);
- difr = NA_PTR_TYPE(rb_difr, doublereal*);
- givptr = NUM2INT(rb_givptr);
- ldbx = n;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- bx = ALLOC_N(doublecomplex, (ldbx)*(nrhs));
- rwork = ALLOC_N(doublereal, (k*(1+nrhs) + 2*nrhs));
-
- zlals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, rwork, &info);
-
- free(bx);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zlals0(VALUE mLapack){
- rb_define_module_function(mLapack, "zlals0", rb_zlals0, -1);
-}
diff --git a/zlalsa.c b/zlalsa.c
deleted file mode 100644
index 64f0274..0000000
--- a/zlalsa.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlalsa_(integer *icompq, integer *smlsiz, integer *n, integer *nrhs, doublecomplex *b, integer *ldb, doublecomplex *bx, integer *ldbx, doublereal *u, integer *ldu, doublereal *vt, integer *k, doublereal *difl, doublereal *difr, doublereal *z, doublereal *poles, integer *givptr, integer *givcol, integer *ldgcol, integer *perm, doublereal *givnum, doublereal *c, doublereal *s, doublereal *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zlalsa(int argc, VALUE *argv, VALUE self){
- VALUE rb_icompq;
- integer icompq;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_u;
- doublereal *u;
- VALUE rb_vt;
- doublereal *vt;
- VALUE rb_k;
- integer *k;
- VALUE rb_difl;
- doublereal *difl;
- VALUE rb_difr;
- doublereal *difr;
- VALUE rb_z;
- doublereal *z;
- VALUE rb_poles;
- doublereal *poles;
- VALUE rb_givptr;
- integer *givptr;
- VALUE rb_givcol;
- integer *givcol;
- VALUE rb_perm;
- integer *perm;
- VALUE rb_givnum;
- doublereal *givnum;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_bx;
- doublecomplex *bx;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublereal *rwork;
- integer *iwork;
-
- integer ldb;
- integer nrhs;
- integer ldu;
- integer smlsiz;
- integer n;
- integer nlvl;
- integer ldgcol;
- integer ldbx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n bx, info, b = NumRu::Lapack.zlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s)\n or\n NumRu::Lapack.zlalsa # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLALSA is an itermediate step in solving the least squares problem\n* by computing the SVD of the coefficient matrix in compact form (The\n* singular vectors are computed as products of simple orthorgonal\n* matrices.).\n*\n* If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector\n* matrix of an upper bidiagonal matrix to the right hand side; and if\n* ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the\n* right hand side. The singular vector matrices were generated in\n* compact form by ZLALSA.\n*\n\n* Arguments\n* =========\n*\n* ICOMPQ (input) INTEGER\n* Specifies whether the left or the right singular vector\n* matrix is involved.\n* = 0: Left singular vector matrix\n* = 1: Right singular vector matrix\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The row and column dimensions of the upper bidiagonal matrix.\n*\n* NRHS (input) INTEGER\n* The number of columns of B and BX. NRHS must be at least 1.\n*\n* B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n* On input, B contains the right hand sides of the least\n* squares problem in rows 1 through M.\n* On output, B contains the solution X in rows 1 through N.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,MAX( M, N ) ).\n*\n* BX (output) COMPLEX*16 array, dimension ( LDBX, NRHS )\n* On exit, the result of applying the left or right singular\n* vector matrix to B.\n*\n* LDBX (input) INTEGER\n* The leading dimension of BX.\n*\n* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n* On entry, U contains the left singular vector matrices of all\n* subproblems at the bottom level.\n*\n* LDU (input) INTEGER, LDU = > N.\n* The leading dimension of arrays U, VT, DIFL, DIFR,\n* POLES, GIVNUM, and Z.\n*\n* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n* On entry, VT' contains the right singular vector matrices of\n* all subproblems at the bottom level.\n*\n* K (input) INTEGER array, dimension ( N ).\n*\n* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n* distances between singular values on the I-th level and\n* singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n* record the normalizing factors of the right singular vectors\n* matrices of subproblems on I-th level.\n*\n* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n* On entry, Z(1, I) contains the components of the deflation-\n* adjusted updating row vector for subproblems on the I-th\n* level.\n*\n* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n* singular values involved in the secular equations on the I-th\n* level.\n*\n* GIVPTR (input) INTEGER array, dimension ( N ).\n* On entry, GIVPTR( I ) records the number of Givens\n* rotations performed on the I-th problem on the computation\n* tree.\n*\n* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n* locations of Givens rotations performed on the I-th level on\n* the computation tree.\n*\n* LDGCOL (input) INTEGER, LDGCOL = > N.\n* The leading dimension of arrays GIVCOL and PERM.\n*\n* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n* On entry, PERM(*, I) records permutations done on the I-th\n* level of the computation tree.\n*\n* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n* values of Givens rotations performed on the I-th level on the\n* computation tree.\n*\n* C (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* C( I ) contains the C-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* S (input) DOUBLE PRECISION array, dimension ( N ).\n* On entry, if the I-th subproblem is not square,\n* S( I ) contains the S-value of a Givens rotation related to\n* the right null space of the I-th subproblem.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension at least\n* MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n*\n* IWORK (workspace) INTEGER array.\n* The dimension must be at least 3 * 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* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 15)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
- rb_icompq = argv[0];
- rb_b = argv[1];
- rb_u = argv[2];
- rb_vt = argv[3];
- rb_k = argv[4];
- rb_difl = argv[5];
- rb_difr = argv[6];
- rb_z = argv[7];
- rb_poles = argv[8];
- rb_givptr = argv[9];
- rb_givcol = argv[10];
- rb_perm = argv[11];
- rb_givnum = argv[12];
- rb_c = argv[13];
- rb_s = argv[14];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (5th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- if (!NA_IsNArray(rb_difl))
- rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
- if (NA_RANK(rb_difl) != 2)
- rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
- nlvl = NA_SHAPE1(rb_difl);
- if (nlvl != ((int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1))
- rb_raise(rb_eRuntimeError, "shape 1 of difl must be %d", (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
- ldu = NA_SHAPE0(rb_difl);
- if (NA_TYPE(rb_difl) != NA_DFLOAT)
- rb_difl = na_change_type(rb_difl, NA_DFLOAT);
- difl = NA_PTR_TYPE(rb_difl, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (14th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (3th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
- smlsiz = NA_SHAPE1(rb_u);
- if (NA_SHAPE0(rb_u) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of u must be the same as shape 0 of difl");
- if (NA_TYPE(rb_u) != NA_DFLOAT)
- rb_u = na_change_type(rb_u, NA_DFLOAT);
- u = NA_PTR_TYPE(rb_u, doublereal*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of difl");
- if (NA_SHAPE0(rb_z) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
- if (NA_TYPE(rb_z) != NA_DFLOAT)
- rb_z = na_change_type(rb_z, NA_DFLOAT);
- z = NA_PTR_TYPE(rb_z, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (15th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- icompq = NUM2INT(rb_icompq);
- if (!NA_IsNArray(rb_perm))
- rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
- if (NA_RANK(rb_perm) != 2)
- rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_perm) != nlvl)
- rb_raise(rb_eRuntimeError, "shape 1 of perm must be the same as shape 1 of difl");
- ldgcol = NA_SHAPE0(rb_perm);
- if (NA_TYPE(rb_perm) != NA_LINT)
- rb_perm = na_change_type(rb_perm, NA_LINT);
- perm = NA_PTR_TYPE(rb_perm, integer*);
- if (!NA_IsNArray(rb_givptr))
- rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
- if (NA_RANK(rb_givptr) != 1)
- rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
- if (NA_SHAPE0(rb_givptr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
- if (NA_TYPE(rb_givptr) != NA_LINT)
- rb_givptr = na_change_type(rb_givptr, NA_LINT);
- givptr = NA_PTR_TYPE(rb_givptr, integer*);
- ldbx = n;
- if (!NA_IsNArray(rb_poles))
- rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
- if (NA_RANK(rb_poles) != 2)
- rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
- if (NA_SHAPE1(rb_poles) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_poles) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of difl");
- if (NA_TYPE(rb_poles) != NA_DFLOAT)
- rb_poles = na_change_type(rb_poles, NA_DFLOAT);
- poles = NA_PTR_TYPE(rb_poles, doublereal*);
- if (!NA_IsNArray(rb_difr))
- rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
- if (NA_RANK(rb_difr) != 2)
- rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_difr) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_difr) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of difl");
- if (NA_TYPE(rb_difr) != NA_DFLOAT)
- rb_difr = na_change_type(rb_difr, NA_DFLOAT);
- difr = NA_PTR_TYPE(rb_difr, doublereal*);
- if (!NA_IsNArray(rb_vt))
- rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
- if (NA_RANK(rb_vt) != 2)
- rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vt) != (smlsiz+1))
- rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
- if (NA_SHAPE0(rb_vt) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of difl");
- if (NA_TYPE(rb_vt) != NA_DFLOAT)
- rb_vt = na_change_type(rb_vt, NA_DFLOAT);
- vt = NA_PTR_TYPE(rb_vt, doublereal*);
- nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
- if (!NA_IsNArray(rb_givnum))
- rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
- if (NA_RANK(rb_givnum) != 2)
- rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givnum) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givnum) != ldu)
- rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of difl");
- if (NA_TYPE(rb_givnum) != NA_DFLOAT)
- rb_givnum = na_change_type(rb_givnum, NA_DFLOAT);
- givnum = NA_PTR_TYPE(rb_givnum, doublereal*);
- if (!NA_IsNArray(rb_givcol))
- rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
- if (NA_RANK(rb_givcol) != 2)
- rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
- if (NA_SHAPE1(rb_givcol) != (2 * nlvl))
- rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
- if (NA_SHAPE0(rb_givcol) != ldgcol)
- rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
- if (NA_TYPE(rb_givcol) != NA_LINT)
- rb_givcol = na_change_type(rb_givcol, NA_LINT);
- givcol = NA_PTR_TYPE(rb_givcol, integer*);
- {
- int shape[2];
- shape[0] = ldbx;
- shape[1] = nrhs;
- rb_bx = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- bx = NA_PTR_TYPE(rb_bx, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- rwork = ALLOC_N(doublereal, (MAX(n,(smlsiz+1)*nrhs*3)));
- iwork = ALLOC_N(integer, (3 * n));
-
- zlalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, rwork, iwork, &info);
-
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_bx, rb_info, rb_b);
-}
-
-void
-init_lapack_zlalsa(VALUE mLapack){
- rb_define_module_function(mLapack, "zlalsa", rb_zlalsa, -1);
-}
diff --git a/zlalsd.c b/zlalsd.c
deleted file mode 100644
index 670a99c..0000000
--- a/zlalsd.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlalsd_(char *uplo, integer *smlsiz, integer *n, integer *nrhs, doublereal *d, doublereal *e, doublecomplex *b, integer *ldb, doublereal *rcond, integer *rank, doublecomplex *work, doublereal *rwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zlalsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_smlsiz;
- integer smlsiz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *work;
- doublereal *rwork;
- integer *iwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer nlvl;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rank, info, d, e, b = NumRu::Lapack.zlalsd( uplo, smlsiz, d, e, b, rcond)\n or\n NumRu::Lapack.zlalsd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLALSD uses the singular value decomposition of A to solve the least\n* squares problem of finding X to minimize the Euclidean norm of each\n* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n* are N-by-NRHS. The solution X overwrites B.\n*\n* The singular values of A smaller than RCOND times the largest\n* singular value are treated as zero in solving the least squares\n* problem; in this case a minimum norm solution is returned.\n* The actual singular values are returned in D in ascending order.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': D and E define an upper bidiagonal matrix.\n* = 'L': D and E define a lower bidiagonal matrix.\n*\n* SMLSIZ (input) INTEGER\n* The maximum size of the subproblems at the bottom of the\n* computation tree.\n*\n* N (input) INTEGER\n* The dimension of the bidiagonal matrix. N >= 0.\n*\n* NRHS (input) INTEGER\n* The number of columns of B. NRHS must be at least 1.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry D contains the main diagonal of the bidiagonal\n* matrix. On exit, if INFO = 0, D contains its singular values.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* Contains the super-diagonal entries of the bidiagonal matrix.\n* On exit, E has been destroyed.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On input, B contains the right hand sides of the least\n* squares problem. On output, B contains the solution X.\n*\n* LDB (input) INTEGER\n* The leading dimension of B in the calling subprogram.\n* LDB must be at least max(1,N).\n*\n* RCOND (input) DOUBLE PRECISION\n* The singular values of A less than or equal to RCOND times\n* the largest singular value are treated as zero in solving\n* the least squares problem. If RCOND is negative,\n* machine precision is used instead.\n* For example, if diag(S)*X=B were the least squares problem,\n* where diag(S) is a diagonal matrix of singular values, the\n* solution would be X(i) = B(i) / S(i) if S(i) is greater than\n* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n* RCOND*max(S).\n*\n* RANK (output) INTEGER\n* The number of singular values of A greater than RCOND times\n* the largest singular value.\n*\n* WORK (workspace) COMPLEX*16 array, dimension at least\n* (N * NRHS).\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension at least\n* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n* MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n* where\n* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*\n* IWORK (workspace) INTEGER array, dimension at least\n* (3*N*NLVL + 11*N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: The algorithm failed to compute a singular value while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through MOD(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Ming Gu and Ren-Cang Li, Computer Science Division, University of\n* California at Berkeley, USA\n* Osni Marques, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_smlsiz = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_b = argv[4];
- rb_rcond = argv[5];
-
- rcond = NUM2DBL(rb_rcond);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- smlsiz = NUM2INT(rb_smlsiz);
- uplo = StringValueCStr(rb_uplo)[0];
- nlvl = ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1;
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublecomplex, (n * nrhs));
- rwork = ALLOC_N(doublereal, (9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)));
- iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));
-
- zlalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, rwork, iwork, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_rank, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_zlalsd(VALUE mLapack){
- rb_define_module_function(mLapack, "zlalsd", rb_zlalsd, -1);
-}
diff --git a/zlangb.c b/zlangb.c
deleted file mode 100644
index c2dae38..0000000
--- a/zlangb.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlangb_(char *norm, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, doublereal *work);
-
-static VALUE
-rb_zlangb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlangb( norm, kl, ku, ab)\n or\n NumRu::Lapack.zlangb # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANGB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n*\n* Description\n* ===========\n*\n* ZLANGB returns the value\n*\n* ZLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANGB as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANGB is\n* set to zero.\n*\n* KL (input) INTEGER\n* The number of sub-diagonals of the matrix A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of super-diagonals of the matrix A. KU >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n* column of A is stored in the j-th column of the array AB as\n* follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KL+KU+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_ab = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- norm = StringValueCStr(rb_norm)[0];
- ku = NUM2INT(rb_ku);
- work = ALLOC_N(doublereal, (MAX(1,lsame_(&norm,"I") ? n : 0)));
-
- __out__ = zlangb_(&norm, &n, &kl, &ku, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlangb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlangb", rb_zlangb, -1);
-}
diff --git a/zlange.c b/zlange.c
deleted file mode 100644
index c7dc99a..0000000
--- a/zlange.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlange_(char *norm, integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_zlange(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlange( norm, m, a)\n or\n NumRu::Lapack.zlange # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANGE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex matrix A.\n*\n* Description\n* ===========\n*\n* ZLANGE returns the value\n*\n* ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANGE as described\n* above.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0. When M = 0,\n* ZLANGE is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0. When N = 0,\n* ZLANGE is set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The m by n matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_m = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlange_(&norm, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlange(VALUE mLapack){
- rb_define_module_function(mLapack, "zlange", rb_zlange, -1);
-}
diff --git a/zlangt.c b/zlangt.c
deleted file mode 100644
index df283ff..0000000
--- a/zlangt.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex *d, doublecomplex *du);
-
-static VALUE
-rb_zlangt(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_dl;
- doublecomplex *dl;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_du;
- doublecomplex *du;
- VALUE rb___out__;
- doublereal __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlangt( norm, dl, d, du)\n or\n NumRu::Lapack.zlangt # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU )\n\n* Purpose\n* =======\n*\n* ZLANGT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* ZLANGT returns the value\n*\n* ZLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANGT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANGT is\n* set to zero.\n*\n* DL (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) sub-diagonal elements of A.\n*\n* D (input) COMPLEX*16 array, dimension (N)\n* The diagonal elements of A.\n*\n* DU (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_dl = argv[1];
- rb_d = argv[2];
- rb_du = argv[3];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_du))
- rb_raise(rb_eArgError, "du (4th argument) must be NArray");
- if (NA_RANK(rb_du) != 1)
- rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_du) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
- if (NA_TYPE(rb_du) != NA_DCOMPLEX)
- rb_du = na_change_type(rb_du, NA_DCOMPLEX);
- du = NA_PTR_TYPE(rb_du, doublecomplex*);
- if (!NA_IsNArray(rb_dl))
- rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
- if (NA_RANK(rb_dl) != 1)
- rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_dl) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
- if (NA_TYPE(rb_dl) != NA_DCOMPLEX)
- rb_dl = na_change_type(rb_dl, NA_DCOMPLEX);
- dl = NA_PTR_TYPE(rb_dl, doublecomplex*);
-
- __out__ = zlangt_(&norm, &n, dl, d, du);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlangt(VALUE mLapack){
- rb_define_module_function(mLapack, "zlangt", rb_zlangt, -1);
-}
diff --git a/zlanhb.c b/zlanhb.c
deleted file mode 100644
index e3baab8..0000000
--- a/zlanhb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlanhb_(char *norm, char *uplo, integer *n, integer *k, doublecomplex *ab, integer *ldab, doublereal *work);
-
-static VALUE
-rb_zlanhb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhb( norm, uplo, k, ab)\n or\n NumRu::Lapack.zlanhb # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n hermitian band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* ZLANHB returns the value\n*\n* ZLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangle of the hermitian band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_k = argv[2];
- rb_ab = argv[3];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlanhb_(&norm, &uplo, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlanhb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlanhb", rb_zlanhb, -1);
-}
diff --git a/zlanhe.c b/zlanhe.c
deleted file mode 100644
index 582354d..0000000
--- a/zlanhe.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_zlanhe(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhe( norm, uplo, a)\n or\n NumRu::Lapack.zlanhe # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHE returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A.\n*\n* Description\n* ===========\n*\n* ZLANHE returns the value\n*\n* ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHE as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHE is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The hermitian matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced. Note that the imaginary parts of the diagonal\n* elements need not be set and are assumed to be zero.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlanhe_(&norm, &uplo, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlanhe(VALUE mLapack){
- rb_define_module_function(mLapack, "zlanhe", rb_zlanhe, -1);
-}
diff --git a/zlanhf.c b/zlanhf.c
deleted file mode 100644
index ad45a86..0000000
--- a/zlanhf.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlanhf_(char *norm, char *transr, char *uplo, integer *n, doublecomplex *a, doublereal *work);
-
-static VALUE
-rb_zlanhf(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhf( norm, transr, uplo, n, a)\n or\n NumRu::Lapack.zlanhf # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHF returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian matrix A in RFP format.\n*\n* Description\n* ===========\n*\n* ZLANHF returns the value\n*\n* ZLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER\n* Specifies the value to be returned in ZLANHF as described\n* above.\n*\n* TRANSR (input) CHARACTER\n* Specifies whether the RFP format of A is normal or\n* conjugate-transposed format.\n* = 'N': RFP format is Normal\n* = 'C': RFP format is Conjugate-transposed\n*\n* UPLO (input) CHARACTER\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n*\n* UPLO = 'U' or 'u' RFP A came from an upper triangular\n* matrix\n*\n* UPLO = 'L' or 'l' RFP A came from a lower triangular\n* matrix\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHF is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n* as defined when TRANSR = 'N'. The contents of RFP A are\n* defined by UPLO as follows: If UPLO = 'U' the RFP A\n* contains the ( N*(N+1)/2 ) elements of upper packed A\n* either in normal or conjugate-transpose Format. If\n* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n* of lower packed A either in normal or conjugate-transpose\n* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n* TRANSR is 'N' the LDA is N+1 when N is even and is N when\n* is odd. See the Note below for more details.\n* Unchanged on exit.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_transr = argv[1];
- rb_uplo = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- work = ALLOC_N(doublereal, (lwork));
-
- __out__ = zlanhf_(&norm, &transr, &uplo, &n, a, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlanhf(VALUE mLapack){
- rb_define_module_function(mLapack, "zlanhf", rb_zlanhf, -1);
-}
diff --git a/zlanhp.c b/zlanhp.c
deleted file mode 100644
index d9bb454..0000000
--- a/zlanhp.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlanhp_(char *norm, char *uplo, integer *n, doublecomplex *ap, doublereal *work);
-
-static VALUE
-rb_zlanhp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhp( norm, uplo, n, ap)\n or\n NumRu::Lapack.zlanhp # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex hermitian matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* ZLANHP returns the value\n*\n* ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* hermitian matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHP is\n* set to zero.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* Note that the imaginary parts of the diagonal elements need\n* not be set and are assumed to be zero.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlanhp_(&norm, &uplo, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlanhp(VALUE mLapack){
- rb_define_module_function(mLapack, "zlanhp", rb_zlanhp, -1);
-}
diff --git a/zlanhs.c b/zlanhs.c
deleted file mode 100644
index 1ad95dd..0000000
--- a/zlanhs.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlanhs_(char *norm, integer *n, doublecomplex *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_zlanhs(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanhs( norm, a)\n or\n NumRu::Lapack.zlanhs # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANHS returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* Hessenberg matrix A.\n*\n* Description\n* ===========\n*\n* ZLANHS returns the value\n*\n* ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHS as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHS is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The n by n upper Hessenberg matrix A; the part of A below the\n* first sub-diagonal is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_norm = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- norm = StringValueCStr(rb_norm)[0];
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlanhs_(&norm, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlanhs(VALUE mLapack){
- rb_define_module_function(mLapack, "zlanhs", rb_zlanhs, -1);
-}
diff --git a/zlanht.c b/zlanht.c
deleted file mode 100644
index bf5affe..0000000
--- a/zlanht.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlanht_(char *norm, integer *n, doublereal *d, doublecomplex *e);
-
-static VALUE
-rb_zlanht(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb___out__;
- doublereal __out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlanht( norm, d, e)\n or\n NumRu::Lapack.zlanht # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E )\n\n* Purpose\n* =======\n*\n* ZLANHT returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex Hermitian tridiagonal matrix A.\n*\n* Description\n* ===========\n*\n* ZLANHT returns the value\n*\n* ZLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANHT as described\n* above.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANHT is\n* set to zero.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The diagonal elements of A.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
-
- __out__ = zlanht_(&norm, &n, d, e);
-
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlanht(VALUE mLapack){
- rb_define_module_function(mLapack, "zlanht", rb_zlanht, -1);
-}
diff --git a/zlansb.c b/zlansb.c
deleted file mode 100644
index e987575..0000000
--- a/zlansb.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlansb_(char *norm, char *uplo, integer *n, integer *k, doublecomplex *ab, integer *ldab, doublereal *work);
-
-static VALUE
-rb_zlansb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlansb( norm, uplo, k, ab)\n or\n NumRu::Lapack.zlansb # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANSB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n symmetric band matrix A, with k super-diagonals.\n*\n* Description\n* ===========\n*\n* ZLANSB returns the value\n*\n* ZLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANSB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* band matrix A is supplied.\n* = 'U': Upper triangular part is supplied\n* = 'L': Lower triangular part is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANSB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals or sub-diagonals of the\n* band matrix A. K >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangle of the symmetric band matrix A,\n* stored in the first K+1 rows of AB. The j-th column of A is\n* stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_k = argv[2];
- rb_ab = argv[3];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlansb_(&norm, &uplo, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlansb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlansb", rb_zlansb, -1);
-}
diff --git a/zlansp.c b/zlansp.c
deleted file mode 100644
index f013510..0000000
--- a/zlansp.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlansp_(char *norm, char *uplo, integer *n, doublecomplex *ap, doublereal *work);
-
-static VALUE
-rb_zlansp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlansp( norm, uplo, n, ap)\n or\n NumRu::Lapack.zlansp # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* ZLANSP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* ZLANSP returns the value\n*\n* ZLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANSP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is supplied.\n* = 'U': Upper triangular part of A is supplied\n* = 'L': Lower triangular part of A is supplied\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANSP is\n* set to zero.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlansp_(&norm, &uplo, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlansp(VALUE mLapack){
- rb_define_module_function(mLapack, "zlansp", rb_zlansp, -1);
-}
diff --git a/zlansy.c b/zlansy.c
deleted file mode 100644
index a88502d..0000000
--- a/zlansy.c
+++ /dev/null
@@ -1,55 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlansy_(char *norm, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_zlansy(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlansy( norm, uplo, a)\n or\n NumRu::Lapack.zlansy # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANSY returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* complex symmetric matrix A.\n*\n* Description\n* ===========\n*\n* ZLANSY returns the value\n*\n* ZLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANSY as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* symmetric matrix A is to be referenced.\n* = 'U': Upper triangular part of A is referenced\n* = 'L': Lower triangular part of A is referenced\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANSY is\n* set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(N,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n* WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlansy_(&norm, &uplo, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlansy(VALUE mLapack){
- rb_define_module_function(mLapack, "zlansy", rb_zlansy, -1);
-}
diff --git a/zlantb.c b/zlantb.c
deleted file mode 100644
index 835e8dd..0000000
--- a/zlantb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, doublecomplex *ab, integer *ldab, doublereal *work);
-
-static VALUE
-rb_zlantb(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_k;
- integer k;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer ldab;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlantb( norm, uplo, diag, k, ab)\n or\n NumRu::Lapack.zlantb # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n* Purpose\n* =======\n*\n* ZLANTB returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of an\n* n by n triangular band matrix A, with ( k + 1 ) diagonals.\n*\n* Description\n* ===========\n*\n* ZLANTB returns the value\n*\n* ZLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANTB as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANTB is\n* set to zero.\n*\n* K (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n* K >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first k+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n* Note that when DIAG = 'U', the elements of the array AB\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= K+1.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_k = argv[3];
- rb_ab = argv[4];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlantb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlantb", rb_zlantb, -1);
-}
diff --git a/zlantp.c b/zlantp.c
deleted file mode 100644
index 6f0515e..0000000
--- a/zlantp.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlantp_(char *norm, char *uplo, char *diag, integer *n, doublecomplex *ap, doublereal *work);
-
-static VALUE
-rb_zlantp(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlantp( norm, uplo, diag, n, ap)\n or\n NumRu::Lapack.zlantp # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n* Purpose\n* =======\n*\n* ZLANTP returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* triangular matrix A, supplied in packed form.\n*\n* Description\n* ===========\n*\n* ZLANTP returns the value\n*\n* ZLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANTP as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0. When N = 0, ZLANTP is\n* set to zero.\n*\n* AP (input) COMPLEX*16 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* Note that when DIAG = 'U', the elements of the array AP\n* corresponding to the diagonal elements of the matrix A are\n* not referenced, but are assumed to be one.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- lwork = lsame_(&norm,"I") ? n : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlantp_(&norm, &uplo, &diag, &n, ap, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlantp(VALUE mLapack){
- rb_define_module_function(mLapack, "zlantp", rb_zlantp, -1);
-}
diff --git a/zlantr.c b/zlantr.c
deleted file mode 100644
index 16ac3ff..0000000
--- a/zlantr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern doublereal zlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *work);
-
-static VALUE
-rb_zlantr(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb___out__;
- doublereal __out__;
- doublereal *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n __out__ = NumRu::Lapack.zlantr( norm, uplo, diag, m, a)\n or\n NumRu::Lapack.zlantr # print help\n\n\nFORTRAN MANUAL\n DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n* Purpose\n* =======\n*\n* ZLANTR returns the value of the one norm, or the Frobenius norm, or\n* the infinity norm, or the element of largest absolute value of a\n* trapezoidal or triangular matrix A.\n*\n* Description\n* ===========\n*\n* ZLANTR returns the value\n*\n* ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n* (\n* ( norm1(A), NORM = '1', 'O' or 'o'\n* (\n* ( normI(A), NORM = 'I' or 'i'\n* (\n* ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n*\n* where norm1 denotes the one norm of a matrix (maximum column sum),\n* normI denotes the infinity norm of a matrix (maximum row sum) and\n* normF denotes the Frobenius norm of a matrix (square root of sum of\n* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n*\n\n* Arguments\n* =========\n*\n* NORM (input) CHARACTER*1\n* Specifies the value to be returned in ZLANTR as described\n* above.\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower trapezoidal.\n* = 'U': Upper trapezoidal\n* = 'L': Lower trapezoidal\n* Note that A is triangular instead of trapezoidal if M = N.\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A has unit diagonal.\n* = 'N': Non-unit diagonal\n* = 'U': Unit diagonal\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0, and if\n* UPLO = 'U', M <= N. When M = 0, ZLANTR is set to zero.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0, and if\n* UPLO = 'L', N <= M. When N = 0, ZLANTR is set to zero.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The trapezoidal matrix A (A is triangular if M = N).\n* If UPLO = 'U', the leading m by n upper trapezoidal part of\n* the array A contains the upper trapezoidal matrix, and the\n* strictly lower triangular part of A is not referenced.\n* If UPLO = 'L', the leading m by n lower trapezoidal part of\n* the array A contains the lower trapezoidal matrix, and the\n* strictly upper triangular part of A is not referenced. Note\n* that when DIAG = 'U', the diagonal elements of A are not\n* referenced and are assumed to be one.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n* where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n* referenced.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_m = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = lsame_(&norm,"I") ? m : 0;
- work = ALLOC_N(doublereal, (MAX(1,lwork)));
-
- __out__ = zlantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);
-
- free(work);
- rb___out__ = rb_float_new((double)__out__);
- return rb___out__;
-}
-
-void
-init_lapack_zlantr(VALUE mLapack){
- rb_define_module_function(mLapack, "zlantr", rb_zlantr, -1);
-}
diff --git a/zlapll.c b/zlapll.c
deleted file mode 100644
index 62b339a..0000000
--- a/zlapll.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlapll_(integer *n, doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, doublereal *ssmin);
-
-static VALUE
-rb_zlapll(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_ssmin;
- doublereal ssmin;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ssmin, x, y = NumRu::Lapack.zlapll( n, x, incx, y, incy)\n or\n NumRu::Lapack.zlapll # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n* Purpose\n* =======\n*\n* Given two column vectors X and Y, let\n*\n* A = ( X Y ).\n*\n* The subroutine first computes the QR factorization of A = Q*R,\n* and then computes the SVD of the 2-by-2 upper triangular matrix R.\n* The smaller singular value of R is returned in SSMIN, which is used\n* as the measurement of the linear dependency of the vectors X and Y.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The length of the vectors X and Y.\n*\n* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n* On entry, X contains the N-vector X.\n* On exit, X is overwritten.\n*\n* INCX (input) INTEGER\n* The increment between successive elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n* On entry, Y contains the N-vector Y.\n* On exit, Y is overwritten.\n*\n* INCY (input) INTEGER\n* The increment between successive elements of Y. INCY > 0.\n*\n* SSMIN (output) DOUBLE PRECISION\n* The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
-
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zlapll_(&n, x, &incx, y, &incy, &ssmin);
-
- rb_ssmin = rb_float_new((double)ssmin);
- return rb_ary_new3(3, rb_ssmin, rb_x, rb_y);
-}
-
-void
-init_lapack_zlapll(VALUE mLapack){
- rb_define_module_function(mLapack, "zlapll", rb_zlapll, -1);
-}
diff --git a/zlapmr.c b/zlapmr.c
deleted file mode 100644
index 0c5d0d7..0000000
--- a/zlapmr.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlapmr_(logical *forwrd, integer *m, integer *n, doublecomplex *x, integer *ldx, integer *k);
-
-static VALUE
-rb_zlapmr(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.zlapmr( forwrd, x, k)\n or\n NumRu::Lapack.zlapmr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAPMR( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* ZLAPMR rearranges the rows of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (M)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IN, J, JJ\n COMPLEX*16 TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_forwrd = argv[0];
- rb_x = argv[1];
- rb_k = argv[2];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (3th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
- m = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = m;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- zlapmr_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_zlapmr(VALUE mLapack){
- rb_define_module_function(mLapack, "zlapmr", rb_zlapmr, -1);
-}
diff --git a/zlapmt.c b/zlapmt.c
deleted file mode 100644
index 7408b11..0000000
--- a/zlapmt.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlapmt_(logical *forwrd, integer *m, integer *n, doublecomplex *x, integer *ldx, integer *k);
-
-static VALUE
-rb_zlapmt(int argc, VALUE *argv, VALUE self){
- VALUE rb_forwrd;
- logical forwrd;
- VALUE rb_m;
- integer m;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_k;
- integer *k;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_k_out__;
- integer *k_out__;
-
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, k = NumRu::Lapack.zlapmt( forwrd, m, x, k)\n or\n NumRu::Lapack.zlapmt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K )\n\n* Purpose\n* =======\n*\n* ZLAPMT rearranges the columns of the M by N matrix X as specified\n* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n* If FORWRD = .TRUE., forward permutation:\n*\n* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n* If FORWRD = .FALSE., backward permutation:\n*\n* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n* Arguments\n* =========\n*\n* FORWRD (input) LOGICAL\n* = .TRUE., forward permutation\n* = .FALSE., backward permutation\n*\n* M (input) INTEGER\n* The number of rows of the matrix X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix X. N >= 0.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the M by N matrix X.\n* On exit, X contains the permuted matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X, LDX >= MAX(1,M).\n*\n* K (input/output) INTEGER array, dimension (N)\n* On entry, K contains the permutation vector. K is used as\n* internal workspace, but reset to its original value on\n* output.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, II, IN, J\n COMPLEX*16 TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_forwrd = argv[0];
- rb_m = argv[1];
- rb_x = argv[2];
- rb_k = argv[3];
-
- if (!NA_IsNArray(rb_k))
- rb_raise(rb_eArgError, "k (4th argument) must be NArray");
- if (NA_RANK(rb_k) != 1)
- rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_k);
- if (NA_TYPE(rb_k) != NA_LINT)
- rb_k = na_change_type(rb_k, NA_LINT);
- k = NA_PTR_TYPE(rb_k, integer*);
- forwrd = (rb_forwrd == Qtrue);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 0 of k");
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- m = NUM2INT(rb_m);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- k_out__ = NA_PTR_TYPE(rb_k_out__, integer*);
- MEMCPY(k_out__, k, integer, NA_TOTAL(rb_k));
- rb_k = rb_k_out__;
- k = k_out__;
-
- zlapmt_(&forwrd, &m, &n, x, &ldx, k);
-
- return rb_ary_new3(2, rb_x, rb_k);
-}
-
-void
-init_lapack_zlapmt(VALUE mLapack){
- rb_define_module_function(mLapack, "zlapmt", rb_zlapmt, -1);
-}
diff --git a/zlaqgb.c b/zlaqgb.c
deleted file mode 100644
index 1e8c96a..0000000
--- a/zlaqgb.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqgb_(integer *m, integer *n, integer *kl, integer *ku, doublecomplex *ab, integer *ldab, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);
-
-static VALUE
-rb_zlaqgb(int argc, VALUE *argv, VALUE self){
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.zlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.zlaqgb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQGB equilibrates a general M by N band matrix A with KL\n* subdiagonals and KU superdiagonals using the row and scaling factors\n* in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* KL (input) INTEGER\n* The number of subdiagonals within the band of A. KL >= 0.\n*\n* KU (input) INTEGER\n* The number of superdiagonals within the band of A. KU >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n* The j-th column of A is stored in the j-th column of the\n* array AB as follows:\n* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n* On exit, the equilibrated matrix, in the same storage format\n* as A. See EQUED for the form of the equilibrated matrix.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDA >= KL+KU+1.\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_kl = argv[0];
- rb_ku = argv[1];
- rb_ab = argv[2];
- rb_r = argv[3];
- rb_c = argv[4];
- rb_rowcnd = argv[5];
- rb_colcnd = argv[6];
- rb_amax = argv[7];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kl = NUM2INT(rb_kl);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- amax = NUM2DBL(rb_amax);
- colcnd = NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (4th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- rowcnd = NUM2DBL(rb_rowcnd);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zlaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_zlaqgb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqgb", rb_zlaqgb, -1);
-}
diff --git a/zlaqge.c b/zlaqge.c
deleted file mode 100644
index 1c79494..0000000
--- a/zlaqge.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqge_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *r, doublereal *c, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed);
-
-static VALUE
-rb_zlaqge(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_r;
- doublereal *r;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_rowcnd;
- doublereal rowcnd;
- VALUE rb_colcnd;
- doublereal colcnd;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.zlaqge( a, r, c, rowcnd, colcnd, amax)\n or\n NumRu::Lapack.zlaqge # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQGE equilibrates a general M by N matrix A using the row and\n* column scaling factors in the vectors R and C.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M by N matrix A.\n* On exit, the equilibrated matrix. See EQUED for the form of\n* the equilibrated matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(M,1).\n*\n* R (input) DOUBLE PRECISION array, dimension (M)\n* The row scale factors for A.\n*\n* C (input) DOUBLE PRECISION array, dimension (N)\n* The column scale factors for A.\n*\n* ROWCND (input) DOUBLE PRECISION\n* Ratio of the smallest R(i) to the largest R(i).\n*\n* COLCND (input) DOUBLE PRECISION\n* Ratio of the smallest C(i) to the largest C(i).\n*\n* AMAX (input) DOUBLE PRECISION\n* Absolute value of largest matrix entry.\n*\n* EQUED (output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration\n* = 'R': Row equilibration, i.e., A has been premultiplied by\n* diag(R).\n* = 'C': Column equilibration, i.e., A has been postmultiplied\n* by diag(C).\n* = 'B': Both row and column equilibration, i.e., A has been\n* replaced by diag(R) * A * diag(C).\n*\n* Internal Parameters\n* ===================\n*\n* THRESH is a threshold value used to decide if row or column scaling\n* should be done based on the ratio of the row or column scaling\n* factors. If ROWCND < THRESH, row scaling is done, and if\n* COLCND < THRESH, column scaling is done.\n*\n* LARGE and SMALL are threshold values used to decide if row scaling\n* should be done based on the absolute size of the largest matrix\n* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_a = argv[0];
- rb_r = argv[1];
- rb_c = argv[2];
- rb_rowcnd = argv[3];
- rb_colcnd = argv[4];
- rb_amax = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (3th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- amax = NUM2DBL(rb_amax);
- colcnd = NUM2DBL(rb_colcnd);
- if (!NA_IsNArray(rb_r))
- rb_raise(rb_eArgError, "r (2th argument) must be NArray");
- if (NA_RANK(rb_r) != 1)
- rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_r);
- if (NA_TYPE(rb_r) != NA_DFLOAT)
- rb_r = na_change_type(rb_r, NA_DFLOAT);
- r = NA_PTR_TYPE(rb_r, doublereal*);
- rowcnd = NUM2DBL(rb_rowcnd);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_zlaqge(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqge", rb_zlaqge, -1);
-}
diff --git a/zlaqhb.c b/zlaqhb.c
deleted file mode 100644
index 8c4368f..0000000
--- a/zlaqhb.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqhb_(char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_zlaqhb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, equed, ab = NumRu::Lapack.zlaqhb( uplo, kd, ab, scond, amax)\n or\n NumRu::Lapack.zlaqhb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQHB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* S (output) 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kd = NUM2INT(rb_kd);
- amax = NUM2DBL(rb_amax);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zlaqhb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(3, rb_s, rb_equed, rb_ab);
-}
-
-void
-init_lapack_zlaqhb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqhb", rb_zlaqhb, -1);
-}
diff --git a/zlaqhe.c b/zlaqhe.c
deleted file mode 100644
index 785633a..0000000
--- a/zlaqhe.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqhe_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_zlaqhe(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.zlaqhe( uplo, a, s, scond, amax)\n or\n NumRu::Lapack.zlaqhe # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQHE equilibrates a Hermitian 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* Hermitian 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 Hermitian 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlaqhe_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_zlaqhe(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqhe", rb_zlaqhe, -1);
-}
diff --git a/zlaqhp.c b/zlaqhp.c
deleted file mode 100644
index 1353fc9..0000000
--- a/zlaqhp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqhp_(char *uplo, integer *n, doublecomplex *ap, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_zlaqhp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ap = NumRu::Lapack.zlaqhp( uplo, ap, s, scond, amax)\n or\n NumRu::Lapack.zlaqhp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQHP equilibrates a Hermitian 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* Hermitian 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = NUM2DBL(rb_scond);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zlaqhp_(&uplo, &n, ap, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ap);
-}
-
-void
-init_lapack_zlaqhp(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqhp", rb_zlaqhp, -1);
-}
diff --git a/zlaqp2.c b/zlaqp2.c
deleted file mode 100644
index 760f063..0000000
--- a/zlaqp2.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqp2_(integer *m, integer *n, integer *offset, doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *work);
-
-static VALUE
-rb_zlaqp2(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- doublereal *vn1;
- VALUE rb_vn2;
- doublereal *vn2;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- doublereal *vn1_out__;
- VALUE rb_vn2_out__;
- doublereal *vn2_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a, jpvt, vn1, vn2 = NumRu::Lapack.zlaqp2( m, offset, a, jpvt, vn1, vn2)\n or\n NumRu::Lapack.zlaqp2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n* Purpose\n* =======\n*\n* ZLAQP2 computes a QR factorization with column pivoting of\n* the block A(OFFSET+1:M,1:N).\n* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* OFFSET (input) INTEGER\n* The number of rows of the matrix A that must be pivoted\n* but no factorized. OFFSET >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is\n* the triangular factor obtained; the elements in block\n* A(OFFSET+1:M,1:N) below the diagonal, together with the\n* array TAU, represent the orthogonal matrix Q as a product of\n* elementary reflectors. Block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n* to the front of A*P (a leading column); if JPVT(i) = 0,\n* the i-th column of A is a free column.\n* On exit, if JPVT(i) = k, then the i-th column of A*P\n* was the k-th column of A.\n*\n* TAU (output) COMPLEX*16 array, dimension (min(M,N))\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* Partial column norm updating strategy modified by\n* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n* University of Zagreb, Croatia.\n* June 2010\n* For more details see LAPACK Working Note 176.\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_DFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_DFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, doublereal*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_DFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_DFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, doublereal*);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- offset = NUM2INT(rb_offset);
- {
- int shape[1];
- shape[0] = MIN(m,n);
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, doublereal*);
- MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, doublereal*);
- MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zlaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);
-
- free(work);
- return rb_ary_new3(5, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2);
-}
-
-void
-init_lapack_zlaqp2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqp2", rb_zlaqp2, -1);
-}
diff --git a/zlaqps.c b/zlaqps.c
deleted file mode 100644
index cd57f95..0000000
--- a/zlaqps.c
+++ /dev/null
@@ -1,189 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqps_(integer *m, integer *n, integer *offset, integer *nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex *auxv, doublecomplex *f, integer *ldf);
-
-static VALUE
-rb_zlaqps(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_offset;
- integer offset;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_jpvt;
- integer *jpvt;
- VALUE rb_vn1;
- doublereal *vn1;
- VALUE rb_vn2;
- doublereal *vn2;
- VALUE rb_auxv;
- doublecomplex *auxv;
- VALUE rb_f;
- doublecomplex *f;
- VALUE rb_kb;
- integer kb;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_jpvt_out__;
- integer *jpvt_out__;
- VALUE rb_vn1_out__;
- doublereal *vn1_out__;
- VALUE rb_vn2_out__;
- doublereal *vn2_out__;
- VALUE rb_auxv_out__;
- doublecomplex *auxv_out__;
- VALUE rb_f_out__;
- doublecomplex *f_out__;
-
- integer lda;
- integer n;
- integer nb;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.zlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f)\n or\n NumRu::Lapack.zlaqps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n* Purpose\n* =======\n*\n* ZLAQPS computes a step of QR factorization with column pivoting\n* of a complex M-by-N matrix A by using Blas-3. It tries to factorize\n* NB columns from A starting from the row OFFSET+1, and updates all\n* of the matrix with Blas-3 xGEMM.\n*\n* In some cases, due to catastrophic cancellations, it cannot\n* factorize NB columns. Hence, the actual number of factorized\n* columns is returned in KB.\n*\n* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0\n*\n* OFFSET (input) INTEGER\n* The number of rows of A that have been factorized in\n* previous steps.\n*\n* NB (input) INTEGER\n* The number of columns to factorize.\n*\n* KB (output) INTEGER\n* The number of columns actually factorized.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, block A(OFFSET+1:M,1:KB) is the triangular\n* factor obtained and block A(1:OFFSET,1:N) has been\n* accordingly pivoted, but no factorized.\n* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n* been updated.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* JPVT (input/output) INTEGER array, dimension (N)\n* JPVT(I) = K <==> Column K of the full matrix A has been\n* permuted into position I in AP.\n*\n* TAU (output) COMPLEX*16 array, dimension (KB)\n* The scalar factors of the elementary reflectors.\n*\n* VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the partial column norms.\n*\n* VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n* The vector with the exact column norms.\n*\n* AUXV (input/output) COMPLEX*16 array, dimension (NB)\n* Auxiliar vector.\n*\n* F (input/output) COMPLEX*16 array, dimension (LDF,NB)\n* Matrix F' = L*Y'*A.\n*\n* LDF (input) INTEGER\n* The leading dimension of the array F. LDF >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n* X. Sun, Computer Science Dept., Duke University, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_m = argv[0];
- rb_offset = argv[1];
- rb_a = argv[2];
- rb_jpvt = argv[3];
- rb_vn1 = argv[4];
- rb_vn2 = argv[5];
- rb_auxv = argv[6];
- rb_f = argv[7];
-
- if (!NA_IsNArray(rb_auxv))
- rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
- if (NA_RANK(rb_auxv) != 1)
- rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
- nb = NA_SHAPE0(rb_auxv);
- if (NA_TYPE(rb_auxv) != NA_DCOMPLEX)
- rb_auxv = na_change_type(rb_auxv, NA_DCOMPLEX);
- auxv = NA_PTR_TYPE(rb_auxv, doublecomplex*);
- offset = NUM2INT(rb_offset);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_jpvt))
- rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
- if (NA_RANK(rb_jpvt) != 1)
- rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpvt) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
- if (NA_TYPE(rb_jpvt) != NA_LINT)
- rb_jpvt = na_change_type(rb_jpvt, NA_LINT);
- jpvt = NA_PTR_TYPE(rb_jpvt, integer*);
- if (!NA_IsNArray(rb_vn2))
- rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
- if (NA_RANK(rb_vn2) != 1)
- rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn2) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn2) != NA_DFLOAT)
- rb_vn2 = na_change_type(rb_vn2, NA_DFLOAT);
- vn2 = NA_PTR_TYPE(rb_vn2, doublereal*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != nb)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_DCOMPLEX)
- rb_f = na_change_type(rb_f, NA_DCOMPLEX);
- f = NA_PTR_TYPE(rb_f, doublecomplex*);
- if (!NA_IsNArray(rb_vn1))
- rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
- if (NA_RANK(rb_vn1) != 1)
- rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_vn1) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
- if (NA_TYPE(rb_vn1) != NA_DFLOAT)
- rb_vn1 = na_change_type(rb_vn1, NA_DFLOAT);
- vn1 = NA_PTR_TYPE(rb_vn1, doublereal*);
- kb = nb;
- {
- int shape[1];
- shape[0] = kb;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- jpvt_out__ = NA_PTR_TYPE(rb_jpvt_out__, integer*);
- MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rb_jpvt));
- rb_jpvt = rb_jpvt_out__;
- jpvt = jpvt_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn1_out__ = NA_PTR_TYPE(rb_vn1_out__, doublereal*);
- MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rb_vn1));
- rb_vn1 = rb_vn1_out__;
- vn1 = vn1_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- vn2_out__ = NA_PTR_TYPE(rb_vn2_out__, doublereal*);
- MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rb_vn2));
- rb_vn2 = rb_vn2_out__;
- vn2 = vn2_out__;
- {
- int shape[1];
- shape[0] = nb;
- rb_auxv_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- auxv_out__ = NA_PTR_TYPE(rb_auxv_out__, doublecomplex*);
- MEMCPY(auxv_out__, auxv, doublecomplex, NA_TOTAL(rb_auxv));
- rb_auxv = rb_auxv_out__;
- auxv = auxv_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = nb;
- rb_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, doublecomplex*);
- MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
-
- zlaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);
-
- rb_kb = INT2NUM(kb);
- return rb_ary_new3(8, rb_kb, rb_tau, rb_a, rb_jpvt, rb_vn1, rb_vn2, rb_auxv, rb_f);
-}
-
-void
-init_lapack_zlaqps(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqps", rb_zlaqps, -1);
-}
diff --git a/zlaqr0.c b/zlaqr0.c
deleted file mode 100644
index 6802c16..0000000
--- a/zlaqr0.c
+++ /dev/null
@@ -1,128 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqr0_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublecomplex *h, integer *ldh, doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zlaqr0(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.zlaqr0( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, lwork)\n or\n NumRu::Lapack.zlaqr0 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLAQR0 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to ZGEBAL, and then passed to ZGEHRD when the\n* matrix output by ZGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then ZLAQR0 does a workspace query.\n* In this case, ZLAQR0 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, ZLAQR0 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_h = argv[4];
- rb_iloz = argv[5];
- rb_ihiz = argv[6];
- rb_z = argv[7];
- rb_ldz = argv[8];
- rb_lwork = argv[9];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- ldz = NUM2INT(rb_ldz);
- ihi = NUM2INT(rb_ihi);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (5th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? ihi : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihi : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? ihi : 0;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- zlaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_zlaqr0(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqr0", rb_zlaqr0, -1);
-}
diff --git a/zlaqr1.c b/zlaqr1.c
deleted file mode 100644
index e90c2c3..0000000
--- a/zlaqr1.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqr1_(integer *n, doublecomplex *h, integer *ldh, doublecomplex *s1, doublecomplex *s2, doublecomplex *v);
-
-static VALUE
-rb_zlaqr1(int argc, VALUE *argv, VALUE self){
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_s1;
- doublecomplex s1;
- VALUE rb_s2;
- doublecomplex s2;
- VALUE rb_v;
- doublecomplex *v;
-
- integer ldh;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n v = NumRu::Lapack.zlaqr1( h, s1, s2)\n or\n NumRu::Lapack.zlaqr1 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )\n\n* Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a\n* scalar multiple of the first column of the product\n*\n* (*) K = (H - s1*I)*(H - s2*I)\n*\n* scaling to avoid overflows and most underflows.\n*\n* This is useful for starting double implicit shift bulges\n* in the QR algorithm.\n*\n*\n\n* N (input) integer\n* Order of the matrix H. N must be either 2 or 3.\n*\n* H (input) COMPLEX*16 array of dimension (LDH,N)\n* The 2-by-2 or 3-by-3 matrix H in (*).\n*\n* LDH (input) integer\n* The leading dimension of H as declared in\n* the calling procedure. LDH.GE.N\n*\n* S1 (input) COMPLEX*16\n* S2 S1 and S2 are the shifts defining K in (*) above.\n*\n* V (output) COMPLEX*16 array of dimension N\n* A scalar multiple of the first column of the\n* matrix K in (*).\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_h = argv[0];
- rb_s1 = argv[1];
- rb_s2 = argv[2];
-
- s1.r = NUM2DBL(rb_funcall(rb_s1, rb_intern("real"), 0));
- s1.i = NUM2DBL(rb_funcall(rb_s1, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (1th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- s2.r = NUM2DBL(rb_funcall(rb_s2, rb_intern("real"), 0));
- s2.i = NUM2DBL(rb_funcall(rb_s2, rb_intern("imag"), 0));
- {
- int shape[1];
- shape[0] = n;
- rb_v = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
-
- zlaqr1_(&n, h, &ldh, &s1, &s2, v);
-
- return rb_v;
-}
-
-void
-init_lapack_zlaqr1(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqr1", rb_zlaqr1, -1);
-}
diff --git a/zlaqr2.c b/zlaqr2.c
deleted file mode 100644
index ce5d1b6..0000000
--- a/zlaqr2.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqr2_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublecomplex *h, integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z, integer *ldz, integer *ns, integer *nd, doublecomplex *sh, doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, doublecomplex *work, integer *lwork);
-
-static VALUE
-rb_zlaqr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_ldt;
- integer ldt;
- VALUE rb_nv;
- integer nv;
- VALUE rb_ldwv;
- integer ldwv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sh;
- doublecomplex *sh;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
- doublecomplex *v;
- doublecomplex *t;
- doublecomplex *wv;
- doublecomplex *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.zlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, ldt, nv, ldwv, lwork)\n or\n NumRu::Lapack.zlaqr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* This subroutine is identical to ZLAQR3 except that it avoids\n* recursion by calling ZLAHQR instead of ZLAQR4.\n*\n*\n* ******************************************************************\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX*16 array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX*16 array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX*16 array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX*16 array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; ZLAQR2\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_ldt = argv[10];
- rb_nv = argv[11];
- rb_ldwv = argv[12];
- rb_lwork = argv[13];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- kbot = NUM2INT(rb_kbot);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- sh = NA_PTR_TYPE(rb_sh, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
- wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
- work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
-
- zlaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(5, rb_ns, rb_nd, rb_sh, rb_h, rb_z);
-}
-
-void
-init_lapack_zlaqr2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqr2", rb_zlaqr2, -1);
-}
diff --git a/zlaqr3.c b/zlaqr3.c
deleted file mode 100644
index 0605e65..0000000
--- a/zlaqr3.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqr3_(logical *wantt, logical *wantz, integer *n, integer *ktop, integer *kbot, integer *nw, doublecomplex *h, integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z, integer *ldz, integer *ns, integer *nd, doublecomplex *sh, doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, doublecomplex *work, integer *lwork);
-
-static VALUE
-rb_zlaqr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_nw;
- integer nw;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_nh;
- integer nh;
- VALUE rb_ldt;
- integer ldt;
- VALUE rb_nv;
- integer nv;
- VALUE rb_ldwv;
- integer ldwv;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ns;
- integer ns;
- VALUE rb_nd;
- integer nd;
- VALUE rb_sh;
- doublecomplex *sh;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
- doublecomplex *v;
- doublecomplex *t;
- doublecomplex *wv;
- doublecomplex *work;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ldv;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ns, nd, sh, h, z = NumRu::Lapack.zlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, ldt, nv, ldwv, lwork)\n or\n NumRu::Lapack.zlaqr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n* Aggressive early deflation:\n*\n* This subroutine accepts as input an upper Hessenberg matrix\n* H and performs an unitary similarity transformation\n* designed to detect and deflate fully converged eigenvalues from\n* a trailing principal submatrix. On output H has been over-\n* written by a new Hessenberg matrix that is a perturbation of\n* an unitary similarity transformation of H. It is to be\n* hoped that the final version of H has many zero subdiagonal\n* entries.\n*\n* ******************************************************************\n\n* WANTT (input) LOGICAL\n* If .TRUE., then the Hessenberg matrix H is fully updated\n* so that the triangular Schur factor may be\n* computed (in cooperation with the calling subroutine).\n* If .FALSE., then only enough of H is updated to preserve\n* the eigenvalues.\n*\n* WANTZ (input) LOGICAL\n* If .TRUE., then the unitary matrix Z is updated so\n* so that the unitary Schur factor may be computed\n* (in cooperation with the calling subroutine).\n* If .FALSE., then Z is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix H and (if WANTZ is .TRUE.) the\n* order of the unitary matrix Z.\n*\n* KTOP (input) INTEGER\n* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n* KBOT and KTOP together determine an isolated block\n* along the diagonal of the Hessenberg matrix.\n*\n* KBOT (input) INTEGER\n* It is assumed without a check that either\n* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n* determine an isolated block along the diagonal of the\n* Hessenberg matrix.\n*\n* NW (input) INTEGER\n* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On input the initial N-by-N section of H stores the\n* Hessenberg matrix undergoing aggressive early deflation.\n* On output H has been transformed by a unitary\n* similarity transformation, perturbed, and the returned\n* to Hessenberg form that (it is to be hoped) has some\n* zero subdiagonal entries.\n*\n* LDH (input) integer\n* Leading dimension of H just as declared in the calling\n* subroutine. N .LE. LDH\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* IF WANTZ is .TRUE., then on output, the unitary\n* similarity transformation mentioned above has been\n* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ is .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer\n* The leading dimension of Z just as declared in the\n* calling subroutine. 1 .LE. LDZ.\n*\n* NS (output) integer\n* The number of unconverged (ie approximate) eigenvalues\n* returned in SR and SI that may be used as shifts by the\n* calling subroutine.\n*\n* ND (output) integer\n* The number of converged eigenvalues uncovered by this\n* subroutine.\n*\n* SH (output) COMPLEX*16 array, dimension KBOT\n* On output, approximate eigenvalues that may\n* be used for shifts are stored in SH(KBOT-ND-NS+1)\n* through SR(KBOT-ND). Converged eigenvalues are\n* stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n* V (workspace) COMPLEX*16 array, dimension (LDV,NW)\n* An NW-by-NW work array.\n*\n* LDV (input) integer scalar\n* The leading dimension of V just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* NH (input) integer scalar\n* The number of columns of T. NH.GE.NW.\n*\n* T (workspace) COMPLEX*16 array, dimension (LDT,NW)\n*\n* LDT (input) integer\n* The leading dimension of T just as declared in the\n* calling subroutine. NW .LE. LDT\n*\n* NV (input) integer\n* The number of rows of work array WV available for\n* workspace. NV.GE.NW.\n*\n* WV (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n*\n* LDWV (input) integer\n* The leading dimension of W just as declared in the\n* calling subroutine. NW .LE. LDV\n*\n* WORK (workspace) COMPLEX*16 array, dimension LWORK.\n* On exit, WORK(1) is set to an estimate of the optimal value\n* of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n* LWORK (input) integer\n* The dimension of the work array WORK. LWORK = 2*NW\n* suffices, but greater efficiency may result from larger\n* values of LWORK.\n*\n* If LWORK = -1, then a workspace query is assumed; ZLAQR3\n* only estimates the optimal workspace size for the given\n* values of N, NW, KTOP and KBOT. The estimate is returned\n* in WORK(1). No error message related to LWORK is issued\n* by XERBLA. Neither H nor Z are accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 14)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ktop = argv[2];
- rb_kbot = argv[3];
- rb_nw = argv[4];
- rb_h = argv[5];
- rb_iloz = argv[6];
- rb_ihiz = argv[7];
- rb_z = argv[8];
- rb_nh = argv[9];
- rb_ldt = argv[10];
- rb_nv = argv[11];
- rb_ldwv = argv[12];
- rb_lwork = argv[13];
-
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (9th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- kbot = NUM2INT(rb_kbot);
- iloz = NUM2INT(rb_iloz);
- nv = NUM2INT(rb_nv);
- wantt = (rb_wantt == Qtrue);
- ihiz = NUM2INT(rb_ihiz);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (6th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_h) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- nw = NUM2INT(rb_nw);
- ldv = nw;
- ldwv = nw;
- ldt = nw;
- {
- int shape[1];
- shape[0] = MAX(1,kbot);
- rb_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- sh = NA_PTR_TYPE(rb_sh, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
- t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
- wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
- work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
-
- zlaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);
-
- free(v);
- free(t);
- free(wv);
- free(work);
- rb_ns = INT2NUM(ns);
- rb_nd = INT2NUM(nd);
- return rb_ary_new3(5, rb_ns, rb_nd, rb_sh, rb_h, rb_z);
-}
-
-void
-init_lapack_zlaqr3(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqr3", rb_zlaqr3, -1);
-}
diff --git a/zlaqr4.c b/zlaqr4.c
deleted file mode 100644
index 900e09f..0000000
--- a/zlaqr4.c
+++ /dev/null
@@ -1,123 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqr4_(logical *wantt, logical *wantz, integer *n, integer *ilo, integer *ihi, doublecomplex *h, integer *ldh, doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zlaqr4(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer ldh;
- integer n;
- integer ldz;
- integer ihi;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, work, info, h, z = NumRu::Lapack.zlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, lwork)\n or\n NumRu::Lapack.zlaqr4 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLAQR4 computes the eigenvalues of a Hessenberg matrix H\n* and, optionally, the matrices T and Z from the Schur decomposition\n* H = Z T Z**H, where T is an upper triangular matrix (the\n* Schur form), and Z is the unitary matrix of Schur vectors.\n*\n* Optionally Z may be postmultiplied into an input unitary\n* matrix Q so that this routine can give the Schur factorization\n* of a matrix A which has been reduced to the Hessenberg form H\n* by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n* Arguments\n* =========\n*\n* WANTT (input) LOGICAL\n* = .TRUE. : the full Schur form T is required;\n* = .FALSE.: only eigenvalues are required.\n*\n* WANTZ (input) LOGICAL\n* = .TRUE. : the matrix of Schur vectors Z is required;\n* = .FALSE.: Schur vectors are not required.\n*\n* N (input) INTEGER\n* The order of the matrix H. N .GE. 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* It is assumed that H is already upper triangular in rows\n* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n* previous call to ZGEBAL, and then passed to ZGEHRD when the\n* matrix output by ZGEBAL is reduced to Hessenberg form.\n* Otherwise, ILO and IHI should be set to 1 and N,\n* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n* If N = 0, then ILO = 1 and IHI = 0.\n*\n* H (input/output) COMPLEX*16 array, dimension (LDH,N)\n* On entry, the upper Hessenberg matrix H.\n* On exit, if INFO = 0 and WANTT is .TRUE., then H\n* contains the upper triangular matrix T from the Schur\n* decomposition (the Schur form). If INFO = 0 and WANT is\n* .FALSE., then the contents of H are unspecified on exit.\n* (The output value of H when INFO.GT.0 is given under the\n* description of INFO below.)\n*\n* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n* LDH (input) INTEGER\n* The leading dimension of the array H. LDH .GE. max(1,N).\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n* in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n* stored in the same order as on the diagonal of the Schur\n* form returned in H, with W(i) = H(i,i).\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n* If WANTZ is .FALSE., then Z is not referenced.\n* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n* (The output value of Z when INFO.GT.0 is given under\n* the description of INFO below.)\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. if WANTZ is .TRUE.\n* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension LWORK\n* On exit, if LWORK = -1, WORK(1) returns an estimate of\n* the optimal value for LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK .GE. max(1,N)\n* is sufficient, but LWORK typically as large as 6*N may\n* be required for optimal performance. A workspace query\n* to determine the optimal workspace size is recommended.\n*\n* If LWORK = -1, then ZLAQR4 does a workspace query.\n* In this case, ZLAQR4 checks the input parameters and\n* estimates the optimal workspace size for the given\n* values of N, ILO and IHI. The estimate is returned\n* in WORK(1). No error message related to LWORK is\n* issued by XERBLA. Neither H nor Z are accessed.\n*\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* .GT. 0: if INFO = i, ZLAQR4 failed to compute all of\n* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n* and WI contain those eigenvalues which have been\n* successfully computed. (Failures are rare.)\n*\n* If INFO .GT. 0 and WANT is .FALSE., then on exit,\n* the remaining unconverged eigenvalues are the eigen-\n* values of the upper Hessenberg matrix rows and\n* columns ILO through INFO of the final, output\n* value of H.\n*\n* If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n* (*) (initial value of H)*U = U*(final value of H)\n*\n* where U is a unitary matrix. The final\n* value of H is upper Hessenberg and triangular in\n* rows and columns INFO+1 through IHI.\n*\n* If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n* (final value of Z(ILO:IHI,ILOZ:IHIZ)\n* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n* where U is the unitary matrix in (*) (regard-\n* less of the value of WANTT.)\n*\n* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n* accessed.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* References:\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n* Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n* 929--947, 2002.\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n* of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_ilo = argv[2];
- rb_h = argv[3];
- rb_iloz = argv[4];
- rb_ihiz = argv[5];
- rb_z = argv[6];
- rb_lwork = argv[7];
-
- ilo = NUM2INT(rb_ilo);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (4th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- ihi = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (ldz != (wantz ? MAX(1,ihiz) : 1))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? MAX(1,ihiz) : 1);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- wantt = (rb_wantt == Qtrue);
- lwork = NUM2INT(rb_lwork);
- ldz = wantz ? MAX(1,ihiz) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = ihi;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- zlaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_w, rb_work, rb_info, rb_h, rb_z);
-}
-
-void
-init_lapack_zlaqr4(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqr4", rb_zlaqr4, -1);
-}
diff --git a/zlaqr5.c b/zlaqr5.c
deleted file mode 100644
index d957faf..0000000
--- a/zlaqr5.c
+++ /dev/null
@@ -1,160 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqr5_(logical *wantt, logical *wantz, integer *kacc22, integer *n, integer *ktop, integer *kbot, integer *nshfts, doublecomplex *s, doublecomplex *h, integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z, integer *ldz, doublecomplex *v, integer *ldv, doublecomplex *u, integer *ldu, integer *nv, doublecomplex *wv, integer *ldwv, integer *nh, doublecomplex *wh, integer *ldwh);
-
-static VALUE
-rb_zlaqr5(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantt;
- logical wantt;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_kacc22;
- integer kacc22;
- VALUE rb_ktop;
- integer ktop;
- VALUE rb_kbot;
- integer kbot;
- VALUE rb_s;
- doublecomplex *s;
- VALUE rb_h;
- doublecomplex *h;
- VALUE rb_iloz;
- integer iloz;
- VALUE rb_ihiz;
- integer ihiz;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_nv;
- integer nv;
- VALUE rb_nh;
- integer nh;
- VALUE rb_s_out__;
- doublecomplex *s_out__;
- VALUE rb_h_out__;
- doublecomplex *h_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
- doublecomplex *v;
- doublecomplex *u;
- doublecomplex *wv;
- doublecomplex *wh;
-
- integer nshfts;
- integer ldh;
- integer n;
- integer ldv;
- integer ldu;
- integer ldwv;
- integer ldwh;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, h, z = NumRu::Lapack.zlaqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh)\n or\n NumRu::Lapack.zlaqr5 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n* This auxiliary subroutine called by ZLAQR0 performs a\n* single small-bulge multi-shift QR sweep.\n*\n\n* WANTT (input) logical scalar\n* WANTT = .true. if the triangular Schur factor\n* is being computed. WANTT is set to .false. otherwise.\n*\n* WANTZ (input) logical scalar\n* WANTZ = .true. if the unitary Schur factor is being\n* computed. WANTZ is set to .false. otherwise.\n*\n* KACC22 (input) integer with value 0, 1, or 2.\n* Specifies the computation mode of far-from-diagonal\n* orthogonal updates.\n* = 0: ZLAQR5 does not accumulate reflections and does not\n* use matrix-matrix multiply to update far-from-diagonal\n* matrix entries.\n* = 1: ZLAQR5 accumulates reflections and uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries.\n* = 2: ZLAQR5 accumulates reflections, uses matrix-matrix\n* multiply to update the far-from-diagonal matrix entries,\n* and takes advantage of 2-by-2 block structure during\n* matrix multiplies.\n*\n* N (input) integer scalar\n* N is the order of the Hessenberg matrix H upon which this\n* subroutine operates.\n*\n* KTOP (input) integer scalar\n* KBOT (input) integer scalar\n* These are the first and last rows and columns of an\n* isolated diagonal block upon which the QR sweep is to be\n* applied. It is assumed without a check that\n* either KTOP = 1 or H(KTOP,KTOP-1) = 0\n* and\n* either KBOT = N or H(KBOT+1,KBOT) = 0.\n*\n* NSHFTS (input) integer scalar\n* NSHFTS gives the number of simultaneous shifts. NSHFTS\n* must be positive and even.\n*\n* S (input/output) COMPLEX*16 array of size (NSHFTS)\n* S contains the shifts of origin that define the multi-\n* shift QR sweep. On output S may be reordered.\n*\n* H (input/output) COMPLEX*16 array of size (LDH,N)\n* On input H contains a Hessenberg matrix. On output a\n* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n* to the isolated diagonal block in rows and columns KTOP\n* through KBOT.\n*\n* LDH (input) integer scalar\n* LDH is the leading dimension of H just as declared in the\n* calling procedure. LDH.GE.MAX(1,N).\n*\n* ILOZ (input) INTEGER\n* IHIZ (input) INTEGER\n* Specify the rows of Z to which transformations must be\n* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n* Z (input/output) COMPLEX*16 array of size (LDZ,IHI)\n* If WANTZ = .TRUE., then the QR Sweep unitary\n* similarity transformation is accumulated into\n* Z(ILOZ:IHIZ,ILO:IHI) from the right.\n* If WANTZ = .FALSE., then Z is unreferenced.\n*\n* LDZ (input) integer scalar\n* LDA is the leading dimension of Z just as declared in\n* the calling procedure. LDZ.GE.N.\n*\n* V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2)\n*\n* LDV (input) integer scalar\n* LDV is the leading dimension of V as declared in the\n* calling procedure. LDV.GE.3.\n*\n* U (workspace) COMPLEX*16 array of size\n* (LDU,3*NSHFTS-3)\n*\n* LDU (input) integer scalar\n* LDU is the leading dimension of U just as declared in the\n* in the calling subroutine. LDU.GE.3*NSHFTS-3.\n*\n* NH (input) integer scalar\n* NH is the number of columns in array WH available for\n* workspace. NH.GE.1.\n*\n* WH (workspace) COMPLEX*16 array of size (LDWH,NH)\n*\n* LDWH (input) integer scalar\n* Leading dimension of WH just as declared in the\n* calling procedure. LDWH.GE.3*NSHFTS-3.\n*\n* NV (input) integer scalar\n* NV is the number of rows in WV agailable for workspace.\n* NV.GE.1.\n*\n* WV (workspace) COMPLEX*16 array of size\n* (LDWV,3*NSHFTS-3)\n*\n* LDWV (input) integer scalar\n* LDWV is the leading dimension of WV as declared in the\n* in the calling subroutine. LDWV.GE.NV.\n*\n\n* ================================================================\n* Based on contributions by\n* Karen Braman and Ralph Byers, Department of Mathematics,\n* University of Kansas, USA\n*\n* ================================================================\n* Reference:\n*\n* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n* Algorithm Part I: Maintaining Well Focused Shifts, and\n* Level 3 Performance, SIAM Journal of Matrix Analysis,\n* volume 23, pages 929--947, 2002.\n*\n* ================================================================\n\n");
- return Qnil;
- }
- if (argc != 13)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
- rb_wantt = argv[0];
- rb_wantz = argv[1];
- rb_kacc22 = argv[2];
- rb_ktop = argv[3];
- rb_kbot = argv[4];
- rb_s = argv[5];
- rb_h = argv[6];
- rb_iloz = argv[7];
- rb_ihiz = argv[8];
- rb_z = argv[9];
- rb_ldz = argv[10];
- rb_nv = argv[11];
- rb_nh = argv[12];
-
- kacc22 = NUM2INT(rb_kacc22);
- ktop = NUM2INT(rb_ktop);
- wantz = (rb_wantz == Qtrue);
- kbot = NUM2INT(rb_kbot);
- ldz = NUM2INT(rb_ldz);
- nh = NUM2INT(rb_nh);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- nshfts = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DCOMPLEX)
- rb_s = na_change_type(rb_s, NA_DCOMPLEX);
- s = NA_PTR_TYPE(rb_s, doublecomplex*);
- if (!NA_IsNArray(rb_h))
- rb_raise(rb_eArgError, "h (7th argument) must be NArray");
- if (NA_RANK(rb_h) != 2)
- rb_raise(rb_eArgError, "rank of h (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_h);
- ldh = NA_SHAPE0(rb_h);
- if (NA_TYPE(rb_h) != NA_DCOMPLEX)
- rb_h = na_change_type(rb_h, NA_DCOMPLEX);
- h = NA_PTR_TYPE(rb_h, doublecomplex*);
- ldv = 3;
- wantt = (rb_wantt == Qtrue);
- nv = NUM2INT(rb_nv);
- ihiz = NUM2INT(rb_ihiz);
- iloz = NUM2INT(rb_iloz);
- ldu = 3*nshfts-3;
- ldwv = nv;
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (10th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantz ? ihiz : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
- if (NA_SHAPE0(rb_z) != (wantz ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- ldwh = 3*nshfts-3;
- {
- int shape[1];
- shape[0] = nshfts;
- rb_s_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublecomplex*);
- MEMCPY(s_out__, s, doublecomplex, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldh;
- shape[1] = n;
- rb_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- h_out__ = NA_PTR_TYPE(rb_h_out__, doublecomplex*);
- MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rb_h));
- rb_h = rb_h_out__;
- h = h_out__;
- {
- int shape[2];
- shape[0] = wantz ? ldz : 0;
- shape[1] = wantz ? ihiz : 0;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- v = ALLOC_N(doublecomplex, (ldv)*(nshfts/2));
- u = ALLOC_N(doublecomplex, (ldu)*(3*nshfts-3));
- wv = ALLOC_N(doublecomplex, (ldwv)*(3*nshfts-3));
- wh = ALLOC_N(doublecomplex, (ldwh)*(MAX(1,nh)));
-
- zlaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, s, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);
-
- free(v);
- free(u);
- free(wv);
- free(wh);
- return rb_ary_new3(3, rb_s, rb_h, rb_z);
-}
-
-void
-init_lapack_zlaqr5(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqr5", rb_zlaqr5, -1);
-}
diff --git a/zlaqsb.c b/zlaqsb.c
deleted file mode 100644
index 64605a4..0000000
--- a/zlaqsb.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqsb_(char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_zlaqsb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ab = NumRu::Lapack.zlaqsb( uplo, kd, ab, s, scond, amax)\n or\n NumRu::Lapack.zlaqsb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQSB equilibrates a symmetric band matrix A using the scaling\n* factors 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the symmetric band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_s = argv[3];
- rb_scond = argv[4];
- rb_amax = argv[5];
-
- scond = NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kd = NUM2INT(rb_kd);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zlaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ab);
-}
-
-void
-init_lapack_zlaqsb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqsb", rb_zlaqsb, -1);
-}
diff --git a/zlaqsp.c b/zlaqsp.c
deleted file mode 100644
index ac8a63d..0000000
--- a/zlaqsp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaqsp_(char *uplo, integer *n, doublecomplex *ap, doublereal *s, doublereal *scond, doublereal *amax, char *equed);
-
-static VALUE
-rb_zlaqsp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, ap = NumRu::Lapack.zlaqsp( uplo, ap, s, scond, amax)\n or\n NumRu::Lapack.zlaqsp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n* Purpose\n* =======\n*\n* ZLAQSP 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n* the same storage format as A.\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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = NUM2DBL(rb_scond);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zlaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_ap);
-}
-
-void
-init_lapack_zlaqsp(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqsp", rb_zlaqsp, -1);
-}
diff --git a/zlaqsy.c b/zlaqsy.c
deleted file mode 100644
index f8743ca..0000000
--- a/zlaqsy.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#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
-rb_zlaqsy(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_equed;
- char equed;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n equed, a = NumRu::Lapack.zlaqsy( uplo, a, s, scond, amax)\n or\n NumRu::Lapack.zlaqsy # print 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_s = argv[2];
- rb_scond = argv[3];
- rb_amax = argv[4];
-
- scond = NUM2DBL(rb_scond);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- amax = NUM2DBL(rb_amax);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (3th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);
-
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(2, rb_equed, rb_a);
-}
-
-void
-init_lapack_zlaqsy(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaqsy", rb_zlaqsy, -1);
-}
diff --git a/zlar1v.c b/zlar1v.c
deleted file mode 100644
index dc23517..0000000
--- a/zlar1v.c
+++ /dev/null
@@ -1,154 +0,0 @@
-#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
-rb_zlar1v(int argc, VALUE *argv, VALUE self){
- VALUE rb_b1;
- integer b1;
- VALUE rb_bn;
- integer bn;
- VALUE rb_lambda;
- doublereal lambda;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_l;
- doublereal *l;
- VALUE rb_ld;
- doublereal *ld;
- VALUE rb_lld;
- doublereal *lld;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_gaptol;
- doublereal gaptol;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_wantnc;
- logical wantnc;
- VALUE rb_r;
- integer r;
- VALUE rb_negcnt;
- integer negcnt;
- VALUE rb_ztz;
- doublereal ztz;
- VALUE rb_mingma;
- doublereal mingma;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_nrminv;
- doublereal nrminv;
- VALUE rb_resid;
- doublereal resid;
- VALUE rb_rqcorr;
- doublereal rqcorr;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
- doublereal *work;
-
- integer n;
-
- if (argc == 0) {
- 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)\n or\n NumRu::Lapack.zlar1v # print 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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_b1 = argv[0];
- rb_bn = argv[1];
- rb_lambda = argv[2];
- rb_d = argv[3];
- rb_l = argv[4];
- rb_ld = argv[5];
- rb_lld = argv[6];
- rb_pivmin = argv[7];
- rb_gaptol = argv[8];
- rb_z = argv[9];
- rb_wantnc = argv[10];
- rb_r = argv[11];
-
- pivmin = NUM2DBL(rb_pivmin);
- bn = NUM2INT(rb_bn);
- lambda = NUM2DBL(rb_lambda);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (10th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
- n = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- wantnc = (rb_wantnc == Qtrue);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (4th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- r = NUM2INT(rb_r);
- gaptol = NUM2DBL(rb_gaptol);
- b1 = NUM2INT(rb_b1);
- if (!NA_IsNArray(rb_lld))
- rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
- if (NA_RANK(rb_lld) != 1)
- rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_lld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
- if (NA_TYPE(rb_lld) != NA_DFLOAT)
- rb_lld = na_change_type(rb_lld, NA_DFLOAT);
- lld = NA_PTR_TYPE(rb_lld, doublereal*);
- if (!NA_IsNArray(rb_ld))
- rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
- if (NA_RANK(rb_ld) != 1)
- rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ld) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
- if (NA_TYPE(rb_ld) != NA_DFLOAT)
- rb_ld = na_change_type(rb_ld, NA_DFLOAT);
- ld = NA_PTR_TYPE(rb_ld, doublereal*);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (5th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
- if (NA_TYPE(rb_l) != NA_DFLOAT)
- rb_l = na_change_type(rb_l, NA_DFLOAT);
- l = NA_PTR_TYPE(rb_l, doublereal*);
- {
- int shape[1];
- shape[0] = 2;
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_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);
- rb_negcnt = INT2NUM(negcnt);
- rb_ztz = rb_float_new((double)ztz);
- rb_mingma = rb_float_new((double)mingma);
- rb_nrminv = rb_float_new((double)nrminv);
- rb_resid = rb_float_new((double)resid);
- rb_rqcorr = rb_float_new((double)rqcorr);
- rb_r = INT2NUM(r);
- return rb_ary_new3(9, rb_negcnt, rb_ztz, rb_mingma, rb_isuppz, rb_nrminv, rb_resid, rb_rqcorr, rb_z, rb_r);
-}
-
-void
-init_lapack_zlar1v(VALUE mLapack){
- rb_define_module_function(mLapack, "zlar1v", rb_zlar1v, -1);
-}
diff --git a/zlar2v.c b/zlar2v.c
deleted file mode 100644
index eb9decc..0000000
--- a/zlar2v.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#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
-rb_zlar2v(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_incx;
- integer incx;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublecomplex *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y, z = NumRu::Lapack.zlar2v( n, x, y, z, incx, c, s, incc)\n or\n NumRu::Lapack.zlar2v # print 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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_y = argv[2];
- rb_z = argv[3];
- rb_incx = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- n = NUM2INT(rb_n);
- incc = NUM2INT(rb_incc);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 1)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_z) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (3th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_DCOMPLEX)
- rb_s = na_change_type(rb_s, NA_DCOMPLEX);
- s = NA_PTR_TYPE(rb_s, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- zlar2v_(&n, x, y, z, &incx, c, s, &incc);
-
- return rb_ary_new3(3, rb_x, rb_y, rb_z);
-}
-
-void
-init_lapack_zlar2v(VALUE mLapack){
- rb_define_module_function(mLapack, "zlar2v", rb_zlar2v, -1);
-}
diff --git a/zlarcm.c b/zlarcm.c
deleted file mode 100644
index f5bebaf..0000000
--- a/zlarcm.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#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
-rb_zlarcm(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublereal *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_c;
- doublecomplex *c;
- doublereal *rwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarcm( a, b)\n or\n NumRu::Lapack.zlarcm # print 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_b = argv[1];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (2th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DFLOAT)
- rb_a = na_change_type(rb_a, NA_DFLOAT);
- a = NA_PTR_TYPE(rb_a, doublereal*);
- ldc = MAX(1,m);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- rwork = ALLOC_N(doublereal, (2*m*n));
-
- zlarcm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);
-
- free(rwork);
- return rb_c;
-}
-
-void
-init_lapack_zlarcm(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarcm", rb_zlarcm, -1);
-}
diff --git a/zlarf.c b/zlarf.c
deleted file mode 100644
index 69dca91..0000000
--- a/zlarf.c
+++ /dev/null
@@ -1,83 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarf_(char *side, integer *m, integer *n, doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work);
-
-static VALUE
-rb_zlarf(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- doublecomplex tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarf( side, m, v, incv, tau, c)\n or\n NumRu::Lapack.zlarf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* ZLARF applies a complex elementary reflector H to a complex M-by-N\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX*16 array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of H. V is not used if\n* TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_v = argv[2];
- rb_incv = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- tau.r = NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (3th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zlarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_zlarf(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarf", rb_zlarf, -1);
-}
diff --git a/zlarfb.c b/zlarfb.c
deleted file mode 100644
index 6e0c129..0000000
--- a/zlarfb.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarfb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, doublecomplex *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c, integer *ldc, doublecomplex *work, integer *ldwork);
-
-static VALUE
-rb_zlarfb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer ldv;
- integer k;
- integer ldt;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarfb( side, trans, direct, storev, m, v, t, c)\n or\n NumRu::Lapack.zlarfb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* ZLARFB applies a complex block reflector H or its transpose H' to a\n* complex M-by-N matrix C, from either the left or the right.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* V (input) COMPLEX*16 array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,M) if STOREV = 'R' and SIDE = 'L'\n* (LDV,N) if STOREV = 'R' and SIDE = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n* if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX*16 array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_v = argv[5];
- rb_t = argv[6];
- rb_c = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (6th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
- k = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- direct = StringValueCStr(rb_direct)[0];
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (7th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != k)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of v");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DCOMPLEX)
- rb_t = na_change_type(rb_t, NA_DCOMPLEX);
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (ldwork)*(k));
-
- zlarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_zlarfb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarfb", rb_zlarfb, -1);
-}
diff --git a/zlarfg.c b/zlarfg.c
deleted file mode 100644
index 05d33d9..0000000
--- a/zlarfg.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarfg_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau);
-
-static VALUE
-rb_zlarfg(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- doublecomplex tau;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.zlarfg( n, alpha, x, incx)\n or\n NumRu::Lapack.zlarfg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* ZLARFG generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, with beta real, and x is an\n* (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n* Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX*16\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX*16 array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX*16\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- zlarfg_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
- rb_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_zlarfg(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarfg", rb_zlarfg, -1);
-}
diff --git a/zlarfgp.c b/zlarfgp.c
deleted file mode 100644
index 1fdc704..0000000
--- a/zlarfgp.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarfgp_(integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *tau);
-
-static VALUE
-rb_zlarfgp(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_tau;
- doublecomplex tau;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, alpha, x = NumRu::Lapack.zlarfgp( n, alpha, x, incx)\n or\n NumRu::Lapack.zlarfgp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU )\n\n* Purpose\n* =======\n*\n* ZLARFGP generates a complex elementary reflector H of order n, such\n* that\n*\n* H' * ( alpha ) = ( beta ), H' * H = I.\n* ( x ) ( 0 )\n*\n* where alpha and beta are scalars, beta is real and non-negative, and\n* x is an (n-1)-element complex vector. H is represented in the form\n*\n* H = I - tau * ( 1 ) * ( 1 v' ) ,\n* ( v )\n*\n* where tau is a complex scalar and v is a complex (n-1)-element\n* vector. Note that H is not hermitian.\n*\n* If the elements of x are all zero and alpha is real, then tau = 0\n* and H is taken to be the unit matrix.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the elementary reflector.\n*\n* ALPHA (input/output) COMPLEX*16\n* On entry, the value alpha.\n* On exit, it is overwritten with the value beta.\n*\n* X (input/output) COMPLEX*16 array, dimension\n* (1+(N-2)*abs(INCX))\n* On entry, the vector x.\n* On exit, it is overwritten with the vector v.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* TAU (output) COMPLEX*16\n* The value tau.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_n = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
-
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-2)*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-2)*abs(incx);
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- zlarfgp_(&n, &alpha, x, &incx, &tau);
-
- rb_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
- rb_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
- return rb_ary_new3(3, rb_tau, rb_alpha, rb_x);
-}
-
-void
-init_lapack_zlarfgp(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarfgp", rb_zlarfgp, -1);
-}
diff --git a/zlarft.c b/zlarft.c
deleted file mode 100644
index db29e1b..0000000
--- a/zlarft.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarft_(char *direct, char *storev, integer *n, integer *k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *t, integer *ldt);
-
-static VALUE
-rb_zlarft(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_v_out__;
- doublecomplex *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.zlarft( direct, storev, n, v, tau)\n or\n NumRu::Lapack.zlarft # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* ZLARFT forms the triangular factor T of a complex block reflector H\n* of order n, which is defined as a product of k elementary reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX*16 array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX*16 array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n* ( v1 1 ) ( 1 v2 v2 v2 )\n* ( v1 v2 1 ) ( 1 v3 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n* ( v1 v2 v3 ) ( v2 v2 v2 1 )\n* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n* ( 1 v3 )\n* ( 1 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublecomplex*);
- MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- zlarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_zlarft(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarft", rb_zlarft, -1);
-}
diff --git a/zlarfx.c b/zlarfx.c
deleted file mode 100644
index 1491e26..0000000
--- a/zlarfx.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarfx_(char *side, integer *m, integer *n, doublecomplex *v, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work);
-
-static VALUE
-rb_zlarfx(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_tau;
- doublecomplex tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarfx( side, v, tau, c)\n or\n NumRu::Lapack.zlarfx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* ZLARFX applies a complex elementary reflector H to a complex m by n\n* matrix C, from either the left or the right. H is represented in the\n* form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix\n*\n* This version uses inline code if H has order < 11.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L'\n* or (N) if SIDE = 'R'\n* The vector v in the representation of H.\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m by n matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDA >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n* WORK is not referenced if H has order < 11.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_side = argv[0];
- rb_v = argv[1];
- rb_tau = argv[2];
- rb_c = argv[3];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (2th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
- m = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (4th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- tau.r = NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zlarfx_(&side, &m, &n, v, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_zlarfx(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarfx", rb_zlarfx, -1);
-}
diff --git a/zlargv.c b/zlargv.c
deleted file mode 100644
index fdf82c6..0000000
--- a/zlargv.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlargv_(integer *n, doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, doublereal *c, integer *incc);
-
-static VALUE
-rb_zlargv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_incc;
- integer incc;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c, x, y = NumRu::Lapack.zlargv( n, x, incx, y, incy, incc)\n or\n NumRu::Lapack.zlargv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n* Purpose\n* =======\n*\n* ZLARGV generates a vector of complex plane rotations with real\n* cosines, determined by elements of the complex vectors x and y.\n* For i = 1,2,...,n\n*\n* ( c(i) s(i) ) ( x(i) ) = ( r(i) )\n* ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 )\n*\n* where c(i)**2 + ABS(s(i))**2 = 1\n*\n* The following conventions are used (these are the same as in ZLARTG,\n* but differ from the BLAS1 routine ZROTG):\n* If y(i)=0, then c(i)=1 and s(i)=0.\n* If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of plane rotations to be generated.\n*\n* X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n* On entry, the vector x.\n* On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n* On entry, the vector y.\n* On exit, the sines of the plane rotations.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 0.\n*\n* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n* The cosines of the plane rotations.\n*\n* INCC (input) INTEGER\n* The increment between elements of C. INCC > 0.\n*\n\n* Further Details\n* ======= =======\n*\n* 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_incc = argv[5];
-
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incc;
- rb_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- c = NA_PTR_TYPE(rb_c, doublereal*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zlargv_(&n, x, &incx, y, &incy, c, &incc);
-
- return rb_ary_new3(3, rb_c, rb_x, rb_y);
-}
-
-void
-init_lapack_zlargv(VALUE mLapack){
- rb_define_module_function(mLapack, "zlargv", rb_zlargv, -1);
-}
diff --git a/zlarnv.c b/zlarnv.c
deleted file mode 100644
index 81148c3..0000000
--- a/zlarnv.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarnv_(integer *idist, integer *iseed, integer *n, doublecomplex *x);
-
-static VALUE
-rb_zlarnv(int argc, VALUE *argv, VALUE self){
- VALUE rb_idist;
- integer idist;
- VALUE rb_iseed;
- integer *iseed;
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_iseed_out__;
- integer *iseed_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, iseed = NumRu::Lapack.zlarnv( idist, iseed, n)\n or\n NumRu::Lapack.zlarnv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARNV( IDIST, ISEED, N, X )\n\n* Purpose\n* =======\n*\n* ZLARNV returns a vector of n random complex numbers from a uniform or\n* normal distribution.\n*\n\n* Arguments\n* =========\n*\n* IDIST (input) INTEGER\n* Specifies the distribution of the random numbers:\n* = 1: real and imaginary parts each uniform (0,1)\n* = 2: real and imaginary parts each uniform (-1,1)\n* = 3: real and imaginary parts each normal (0,1)\n* = 4: uniformly distributed on the disc abs(z) < 1\n* = 5: uniformly distributed on the circle abs(z) = 1\n*\n* ISEED (input/output) INTEGER array, dimension (4)\n* On entry, the seed of the random number generator; the array\n* elements must be between 0 and 4095, and ISEED(4) must be\n* odd.\n* On exit, the seed is updated.\n*\n* N (input) INTEGER\n* The number of random numbers to be generated.\n*\n* X (output) COMPLEX*16 array, dimension (N)\n* The generated random numbers.\n*\n\n* Further Details\n* ===============\n*\n* This routine calls the auxiliary routine DLARUV to generate random\n* real numbers from a uniform (0,1) distribution, in batches of up to\n* 128 using vectorisable code. The Box-Muller method is used to\n* transform numbers from a uniform to a normal distribution.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_idist = argv[0];
- rb_iseed = argv[1];
- rb_n = argv[2];
-
- n = NUM2INT(rb_n);
- idist = NUM2INT(rb_idist);
- if (!NA_IsNArray(rb_iseed))
- rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
- if (NA_RANK(rb_iseed) != 1)
- rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iseed) != (4))
- rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
- if (NA_TYPE(rb_iseed) != NA_LINT)
- rb_iseed = na_change_type(rb_iseed, NA_LINT);
- iseed = NA_PTR_TYPE(rb_iseed, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,n);
- rb_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 4;
- rb_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iseed_out__ = NA_PTR_TYPE(rb_iseed_out__, integer*);
- MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rb_iseed));
- rb_iseed = rb_iseed_out__;
- iseed = iseed_out__;
-
- zlarnv_(&idist, iseed, &n, x);
-
- return rb_ary_new3(2, rb_x, rb_iseed);
-}
-
-void
-init_lapack_zlarnv(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarnv", rb_zlarnv, -1);
-}
diff --git a/zlarrv.c b/zlarrv.c
deleted file mode 100644
index 217df01..0000000
--- a/zlarrv.c
+++ /dev/null
@@ -1,252 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarrv_(integer *n, doublereal *vl, doublereal *vu, doublereal *d, doublereal *l, doublereal *pivmin, integer *isplit, integer *m, integer *dol, integer *dou, doublereal *minrgp, doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr, doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers, doublecomplex *z, integer *ldz, integer *isuppz, doublereal *work, integer *iwork, integer *info);
-
-static VALUE
-rb_zlarrv(int argc, VALUE *argv, VALUE self){
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_l;
- doublereal *l;
- VALUE rb_pivmin;
- doublereal pivmin;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_m;
- integer m;
- VALUE rb_dol;
- integer dol;
- VALUE rb_dou;
- integer dou;
- VALUE rb_minrgp;
- doublereal minrgp;
- VALUE rb_rtol1;
- doublereal rtol1;
- VALUE rb_rtol2;
- doublereal rtol2;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_werr;
- doublereal *werr;
- VALUE rb_wgap;
- doublereal *wgap;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_indexw;
- integer *indexw;
- VALUE rb_gers;
- doublereal *gers;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_l_out__;
- doublereal *l_out__;
- VALUE rb_w_out__;
- doublereal *w_out__;
- VALUE rb_werr_out__;
- doublereal *werr_out__;
- VALUE rb_wgap_out__;
- doublereal *wgap_out__;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.zlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers)\n or\n NumRu::Lapack.zlarrv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZLARRV computes the eigenvectors of the tridiagonal matrix\n* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n* The input eigenvalues should have been computed by DLARRE.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* Lower and upper bounds of the interval that contains the desired\n* eigenvalues. VL < VU. Needed to compute gaps on the left or right\n* end of the extremal eigenvalues in the desired RANGE.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the diagonal matrix D.\n* On exit, D may be overwritten.\n*\n* L (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the unit\n* bidiagonal matrix L are in elements 1 to N-1 of L\n* (if the matrix is not splitted.) At the end of each block\n* is stored the corresponding shift as given by DLARRE.\n* On exit, L is overwritten.\n*\n* PIVMIN (in) DOUBLE PRECISION\n* The minimum pivot allowed in the Sturm sequence.\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into blocks.\n* The first block consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n*\n* M (input) INTEGER\n* The total number of input eigenvalues. 0 <= M <= N.\n*\n* DOL (input) INTEGER\n* DOU (input) INTEGER\n* If the user wants to compute only selected eigenvectors from all\n* the eigenvalues supplied, he can specify an index range DOL:DOU.\n* Or else the setting DOL=1, DOU=M should be applied.\n* Note that DOL and DOU refer to the order in which the eigenvalues\n* are stored in W.\n* If the user wants to compute only selected eigenpairs, then\n* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n* computed eigenvectors. All other columns of Z are set to zero.\n*\n* MINRGP (input) DOUBLE PRECISION\n*\n* RTOL1 (input) DOUBLE PRECISION\n* RTOL2 (input) DOUBLE PRECISION\n* Parameters for bisection.\n* An interval [LEFT,RIGHT] has converged if\n* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n* W (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the APPROXIMATE eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block ( The output array\n* W from DLARRE is expected here ). Furthermore, they are with\n* respect to the shift of the corresponding root representation\n* for their block. On exit, W holds the eigenvalues of the\n* UNshifted matrix.\n*\n* WERR (input/output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the semiwidth of the uncertainty\n* interval of the corresponding eigenvalue in W\n*\n* WGAP (input/output) DOUBLE PRECISION array, dimension (N)\n* The separation from the right neighbor eigenvalue in W.\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The indices of the blocks (submatrices) associated with the\n* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n* W(i) belongs to the first block from the top, =2 if W(i)\n* belongs to the second block, etc.\n*\n* INDEXW (input) INTEGER array, dimension (N)\n* The indices of the eigenvalues within each block (submatrix);\n* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n* GERS (input) DOUBLE PRECISION array, dimension (2*N)\n* The N Gerschgorin intervals (the i-th Gerschgorin interval\n* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n* be computed from the original UNshifted matrix.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n* If INFO = 0, the first M columns of Z contain the\n* orthonormal eigenvectors of the matrix T\n* corresponding to the input eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The I-th eigenvector\n* is nonzero only in elements ISUPPZ( 2*I-1 ) through\n* ISUPPZ( 2*I ).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)\n*\n* IWORK (workspace) INTEGER array, dimension (7*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n*\n* > 0: A problem occured in ZLARRV.\n* < 0: One of the called subroutines signaled an internal problem.\n* Needs inspection of the corresponding parameter IINFO\n* for further information.\n*\n* =-1: Problem in DLARRB when refining a child's eigenvalues.\n* =-2: Problem in DLARRF when computing the RRR of a child.\n* When a child is inside a tight cluster, it can be difficult\n* to find an RRR. A partial remedy from the user's point of\n* view is to make the parameter MINRGP smaller and recompile.\n* However, as the orthogonality of the computed vectors is\n* proportional to 1/MINRGP, the user should be aware that\n* he might be trading in precision when he decreases MINRGP.\n* =-3: Problem in DLARRB when refining a single eigenvalue\n* after the Rayleigh correction was rejected.\n* = 5: The Rayleigh Quotient Iteration failed to converge to\n* full accuracy in MAXITR steps.\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 (argc != 18)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
- rb_vl = argv[0];
- rb_vu = argv[1];
- rb_d = argv[2];
- rb_l = argv[3];
- rb_pivmin = argv[4];
- rb_isplit = argv[5];
- rb_m = argv[6];
- rb_dol = argv[7];
- rb_dou = argv[8];
- rb_minrgp = argv[9];
- rb_rtol1 = argv[10];
- rb_rtol2 = argv[11];
- rb_w = argv[12];
- rb_werr = argv[13];
- rb_wgap = argv[14];
- rb_iblock = argv[15];
- rb_indexw = argv[16];
- rb_gers = argv[17];
-
- vl = NUM2DBL(rb_vl);
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (13th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- dol = NUM2INT(rb_dol);
- if (!NA_IsNArray(rb_l))
- rb_raise(rb_eArgError, "l (4th argument) must be NArray");
- if (NA_RANK(rb_l) != 1)
- rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_l) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of w");
- if (NA_TYPE(rb_l) != NA_DFLOAT)
- rb_l = na_change_type(rb_l, NA_DFLOAT);
- l = NA_PTR_TYPE(rb_l, doublereal*);
- pivmin = NUM2DBL(rb_pivmin);
- dou = NUM2INT(rb_dou);
- if (!NA_IsNArray(rb_wgap))
- rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
- if (NA_RANK(rb_wgap) != 1)
- rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
- if (NA_SHAPE0(rb_wgap) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of w");
- if (NA_TYPE(rb_wgap) != NA_DFLOAT)
- rb_wgap = na_change_type(rb_wgap, NA_DFLOAT);
- wgap = NA_PTR_TYPE(rb_wgap, doublereal*);
- m = NUM2INT(rb_m);
- minrgp = NUM2DBL(rb_minrgp);
- rtol2 = NUM2DBL(rb_rtol2);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_indexw))
- rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
- if (NA_RANK(rb_indexw) != 1)
- rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
- if (NA_SHAPE0(rb_indexw) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of w");
- if (NA_TYPE(rb_indexw) != NA_LINT)
- rb_indexw = na_change_type(rb_indexw, NA_LINT);
- indexw = NA_PTR_TYPE(rb_indexw, integer*);
- if (!NA_IsNArray(rb_werr))
- rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
- if (NA_RANK(rb_werr) != 1)
- rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
- if (NA_SHAPE0(rb_werr) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of w");
- if (NA_TYPE(rb_werr) != NA_DFLOAT)
- rb_werr = na_change_type(rb_werr, NA_DFLOAT);
- werr = NA_PTR_TYPE(rb_werr, doublereal*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- rtol1 = NUM2DBL(rb_rtol1);
- vu = NUM2DBL(rb_vu);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_gers))
- rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
- if (NA_RANK(rb_gers) != 1)
- rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
- if (NA_SHAPE0(rb_gers) != (2*n))
- rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
- if (NA_TYPE(rb_gers) != NA_DFLOAT)
- rb_gers = na_change_type(rb_gers, NA_DFLOAT);
- gers = NA_PTR_TYPE(rb_gers, doublereal*);
- ldz = n;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_l_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- l_out__ = NA_PTR_TYPE(rb_l_out__, doublereal*);
- MEMCPY(l_out__, l, doublereal, NA_TOTAL(rb_l));
- rb_l = rb_l_out__;
- l = l_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w_out__ = NA_PTR_TYPE(rb_w_out__, doublereal*);
- MEMCPY(w_out__, w, doublereal, NA_TOTAL(rb_w));
- rb_w = rb_w_out__;
- w = w_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- werr_out__ = NA_PTR_TYPE(rb_werr_out__, doublereal*);
- MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rb_werr));
- rb_werr = rb_werr_out__;
- werr = werr_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- wgap_out__ = NA_PTR_TYPE(rb_wgap_out__, doublereal*);
- MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rb_wgap));
- rb_wgap = rb_wgap_out__;
- wgap = wgap_out__;
- work = ALLOC_N(doublereal, (12*n));
- iwork = ALLOC_N(integer, (7*n));
-
- zlarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_z, rb_isuppz, rb_info, rb_d, rb_l, rb_w, rb_werr, rb_wgap);
-}
-
-void
-init_lapack_zlarrv(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarrv", rb_zlarrv, -1);
-}
diff --git a/zlarscl2.c b/zlarscl2.c
deleted file mode 100644
index 5ba52bb..0000000
--- a/zlarscl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarscl2_(integer *m, integer *n, doublereal *d, doublecomplex *x, integer *ldx);
-
-static VALUE
-rb_zlarscl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.zlarscl2( d, x)\n or\n NumRu::Lapack.zlarscl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* ZLARSCL2 performs a reciprocal diagonal scaling on an vector:\n* x <-- inv(D) * x\n* where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- zlarscl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_zlarscl2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarscl2", rb_zlarscl2, -1);
-}
diff --git a/zlartg.c b/zlartg.c
deleted file mode 100644
index ad10255..0000000
--- a/zlartg.c
+++ /dev/null
@@ -1,44 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlartg_(doublecomplex *f, doublecomplex *g, doublereal *cs, doublecomplex *sn, doublecomplex *r);
-
-static VALUE
-rb_zlartg(int argc, VALUE *argv, VALUE self){
- VALUE rb_f;
- doublecomplex f;
- VALUE rb_g;
- doublecomplex g;
- VALUE rb_cs;
- doublereal cs;
- VALUE rb_sn;
- doublecomplex sn;
- VALUE rb_r;
- doublecomplex r;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cs, sn, r = NumRu::Lapack.zlartg( f, g)\n or\n NumRu::Lapack.zlartg # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARTG( F, G, CS, SN, R )\n\n* Purpose\n* =======\n*\n* ZLARTG generates a plane rotation so that\n*\n* [ CS SN ] [ F ] [ R ]\n* [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.\n* [ -SN CS ] [ G ] [ 0 ]\n*\n* This is a faster version of the BLAS1 routine ZROTG, except for\n* the following differences:\n* F and G are unchanged on return.\n* If G=0, then CS=1 and SN=0.\n* If F=0, then CS=0 and SN is chosen so that R is real.\n*\n\n* Arguments\n* =========\n*\n* F (input) COMPLEX*16\n* The first component of vector to be rotated.\n*\n* G (input) COMPLEX*16\n* The second component of vector to be rotated.\n*\n* CS (output) DOUBLE PRECISION\n* The cosine of the rotation.\n*\n* SN (output) COMPLEX*16\n* The sine of the rotation.\n*\n* R (output) COMPLEX*16\n* The nonzero component of the rotated vector.\n*\n\n* Further Details\n* ======= =======\n*\n* 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n* This version has a few statements commented out for thread safety\n* (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_f = argv[0];
- rb_g = argv[1];
-
- f.r = NUM2DBL(rb_funcall(rb_f, rb_intern("real"), 0));
- f.i = NUM2DBL(rb_funcall(rb_f, rb_intern("imag"), 0));
- g.r = NUM2DBL(rb_funcall(rb_g, rb_intern("real"), 0));
- g.i = NUM2DBL(rb_funcall(rb_g, rb_intern("imag"), 0));
-
- zlartg_(&f, &g, &cs, &sn, &r);
-
- rb_cs = rb_float_new((double)cs);
- rb_sn = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn.r)), rb_float_new((double)(sn.i)));
- rb_r = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(r.r)), rb_float_new((double)(r.i)));
- return rb_ary_new3(3, rb_cs, rb_sn, rb_r);
-}
-
-void
-init_lapack_zlartg(VALUE mLapack){
- rb_define_module_function(mLapack, "zlartg", rb_zlartg, -1);
-}
diff --git a/zlartv.c b/zlartv.c
deleted file mode 100644
index fde4e9a..0000000
--- a/zlartv.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlartv_(integer *n, doublecomplex *x, integer *incx, doublecomplex *y, integer *incy, doublereal *c, doublecomplex *s, integer *incc);
-
-static VALUE
-rb_zlartv(int argc, VALUE *argv, VALUE self){
- VALUE rb_n;
- integer n;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublecomplex *s;
- VALUE rb_incc;
- integer incc;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, y = NumRu::Lapack.zlartv( n, x, incx, y, incy, c, s, incc)\n or\n NumRu::Lapack.zlartv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n* Purpose\n* =======\n*\n* ZLARTV applies a vector of complex plane rotations with real cosines\n* to elements of the complex vectors x and y. For i = 1,2,...,n\n*\n* ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n* ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(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.\n*\n* INCX (input) INTEGER\n* The increment between elements of X. INCX > 0.\n*\n* Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n* The vector y.\n*\n* INCY (input) INTEGER\n* The increment between elements of Y. INCY > 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, IY\n COMPLEX*16 XI, YI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_n = argv[0];
- rb_x = argv[1];
- rb_incx = argv[2];
- rb_y = argv[3];
- rb_incy = argv[4];
- rb_c = argv[5];
- rb_s = argv[6];
- rb_incc = argv[7];
-
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- incc = NUM2INT(rb_incc);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1+(n-1)*incx))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (4th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1+(n-1)*incy))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (1+(n-1)*incc))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
- if (NA_TYPE(rb_s) != NA_DCOMPLEX)
- rb_s = na_change_type(rb_s, NA_DCOMPLEX);
- s = NA_PTR_TYPE(rb_s, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1+(n-1)*incx;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = 1+(n-1)*incy;
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zlartv_(&n, x, &incx, y, &incy, c, s, &incc);
-
- return rb_ary_new3(2, rb_x, rb_y);
-}
-
-void
-init_lapack_zlartv(VALUE mLapack){
- rb_define_module_function(mLapack, "zlartv", rb_zlartv, -1);
-}
diff --git a/zlarz.c b/zlarz.c
deleted file mode 100644
index 6116b99..0000000
--- a/zlarz.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarz_(char *side, integer *m, integer *n, integer *l, doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work);
-
-static VALUE
-rb_zlarz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- doublecomplex tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarz( side, m, l, v, incv, tau, c)\n or\n NumRu::Lapack.zlarz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n* Purpose\n* =======\n*\n* ZLARZ applies a complex elementary reflector H to a complex\n* M-by-N matrix C, from either the left or the right. H is represented\n* in the form\n*\n* H = I - tau * v * v'\n*\n* where tau is a complex scalar and v is a complex vector.\n*\n* If tau = 0, then H is taken to be the unit matrix.\n*\n* To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n* tau.\n*\n* H is a product of k elementary reflectors as returned by ZTZRZF.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form H * C\n* = 'R': form C * H\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* L (input) INTEGER\n* The number of entries of the vector V containing\n* the meaningful part of the Householder vectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX*16 array, dimension (1+(L-1)*abs(INCV))\n* The vector v in the representation of H as returned by\n* ZTZRZF. V is not used if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0.\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of H.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n* or C * H if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (N) if SIDE = 'L'\n* or (M) if SIDE = 'R'\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_l = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- tau.r = NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- incv = NUM2INT(rb_incv);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1+(l-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zlarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_zlarz(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarz", rb_zlarz, -1);
-}
diff --git a/zlarzb.c b/zlarzb.c
deleted file mode 100644
index cc70922..0000000
--- a/zlarzb.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarzb_(char *side, char *trans, char *direct, char *storev, integer *m, integer *n, integer *k, integer *l, doublecomplex *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c, integer *ldc, doublecomplex *work, integer *ldwork);
-
-static VALUE
-rb_zlarzb(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_m;
- integer m;
- VALUE rb_l;
- integer l;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer ldv;
- integer nv;
- integer ldt;
- integer k;
- integer ldc;
- integer n;
- integer ldwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c = NumRu::Lapack.zlarzb( side, trans, direct, storev, m, l, v, t, c)\n or\n NumRu::Lapack.zlarzb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n* Purpose\n* =======\n*\n* ZLARZB applies a complex block reflector H or its transpose H**H\n* to a complex distributed M-by-N C from the left or the right.\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply H or H' from the Left\n* = 'R': apply H or H' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply H (No transpose)\n* = 'C': apply H' (Conjugate transpose)\n*\n* DIRECT (input) CHARACTER*1\n* Indicates how H is formed from a product of elementary\n* reflectors\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Indicates how the vectors which define the elementary\n* reflectors are stored:\n* = 'C': Columnwise (not supported yet)\n* = 'R': Rowwise\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* K (input) INTEGER\n* The order of the matrix T (= the number of elementary\n* reflectors whose product defines the block reflector).\n*\n* L (input) INTEGER\n* The number of columns of the matrix V containing the\n* meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* V (input) COMPLEX*16 array, dimension (LDV,NV).\n* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n* T (input) COMPLEX*16 array, dimension (LDT,K)\n* The triangular K-by-K matrix T in the representation of the\n* block reflector.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* If SIDE = 'L', LDWORK >= max(1,N);\n* if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_direct = argv[2];
- rb_storev = argv[3];
- rb_m = argv[4];
- rb_l = argv[5];
- rb_v = argv[6];
- rb_t = argv[7];
- rb_c = argv[8];
-
- trans = StringValueCStr(rb_trans)[0];
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (7th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
- nv = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- direct = StringValueCStr(rb_direct)[0];
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- storev = StringValueCStr(rb_storev)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (9th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (8th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
- k = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DCOMPLEX)
- rb_t = na_change_type(rb_t, NA_DCOMPLEX);
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- m = NUM2INT(rb_m);
- ldwork = max(1,n) ? side = 'l' : max(1,m) ? side = 'r' : 0;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (ldwork)*(k));
-
- zlarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);
-
- free(work);
- return rb_c;
-}
-
-void
-init_lapack_zlarzb(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarzb", rb_zlarzb, -1);
-}
diff --git a/zlarzt.c b/zlarzt.c
deleted file mode 100644
index aede229..0000000
--- a/zlarzt.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlarzt_(char *direct, char *storev, integer *n, integer *k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex *t, integer *ldt);
-
-static VALUE
-rb_zlarzt(int argc, VALUE *argv, VALUE self){
- VALUE rb_direct;
- char direct;
- VALUE rb_storev;
- char storev;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_v_out__;
- doublecomplex *v_out__;
-
- integer ldv;
- integer k;
- integer ldt;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n t, v = NumRu::Lapack.zlarzt( direct, storev, n, v, tau)\n or\n NumRu::Lapack.zlarzt # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n* Purpose\n* =======\n*\n* ZLARZT forms the triangular factor T of a complex block reflector\n* H of order > n, which is defined as a product of k elementary\n* reflectors.\n*\n* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n* If STOREV = 'C', the vector which defines the elementary reflector\n* H(i) is stored in the i-th column of the array V, and\n*\n* H = I - V * T * V'\n*\n* If STOREV = 'R', the vector which defines the elementary reflector\n* H(i) is stored in the i-th row of the array V, and\n*\n* H = I - V' * T * V\n*\n* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n* Arguments\n* =========\n*\n* DIRECT (input) CHARACTER*1\n* Specifies the order in which the elementary reflectors are\n* multiplied to form the block reflector:\n* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n* = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n* STOREV (input) CHARACTER*1\n* Specifies how the vectors which define the elementary\n* reflectors are stored (see also Further Details):\n* = 'C': columnwise (not supported yet)\n* = 'R': rowwise\n*\n* N (input) INTEGER\n* The order of the block reflector H. N >= 0.\n*\n* K (input) INTEGER\n* The order of the triangular factor T (= the number of\n* elementary reflectors). K >= 1.\n*\n* V (input/output) COMPLEX*16 array, dimension\n* (LDV,K) if STOREV = 'C'\n* (LDV,N) if STOREV = 'R'\n* The matrix V. See further details.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V.\n* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i).\n*\n* T (output) COMPLEX*16 array, dimension (LDT,K)\n* The k by k triangular factor T of the block reflector.\n* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n* lower triangular. The rest of the array is not used.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= K.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The shape of the matrix V and the storage of the vectors which define\n* the H(i) is best illustrated by the following example with n = 5 and\n* k = 3. The elements equal to 1 are not stored; the corresponding\n* array elements are modified but restored on exit. The rest of the\n* array is not used.\n*\n* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n*\n* ______V_____\n* ( v1 v2 v3 ) / \\\n* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n* ( v1 v2 v3 )\n* . . .\n* . . .\n* 1 . .\n* 1 .\n* 1\n*\n* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n*\n* ______V_____\n* 1 / \\\n* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n* . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n* . . .\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* V = ( v1 v2 v3 )\n* ( v1 v2 v3 )\n* ( v1 v2 v3 )\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_direct = argv[0];
- rb_storev = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_tau = argv[4];
-
- storev = StringValueCStr(rb_storev)[0];
- direct = StringValueCStr(rb_direct)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- ldt = k;
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = k;
- rb_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
- rb_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublecomplex*);
- MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
-
- zlarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);
-
- return rb_ary_new3(2, rb_t, rb_v);
-}
-
-void
-init_lapack_zlarzt(VALUE mLapack){
- rb_define_module_function(mLapack, "zlarzt", rb_zlarzt, -1);
-}
diff --git a/zlascl.c b/zlascl.c
deleted file mode 100644
index 20c2e30..0000000
--- a/zlascl.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlascl_(char *type, integer *kl, integer *ku, doublereal *cfrom, doublereal *cto, integer *m, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_zlascl(int argc, VALUE *argv, VALUE self){
- VALUE rb_type;
- char type;
- VALUE rb_kl;
- integer kl;
- VALUE rb_ku;
- integer ku;
- VALUE rb_cfrom;
- doublereal cfrom;
- VALUE rb_cto;
- doublereal cto;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zlascl( type, kl, ku, cfrom, cto, m, a)\n or\n NumRu::Lapack.zlascl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZLASCL multiplies the M by N complex matrix A by the real scalar\n* CTO/CFROM. This is done without over/underflow as long as the final\n* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n* A may be full, upper triangular, lower triangular, upper Hessenberg,\n* or banded.\n*\n\n* Arguments\n* =========\n*\n* TYPE (input) CHARACTER*1\n* TYPE indices the storage type of the input matrix.\n* = 'G': A is a full matrix.\n* = 'L': A is a lower triangular matrix.\n* = 'U': A is an upper triangular matrix.\n* = 'H': A is an upper Hessenberg matrix.\n* = 'B': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the lower\n* half stored.\n* = 'Q': A is a symmetric band matrix with lower bandwidth KL\n* and upper bandwidth KU and with the only the upper\n* half stored.\n* = 'Z': A is a band matrix with lower bandwidth KL and upper\n* bandwidth KU. See ZGBTRF for storage details.\n*\n* KL (input) INTEGER\n* The lower bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* KU (input) INTEGER\n* The upper bandwidth of A. Referenced only if TYPE = 'B',\n* 'Q' or 'Z'.\n*\n* CFROM (input) DOUBLE PRECISION\n* CTO (input) DOUBLE PRECISION\n* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n* without over/underflow if the final result CTO*A(I,J)/CFROM\n* can be represented without over/underflow. CFROM must be\n* nonzero.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The matrix to be multiplied by CTO/CFROM. See TYPE for the\n* storage type.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_type = argv[0];
- rb_kl = argv[1];
- rb_ku = argv[2];
- rb_cfrom = argv[3];
- rb_cto = argv[4];
- rb_m = argv[5];
- rb_a = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- kl = NUM2INT(rb_kl);
- m = NUM2INT(rb_m);
- cfrom = NUM2DBL(rb_cfrom);
- type = StringValueCStr(rb_type)[0];
- cto = NUM2DBL(rb_cto);
- ku = NUM2INT(rb_ku);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zlascl(VALUE mLapack){
- rb_define_module_function(mLapack, "zlascl", rb_zlascl, -1);
-}
diff --git a/zlascl2.c b/zlascl2.c
deleted file mode 100644
index e0dfebd..0000000
--- a/zlascl2.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlascl2_(integer *m, integer *n, doublereal *d, doublecomplex *x, integer *ldx);
-
-static VALUE
-rb_zlascl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
-
- integer m;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x = NumRu::Lapack.zlascl2( d, x)\n or\n NumRu::Lapack.zlascl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASCL2 ( M, N, D, X, LDX )\n\n* Purpose\n* =======\n*\n* ZLASCL2 performs a diagonal scaling on a vector:\n* x <-- D * x\n* where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n*\n* Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n* standard.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of D and X. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of D and X. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, length M\n* Diagonal matrix D, stored as a vector of length M.\n*\n* X (input/output) COMPLEX*16 array, dimension (LDX,N)\n* On entry, the vector X to be scaled by D.\n* On exit, the scaled vector.\n*\n* LDX (input) INTEGER\n* The leading dimension of the vector X. LDX >= 0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_x = argv[1];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (2th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- m = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
-
- zlascl2_(&m, &n, d, x, &ldx);
-
- return rb_x;
-}
-
-void
-init_lapack_zlascl2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlascl2", rb_zlascl2, -1);
-}
diff --git a/zlaset.c b/zlaset.c
deleted file mode 100644
index f6a4ba3..0000000
--- a/zlaset.c
+++ /dev/null
@@ -1,69 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaset_(char *uplo, integer *m, integer *n, doublecomplex *alpha, doublecomplex *beta, doublecomplex *a, integer *lda);
-
-static VALUE
-rb_zlaset(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_beta;
- doublecomplex beta;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.zlaset( uplo, m, alpha, beta, a)\n or\n NumRu::Lapack.zlaset # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n* Purpose\n* =======\n*\n* ZLASET initializes a 2-D array A to BETA on the diagonal and\n* ALPHA on the offdiagonals.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the part of the matrix A to be set.\n* = 'U': Upper triangular part is set. The lower triangle\n* is unchanged.\n* = 'L': Lower triangular part is set. The upper triangle\n* is unchanged.\n* Otherwise: All of the matrix A is set.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of A.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of A.\n*\n* ALPHA (input) COMPLEX*16\n* All the offdiagonal array elements are set to ALPHA.\n*\n* BETA (input) COMPLEX*16\n* All the diagonal array elements are set to BETA.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the m by n matrix A.\n* On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n* A(i,i) = BETA , 1 <= i <= min(m,n)\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_m = argv[1];
- rb_alpha = argv[2];
- rb_beta = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- beta.r = NUM2DBL(rb_funcall(rb_beta, rb_intern("real"), 0));
- beta.i = NUM2DBL(rb_funcall(rb_beta, rb_intern("imag"), 0));
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_zlaset(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaset", rb_zlaset, -1);
-}
diff --git a/zlasr.c b/zlasr.c
deleted file mode 100644
index 325c480..0000000
--- a/zlasr.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlasr_(char *side, char *pivot, char *direct, integer *m, integer *n, doublereal *c, doublereal *s, doublecomplex *a, integer *lda);
-
-static VALUE
-rb_zlasr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_pivot;
- char pivot;
- VALUE rb_direct;
- char direct;
- VALUE rb_m;
- integer m;
- VALUE rb_c;
- doublereal *c;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.zlasr( side, pivot, direct, m, c, s, a)\n or\n NumRu::Lapack.zlasr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n* Purpose\n* =======\n*\n* ZLASR applies a sequence of real plane rotations to a complex matrix\n* A, from either the left or the right.\n*\n* When SIDE = 'L', the transformation takes the form\n*\n* A := P*A\n*\n* and when SIDE = 'R', the transformation takes the form\n*\n* A := A*P**T\n*\n* where P is an orthogonal matrix consisting of a sequence of z plane\n* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n* and P**T is the transpose of P.\n* \n* When DIRECT = 'F' (Forward sequence), then\n* \n* P = P(z-1) * ... * P(2) * P(1)\n* \n* and when DIRECT = 'B' (Backward sequence), then\n* \n* P = P(1) * P(2) * ... * P(z-1)\n* \n* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n* \n* R(k) = ( c(k) s(k) )\n* = ( -s(k) c(k) ).\n* \n* When PIVOT = 'V' (Variable pivot), the rotation is performed\n* for the plane (k,k+1), i.e., P(k) has the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears as a rank-2 modification to the identity matrix in\n* rows and columns k and k+1.\n* \n* When PIVOT = 'T' (Top pivot), the rotation is performed for the\n* plane (1,k+1), so P(k) has the form\n* \n* P(k) = ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* \n* where R(k) appears in rows and columns 1 and k+1.\n* \n* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n* performed for the plane (k,z), giving P(k) the form\n* \n* P(k) = ( 1 )\n* ( ... )\n* ( 1 )\n* ( c(k) s(k) )\n* ( 1 )\n* ( ... )\n* ( 1 )\n* ( -s(k) c(k) )\n* \n* where R(k) appears in rows and columns k and z. The rotations are\n* performed without ever forming P(k) explicitly.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* Specifies whether the plane rotation matrix P is applied to\n* A on the left or the right.\n* = 'L': Left, compute A := P*A\n* = 'R': Right, compute A:= A*P**T\n*\n* PIVOT (input) CHARACTER*1\n* Specifies the plane for which P(k) is a plane rotation\n* matrix.\n* = 'V': Variable pivot, the plane (k,k+1)\n* = 'T': Top pivot, the plane (1,k+1)\n* = 'B': Bottom pivot, the plane (k,z)\n*\n* DIRECT (input) CHARACTER*1\n* Specifies whether P is a forward or backward sequence of\n* plane rotations.\n* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. If m <= 1, an immediate\n* return is effected.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. If n <= 1, an\n* immediate return is effected.\n*\n* C (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The cosines c(k) of the plane rotations.\n*\n* S (input) DOUBLE PRECISION array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* The sines s(k) of the plane rotations. The 2-by-2 plane\n* rotation part of the matrix P(k), R(k), has the form\n* R(k) = ( c(k) s(k) )\n* ( -s(k) c(k) ).\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The M-by-N matrix A. On exit, A is overwritten by P*A if\n* SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_pivot = argv[1];
- rb_direct = argv[2];
- rb_m = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
- rb_a = argv[6];
-
- direct = StringValueCStr(rb_direct)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (7th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- pivot = StringValueCStr(rb_pivot)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 1)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_c) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
- if (NA_TYPE(rb_c) != NA_DFLOAT)
- rb_c = na_change_type(rb_c, NA_DFLOAT);
- c = NA_PTR_TYPE(rb_c, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_zlasr(VALUE mLapack){
- rb_define_module_function(mLapack, "zlasr", rb_zlasr, -1);
-}
diff --git a/zlassq.c b/zlassq.c
deleted file mode 100644
index d13de61..0000000
--- a/zlassq.c
+++ /dev/null
@@ -1,51 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlassq_(integer *n, doublecomplex *x, integer *incx, doublereal *scale, doublereal *sumsq);
-
-static VALUE
-rb_zlassq(int argc, VALUE *argv, VALUE self){
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_sumsq;
- doublereal sumsq;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, sumsq = NumRu::Lapack.zlassq( x, incx, scale, sumsq)\n or\n NumRu::Lapack.zlassq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n* Purpose\n* =======\n*\n* ZLASSQ returns the values scl and ssq such that\n*\n* ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n* where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n* assumed to be at least unity and the value of ssq will then satisfy\n*\n* 1.0 .le. ssq .le. ( sumsq + 2*n ).\n*\n* scale is assumed to be non-negative and scl returns the value\n*\n* scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n* i\n*\n* scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n* SCALE and SUMSQ are overwritten by scl and ssq respectively.\n*\n* The routine makes only one pass through the vector X.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements to be used from the vector X.\n*\n* X (input) COMPLEX*16 array, dimension (N)\n* The vector x as described above.\n* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n* INCX (input) INTEGER\n* The increment between successive values of the vector X.\n* INCX > 0.\n*\n* SCALE (input/output) DOUBLE PRECISION\n* On entry, the value scale in the equation above.\n* On exit, SCALE is overwritten with the value scl .\n*\n* SUMSQ (input/output) DOUBLE PRECISION\n* On entry, the value sumsq in the equation above.\n* On exit, SUMSQ is overwritten with the value ssq .\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_x = argv[0];
- rb_incx = argv[1];
- rb_scale = argv[2];
- rb_sumsq = argv[3];
-
- scale = NUM2DBL(rb_scale);
- sumsq = NUM2DBL(rb_sumsq);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (1th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- incx = NUM2INT(rb_incx);
-
- zlassq_(&n, x, &incx, &scale, &sumsq);
-
- rb_scale = rb_float_new((double)scale);
- rb_sumsq = rb_float_new((double)sumsq);
- return rb_ary_new3(2, rb_scale, rb_sumsq);
-}
-
-void
-init_lapack_zlassq(VALUE mLapack){
- rb_define_module_function(mLapack, "zlassq", rb_zlassq, -1);
-}
diff --git a/zlaswp.c b/zlaswp.c
deleted file mode 100644
index ea446f4..0000000
--- a/zlaswp.c
+++ /dev/null
@@ -1,75 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlaswp_(integer *n, doublecomplex *a, integer *lda, integer *k1, integer *k2, integer *ipiv, integer *incx);
-
-static VALUE
-rb_zlaswp(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_k1;
- integer k1;
- VALUE rb_k2;
- integer k2;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_incx;
- integer incx;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.zlaswp( a, k1, k2, ipiv, incx)\n or\n NumRu::Lapack.zlaswp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n* Purpose\n* =======\n*\n* ZLASWP performs a series of row interchanges on the matrix A.\n* One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of columns of the matrix A.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the matrix of column dimension N to which the row\n* interchanges will be applied.\n* On exit, the permuted matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n*\n* K1 (input) INTEGER\n* The first element of IPIV for which a row interchange will\n* be done.\n*\n* K2 (input) INTEGER\n* The last element of IPIV for which a row interchange will\n* be done.\n*\n* IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n* The vector of pivot indices. Only the elements in positions\n* K1 through K2 of IPIV are accessed.\n* IPIV(K) = L implies rows K and L are to be interchanged.\n*\n* INCX (input) INTEGER\n* The increment between successive values of IPIV. If IPIV\n* is negative, the pivots are applied in reverse order.\n*\n\n* Further Details\n* ===============\n*\n* Modified by\n* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n COMPLEX*16 TEMP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_a = argv[0];
- rb_k1 = argv[1];
- rb_k2 = argv[2];
- rb_ipiv = argv[3];
- rb_incx = argv[4];
-
- k2 = NUM2INT(rb_k2);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- k1 = NUM2INT(rb_k1);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ipiv) != (k2*abs(incx)))
- rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);
-
- return rb_a;
-}
-
-void
-init_lapack_zlaswp(VALUE mLapack){
- rb_define_module_function(mLapack, "zlaswp", rb_zlaswp, -1);
-}
diff --git a/zlasyf.c b/zlasyf.c
deleted file mode 100644
index d6faca5..0000000
--- a/zlasyf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlasyf_(char *uplo, integer *n, integer *nb, integer *kb, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w, integer *ldw, integer *info);
-
-static VALUE
-rb_zlasyf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_kb;
- integer kb;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *w;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n kb, ipiv, info, a = NumRu::Lapack.zlasyf( uplo, nb, a)\n or\n NumRu::Lapack.zlasyf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n* Purpose\n* =======\n*\n* ZLASYF computes a partial factorization of a complex symmetric matrix\n* A using the Bunch-Kaufman diagonal pivoting method. The partial\n* factorization has the form:\n*\n* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n* ( 0 U22 ) ( 0 D ) ( U12' U22' )\n*\n* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n* ( L21 I ) ( 0 A22 ) ( 0 I )\n*\n* where the order of D is at most NB. The actual order is returned in\n* the argument KB, and is either NB or NB-1, or N if N <= NB.\n* Note that U' denotes the transpose of U.\n*\n* ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code\n* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n* A22 (if UPLO = 'L').\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* NB (input) INTEGER\n* The maximum number of columns of the matrix A that should be\n* factored. NB should be at least 2 to allow for 2-by-2 pivot\n* blocks.\n*\n* KB (output) INTEGER\n* The number of columns of A that were actually factored.\n* KB is either NB-1 or NB, or N if N <= NB.\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* On exit, A contains details of the partial factorization.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If UPLO = 'U', only the last KB elements of IPIV are set;\n* if UPLO = 'L', only the first KB elements are set.\n*\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* W (workspace) COMPLEX*16 array, dimension (LDW,NB)\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- w = ALLOC_N(doublecomplex, (ldw)*(MAX(1,nb)));
-
- zlasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);
-
- free(w);
- rb_kb = INT2NUM(kb);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_kb, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_zlasyf(VALUE mLapack){
- rb_define_module_function(mLapack, "zlasyf", rb_zlasyf, -1);
-}
diff --git a/zlat2c.c b/zlat2c.c
deleted file mode 100644
index 9484a6c..0000000
--- a/zlat2c.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlat2c_(char *uplo, integer *n, doublecomplex *a, integer *lda, complex *sa, integer *ldsa, integer *info);
-
-static VALUE
-rb_zlat2c(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_sa;
- complex *sa;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
- integer ldsa;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n sa, info = NumRu::Lapack.zlat2c( uplo, a)\n or\n NumRu::Lapack.zlat2c # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX\n* triangular matrix, A.\n*\n* RMAX is the overflow for the SINGLE PRECISION arithmetic\n* ZLAT2C checks that all the entries of A are between -RMAX and\n* RMAX. If not the convertion is aborted and a flag is raised.\n*\n* This is an auxiliary routine so there is no argument checking.\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* N (input) INTEGER\n* The number of rows and columns of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the N-by-N triangular coefficient matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* SA (output) COMPLEX array, dimension (LDSA,N)\n* Only the UPLO part of SA is referenced. On exit, if INFO=0,\n* the N-by-N coefficient matrix SA; if INFO>0, the content of\n* the UPLO part of SA is unspecified.\n*\n* LDSA (input) INTEGER\n* The leading dimension of the array SA. LDSA >= max(1,M).\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* = 1: an entry of the matrix A is greater than the SINGLE\n* PRECISION overflow threshold, in this case, the content\n* of the UPLO part of SA in exit is unspecified.\n*\n* =========\n*\n* .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n LOGICAL UPPER\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DBLE, DIMAG\n* ..\n* .. External Functions ..\n REAL SLAMCH\n LOGICAL LSAME\n EXTERNAL SLAMCH, LSAME\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- ldsa = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldsa;
- shape[1] = n;
- rb_sa = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
- }
- sa = NA_PTR_TYPE(rb_sa, complex*);
-
- zlat2c_(&uplo, &n, a, &lda, sa, &ldsa, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_sa, rb_info);
-}
-
-void
-init_lapack_zlat2c(VALUE mLapack){
- rb_define_module_function(mLapack, "zlat2c", rb_zlat2c, -1);
-}
diff --git a/zlatbs.c b/zlatbs.c
deleted file mode 100644
index 30cf4ca..0000000
--- a/zlatbs.c
+++ /dev/null
@@ -1,111 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlatbs_(char *uplo, char *trans, char *diag, char *normin, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info);
-
-static VALUE
-rb_zlatbs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_cnorm;
- doublereal *cnorm;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_cnorm_out__;
- doublereal *cnorm_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.zlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm)\n or\n NumRu::Lapack.zlatbs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* ZLATBS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular band matrix. Here A' denotes the transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine ZTBSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of subdiagonals or superdiagonals in the\n* triangular matrix A. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, ZTBSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTBSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call ZTBSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_kd = argv[4];
- rb_ab = argv[5];
- rb_x = argv[6];
- rb_cnorm = argv[7];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_DFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_DFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, doublereal*);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_ab) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of cnorm");
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, doublereal*);
- MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- zlatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_zlatbs(VALUE mLapack){
- rb_define_module_function(mLapack, "zlatbs", rb_zlatbs, -1);
-}
diff --git a/zlatdf.c b/zlatdf.c
deleted file mode 100644
index d061560..0000000
--- a/zlatdf.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlatdf_(integer *ijob, integer *n, doublecomplex *z, integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal *rdscal, integer *ipiv, integer *jpiv);
-
-static VALUE
-rb_zlatdf(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_rhs;
- doublecomplex *rhs;
- VALUE rb_rdsum;
- doublereal rdsum;
- VALUE rb_rdscal;
- doublereal rdscal;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_jpiv;
- integer *jpiv;
- VALUE rb_rhs_out__;
- doublecomplex *rhs_out__;
-
- integer ldz;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rhs, rdsum, rdscal = NumRu::Lapack.zlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv)\n or\n NumRu::Lapack.zlatdf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n* Purpose\n* =======\n*\n* ZLATDF computes the contribution to the reciprocal Dif-estimate\n* by solving for x in Z * x = b, where b is chosen such that the norm\n* of x is as large as possible. It is assumed that LU decomposition\n* of Z has been computed by ZGETC2. On entry RHS = f holds the\n* contribution from earlier solved sub-systems, and on return RHS = x.\n*\n* The factorization of Z returned by ZGETC2 has the form\n* Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n* triangular with unit diagonal elements and U is upper triangular.\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) INTEGER\n* IJOB = 2: First compute an approximative null-vector e\n* of Z using ZGECON, e is normalized and solve for\n* Zx = +-e - f with the sign giving the greater value of\n* 2-norm(x). About 5 times as expensive as Default.\n* IJOB .ne. 2: Local look ahead strategy where\n* all entries of the r.h.s. b is choosen as either +1 or\n* -1. Default.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Z.\n*\n* Z (input) DOUBLE PRECISION array, dimension (LDZ, N)\n* On entry, the LU part of the factorization of the n-by-n\n* matrix Z computed by ZGETC2: Z = P * L * U * Q\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDA >= max(1, N).\n*\n* RHS (input/output) DOUBLE PRECISION array, dimension (N).\n* On entry, RHS contains contributions from other subsystems.\n* On exit, RHS contains the solution of the subsystem with\n* entries according to the value of IJOB (see above).\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by ZTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n* ZTGSYL.\n*\n* IPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= i <= N, row i of the\n* matrix has been interchanged with row IPIV(i).\n*\n* JPIV (input) INTEGER array, dimension (N).\n* The pivot indices; for 1 <= j <= N, column j of the\n* matrix has been interchanged with column JPIV(j).\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* This routine is a further developed implementation of algorithm\n* BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n* [1] Bo Kagstrom and Lars Westin,\n* Generalized Schur Methods with Condition Estimators for\n* Solving the Generalized Sylvester Equation, IEEE Transactions\n* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n* [2] Peter Poromaa,\n* On Efficient and Robust Estimators for the Separation\n* between two Regular Matrix Pairs with Applications in\n* Condition Estimation. Report UMINF-95.05, Department of\n* Computing Science, Umea University, S-901 87 Umea, Sweden,\n* 1995.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_ijob = argv[0];
- rb_z = argv[1];
- rb_rhs = argv[2];
- rb_rdsum = argv[3];
- rb_rdscal = argv[4];
- rb_ipiv = argv[5];
- rb_jpiv = argv[6];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- rdscal = NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (2th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of ipiv");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- rdsum = NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_rhs))
- rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
- if (NA_RANK(rb_rhs) != 1)
- rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_rhs) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_rhs) != NA_DCOMPLEX)
- rb_rhs = na_change_type(rb_rhs, NA_DCOMPLEX);
- rhs = NA_PTR_TYPE(rb_rhs, doublecomplex*);
- if (!NA_IsNArray(rb_jpiv))
- rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
- if (NA_RANK(rb_jpiv) != 1)
- rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_jpiv) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_jpiv) != NA_LINT)
- rb_jpiv = na_change_type(rb_jpiv, NA_LINT);
- jpiv = NA_PTR_TYPE(rb_jpiv, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_rhs_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- rhs_out__ = NA_PTR_TYPE(rb_rhs_out__, doublecomplex*);
- MEMCPY(rhs_out__, rhs, doublecomplex, NA_TOTAL(rb_rhs));
- rb_rhs = rb_rhs_out__;
- rhs = rhs_out__;
-
- zlatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);
-
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(3, rb_rhs, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_zlatdf(VALUE mLapack){
- rb_define_module_function(mLapack, "zlatdf", rb_zlatdf, -1);
-}
diff --git a/zlatps.c b/zlatps.c
deleted file mode 100644
index eeea77a..0000000
--- a/zlatps.c
+++ /dev/null
@@ -1,105 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlatps_(char *uplo, char *trans, char *diag, char *normin, integer *n, doublecomplex *ap, doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info);
-
-static VALUE
-rb_zlatps(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_cnorm;
- doublereal *cnorm;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_cnorm_out__;
- doublereal *cnorm_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.zlatps( uplo, trans, diag, normin, ap, x, cnorm)\n or\n NumRu::Lapack.zlatps # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* ZLATPS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow, where A is an upper or lower\n* triangular matrix stored in packed form. Here A**T denotes the\n* transpose of A, A**H denotes the conjugate transpose of A, x and b\n* are n-element vectors, and s is a scaling factor, usually less than\n* or equal to 1, chosen so that the components of x will be less than\n* the overflow threshold. If the unscaled problem will not cause\n* overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A\n* is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n* non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 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*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, ZTPSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_ap = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_DFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_DFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, doublereal*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- normin = StringValueCStr(rb_normin)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, doublereal*);
- MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- zlatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_zlatps(VALUE mLapack){
- rb_define_module_function(mLapack, "zlatps", rb_zlatps, -1);
-}
diff --git a/zlatrd.c b/zlatrd.c
deleted file mode 100644
index bec6e21..0000000
--- a/zlatrd.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlatrd_(char *uplo, integer *n, integer *nb, doublecomplex *a, integer *lda, doublereal *e, doublecomplex *tau, doublecomplex *w, integer *ldw);
-
-static VALUE
-rb_zlatrd(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_nb;
- integer nb;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer ldw;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n e, tau, w, a = NumRu::Lapack.zlatrd( uplo, nb, a)\n or\n NumRu::Lapack.zlatrd # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n* Purpose\n* =======\n*\n* ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n* Hermitian tridiagonal form by a unitary similarity\n* transformation Q' * A * Q, and returns the matrices V and W which are\n* needed to apply the transformation to the unreduced part of A.\n*\n* If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a\n* matrix, of which the upper triangle is supplied;\n* if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a\n* matrix, of which the lower triangle is supplied.\n*\n* This is an auxiliary routine called by ZHETRD.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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*\n* NB (input) INTEGER\n* The number of rows and columns to be reduced.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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* On exit:\n* if UPLO = 'U', the last NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements above the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors;\n* if UPLO = 'L', the first NB columns have been reduced to\n* tridiagonal form, with the diagonal elements overwriting\n* the diagonal elements of A; the elements below the diagonal\n* with the array TAU, represent the unitary matrix Q as a\n* product of elementary reflectors.\n* See Further Details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* E (output) DOUBLE PRECISION array, dimension (N-1)\n* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n* elements of the last NB columns of the reduced matrix;\n* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n* the first NB columns of the reduced matrix.\n*\n* TAU (output) COMPLEX*16 array, dimension (N-1)\n* The scalar factors of the elementary reflectors, stored in\n* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n* See Further Details.\n*\n* W (output) COMPLEX*16 array, dimension (LDW,NB)\n* The n-by-nb matrix W required to update the unreduced part\n* of A.\n*\n* LDW (input) INTEGER\n* The leading dimension of the array W. LDW >= max(1,N).\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n* and tau in TAU(i-1).\n*\n* If UPLO = 'L', the matrix Q is represented as a product of elementary\n* reflectors\n*\n* Q = H(1) H(2) . . . H(nb).\n*\n* Each H(i) has the form\n*\n* H(i) = I - tau * v * v'\n*\n* where tau is a complex scalar, and v is a complex vector with\n* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n* and tau in TAU(i).\n*\n* The elements of the vectors v together form the n-by-nb matrix V\n* which is needed, with W, to apply the transformation to the unreduced\n* part of the matrix, using a Hermitian rank-2k update of the form:\n* A := A - V*W' - W*V'.\n*\n* The contents of A on exit are illustrated by the following examples\n* with n = 5 and nb = 2:\n*\n* if UPLO = 'U': if UPLO = 'L':\n*\n* ( a a a v4 v5 ) ( d )\n* ( a a v4 v5 ) ( 1 d )\n* ( a 1 v5 ) ( v1 1 a )\n* ( d 1 ) ( v1 v2 a a )\n* ( d ) ( v1 v2 a a a )\n*\n* where d denotes a diagonal element of the reduced matrix, a denotes\n* an element of the original matrix that is unchanged, and vi denotes\n* an element of the vector defining H(i).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_nb = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- nb = NUM2INT(rb_nb);
- ldw = MAX(1,n);
- {
- int shape[1];
- shape[0] = n-1;
- rb_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n-1;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldw;
- shape[1] = MAX(n,nb);
- rb_w = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);
-
- return rb_ary_new3(4, rb_e, rb_tau, rb_w, rb_a);
-}
-
-void
-init_lapack_zlatrd(VALUE mLapack){
- rb_define_module_function(mLapack, "zlatrd", rb_zlatrd, -1);
-}
diff --git a/zlatrs.c b/zlatrs.c
deleted file mode 100644
index 316f0a6..0000000
--- a/zlatrs.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlatrs_(char *uplo, char *trans, char *diag, char *normin, integer *n, doublecomplex *a, integer *lda, doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info);
-
-static VALUE
-rb_zlatrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_normin;
- char normin;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_cnorm;
- doublereal *cnorm;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_cnorm_out__;
- doublereal *cnorm_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, x, cnorm = NumRu::Lapack.zlatrs( uplo, trans, diag, normin, a, x, cnorm)\n or\n NumRu::Lapack.zlatrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n* Purpose\n* =======\n*\n* ZLATRS solves one of the triangular systems\n*\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n*\n* with scaling to prevent overflow. Here A is an upper or lower\n* triangular matrix, A**T denotes the transpose of A, A**H denotes the\n* conjugate transpose of A, x and b are n-element vectors, and s is a\n* scaling factor, usually less than or equal to 1, chosen so that the\n* components of x will be less than the overflow threshold. If the\n* unscaled problem will not cause overflow, the Level 2 BLAS routine\n* ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* TRANS (input) CHARACTER*1\n* Specifies the operation applied to A.\n* = 'N': Solve A * x = s*b (No transpose)\n* = 'T': Solve A**T * x = s*b (Transpose)\n* = 'C': Solve A**H * x = s*b (Conjugate transpose)\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit triangular\n*\n* NORMIN (input) CHARACTER*1\n* Specifies whether CNORM has been set or not.\n* = 'Y': CNORM contains the column norms on entry\n* = 'N': CNORM is not set on entry. On exit, the norms will\n* be computed and stored in CNORM.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading n by n\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading n by n lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max (1,N).\n*\n* X (input/output) COMPLEX*16 array, dimension (N)\n* On entry, the right hand side b of the triangular system.\n* On exit, X is overwritten by the solution vector x.\n*\n* SCALE (output) DOUBLE PRECISION\n* The scaling factor s for the triangular system\n* A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n* If SCALE = 0, the matrix A is singular or badly scaled, and\n* the vector x is an exact or approximate solution to A*x = 0.\n*\n* CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n*\n* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n* contains the norm of the off-diagonal part of the j-th column\n* of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n* must be greater than or equal to the 1-norm.\n*\n* If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n* returns the 1-norm of the offdiagonal part of the j-th column\n* of A.\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* Further Details\n* ======= =======\n*\n* A rough bound on x is computed; if that is less than overflow, ZTRSV\n* is called, otherwise, specific code is used which checks for possible\n* overflow or divide-by-zero at every operation.\n*\n* A columnwise scheme is used for solving A*x = b. The basic algorithm\n* if A is lower triangular is\n*\n* x[1:n] := b[1:n]\n* for j = 1, ..., n\n* x(j) := x(j) / A(j,j)\n* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n* end\n*\n* Define bounds on the components of x after j iterations of the loop:\n* M(j) = bound on x[1:j]\n* G(j) = bound on x[j+1:n]\n* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n* Then for iteration j+1 we have\n* M(j+1) <= G(j) / | A(j+1,j+1) |\n* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n* where CNORM(j+1) is greater than or equal to the infinity-norm of\n* column j+1 of A, not counting the diagonal. Hence\n*\n* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n* 1<=i<=j\n* and\n*\n* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n* 1<=i< j\n*\n* Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the\n* reciprocal of the largest M(j), j=1,..,n, is larger than\n* max(underflow, 1/overflow).\n*\n* The bound on x(j) is also used to determine when a step in the\n* columnwise method can be performed without fear of overflow. If\n* the computed bound is greater than a large constant, x is scaled to\n* prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n* Similarly, a row-wise scheme is used to solve A**T *x = b or\n* A**H *x = b. The basic algorithm for A upper triangular is\n*\n* for j = 1, ..., n\n* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n* end\n*\n* We simultaneously compute two bounds\n* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n* M(j) = bound on x(i), 1<=i<=j\n*\n* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n* Then the bound on x(j) is\n*\n* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n* 1<=i<=j\n*\n* and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater\n* than max(underflow, 1/overflow).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_normin = argv[3];
- rb_a = argv[4];
- rb_x = argv[5];
- rb_cnorm = argv[6];
-
- if (!NA_IsNArray(rb_cnorm))
- rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
- if (NA_RANK(rb_cnorm) != 1)
- rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cnorm);
- if (NA_TYPE(rb_cnorm) != NA_DFLOAT)
- rb_cnorm = na_change_type(rb_cnorm, NA_DFLOAT);
- cnorm = NA_PTR_TYPE(rb_cnorm, doublereal*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of cnorm");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 0 of cnorm");
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- normin = StringValueCStr(rb_normin)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- cnorm_out__ = NA_PTR_TYPE(rb_cnorm_out__, doublereal*);
- MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rb_cnorm));
- rb_cnorm = rb_cnorm_out__;
- cnorm = cnorm_out__;
-
- zlatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_scale, rb_info, rb_x, rb_cnorm);
-}
-
-void
-init_lapack_zlatrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zlatrs", rb_zlatrs, -1);
-}
diff --git a/zlatrz.c b/zlatrz.c
deleted file mode 100644
index 152155a..0000000
--- a/zlatrz.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlatrz_(integer *m, integer *n, integer *l, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work);
-
-static VALUE
-rb_zlatrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, a = NumRu::Lapack.zlatrz( l, a)\n or\n NumRu::Lapack.zlatrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n* Purpose\n* =======\n*\n* ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means\n* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary\n* matrix and, R and A1 are M-by-M upper triangular matrices.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing the\n* meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements N-L+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an l element vector. tau and z( k )\n* are chosen to annihilate the elements of the kth row of A2.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A2, such that the elements of z( k ) are\n* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A1.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_l = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- l = NUM2INT(rb_l);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (m));
-
- zlatrz_(&m, &n, &l, a, &lda, tau, work);
-
- free(work);
- return rb_ary_new3(2, rb_tau, rb_a);
-}
-
-void
-init_lapack_zlatrz(VALUE mLapack){
- rb_define_module_function(mLapack, "zlatrz", rb_zlatrz, -1);
-}
diff --git a/zlatzm.c b/zlatzm.c
deleted file mode 100644
index ecd85d8..0000000
--- a/zlatzm.c
+++ /dev/null
@@ -1,113 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlatzm_(char *side, integer *m, integer *n, doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *c1, doublecomplex *c2, integer *ldc, doublecomplex *work);
-
-static VALUE
-rb_zlatzm(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_m;
- integer m;
- VALUE rb_n;
- integer n;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_incv;
- integer incv;
- VALUE rb_tau;
- doublecomplex tau;
- VALUE rb_c1;
- doublecomplex *c1;
- VALUE rb_c2;
- doublecomplex *c2;
- VALUE rb_c1_out__;
- doublecomplex *c1_out__;
- VALUE rb_c2_out__;
- doublecomplex *c2_out__;
- doublecomplex *work;
-
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n c1, c2 = NumRu::Lapack.zlatzm( side, m, n, v, incv, tau, c1, c2)\n or\n NumRu::Lapack.zlatzm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZUNMRZ.\n*\n* ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix.\n*\n* Let P = I - tau*u*u', u = ( 1 ),\n* ( v )\n* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n* SIDE = 'R'.\n*\n* If SIDE equals 'L', let\n* C = [ C1 ] 1\n* [ C2 ] m-1\n* n\n* Then C is overwritten by P*C.\n*\n* If SIDE equals 'R', let\n* C = [ C1, C2 ] m\n* 1 n-1\n* Then C is overwritten by C*P.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': form P * C\n* = 'R': form C * P\n*\n* M (input) INTEGER\n* The number of rows of the matrix C.\n*\n* N (input) INTEGER\n* The number of columns of the matrix C.\n*\n* V (input) COMPLEX*16 array, dimension\n* (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n* (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n* The vector v in the representation of P. V is not used\n* if TAU = 0.\n*\n* INCV (input) INTEGER\n* The increment between elements of v. INCV <> 0\n*\n* TAU (input) COMPLEX*16\n* The value tau in the representation of P.\n*\n* C1 (input/output) COMPLEX*16 array, dimension\n* (LDC,N) if SIDE = 'L'\n* (M,1) if SIDE = 'R'\n* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n* if SIDE = 'R'.\n*\n* On exit, the first row of P*C if SIDE = 'L', or the first\n* column of C*P if SIDE = 'R'.\n*\n* C2 (input/output) COMPLEX*16 array, dimension\n* (LDC, N) if SIDE = 'L'\n* (LDC, N-1) if SIDE = 'R'\n* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n* m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n* if SIDE = 'R'.\n*\n* LDC (input) INTEGER\n* The leading dimension of the arrays C1 and C2.\n* LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 array, dimension\n* (N) if SIDE = 'L'\n* (M) if SIDE = 'R'\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_m = argv[1];
- rb_n = argv[2];
- rb_v = argv[3];
- rb_incv = argv[4];
- rb_tau = argv[5];
- rb_c1 = argv[6];
- rb_c2 = argv[7];
-
- tau.r = NUM2DBL(rb_funcall(rb_tau, rb_intern("real"), 0));
- tau.i = NUM2DBL(rb_funcall(rb_tau, rb_intern("imag"), 0));
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- incv = NUM2INT(rb_incv);
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_c2))
- rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
- if (NA_RANK(rb_c2) != 2)
- rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
- ldc = NA_SHAPE0(rb_c2);
- if (NA_TYPE(rb_c2) != NA_DCOMPLEX)
- rb_c2 = na_change_type(rb_c2, NA_DCOMPLEX);
- c2 = NA_PTR_TYPE(rb_c2, doublecomplex*);
- if (!NA_IsNArray(rb_c1))
- rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
- if (NA_RANK(rb_c1) != 2)
- rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
- if (NA_SHAPE0(rb_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
- if (NA_TYPE(rb_c1) != NA_DCOMPLEX)
- rb_c1 = na_change_type(rb_c1, NA_DCOMPLEX);
- c1 = NA_PTR_TYPE(rb_c1, doublecomplex*);
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (4th argument) must be NArray");
- if (NA_RANK(rb_v) != 1)
- rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_v) != (1 + (m-1)*abs(incv)))
- rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- {
- int shape[2];
- shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
- rb_c1_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c1_out__ = NA_PTR_TYPE(rb_c1_out__, doublecomplex*);
- MEMCPY(c1_out__, c1, doublecomplex, NA_TOTAL(rb_c1));
- rb_c1 = rb_c1_out__;
- c1 = c1_out__;
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
- rb_c2_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c2_out__ = NA_PTR_TYPE(rb_c2_out__, doublecomplex*);
- MEMCPY(c2_out__, c2, doublecomplex, NA_TOTAL(rb_c2));
- rb_c2 = rb_c2_out__;
- c2 = c2_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zlatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);
-
- free(work);
- return rb_ary_new3(2, rb_c1, rb_c2);
-}
-
-void
-init_lapack_zlatzm(VALUE mLapack){
- rb_define_module_function(mLapack, "zlatzm", rb_zlatzm, -1);
-}
diff --git a/zlauu2.c b/zlauu2.c
deleted file mode 100644
index 6f4a6c8..0000000
--- a/zlauu2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlauu2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_zlauu2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zlauu2( uplo, a)\n or\n NumRu::Lapack.zlauu2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAUU2 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) COMPLEX*16 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlauu2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zlauu2(VALUE mLapack){
- rb_define_module_function(mLapack, "zlauu2", rb_zlauu2, -1);
-}
diff --git a/zlauum.c b/zlauum.c
deleted file mode 100644
index 96ccfcd..0000000
--- a/zlauum.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zlauum_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_zlauum(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zlauum( uplo, a)\n or\n NumRu::Lapack.zlauum # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZLAUUM 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) COMPLEX*16 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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zlauum_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zlauum(VALUE mLapack){
- rb_define_module_function(mLapack, "zlauum", rb_zlauum, -1);
-}
diff --git a/zpbcon.c b/zpbcon.c
deleted file mode 100644
index 805e61e..0000000
--- a/zpbcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbcon_(char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zpbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zpbcon( uplo, kd, ab, anorm)\n or\n NumRu::Lapack.zpbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPBCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite band matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* ZPBTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the Hermitian band matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zpbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbcon", rb_zpbcon, -1);
-}
diff --git a/zpbequ.c b/zpbequ.c
deleted file mode 100644
index 52562a7..0000000
--- a/zpbequ.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbequ_(char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_zpbequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zpbequ( uplo, kd, ab)\n or\n NumRu::Lapack.zpbequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPBEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite band matrix A and reduce its condition\n* number (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular of A is stored;\n* = 'L': Lower triangular of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- zpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_zpbequ(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbequ", rb_zpbequ, -1);
-}
diff --git a/zpbrfs.c b/zpbrfs.c
deleted file mode 100644
index a91b893..0000000
--- a/zpbrfs.c
+++ /dev/null
@@ -1,126 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbrfs_(char *uplo, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zpbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zpbrfs( uplo, kd, ab, afb, b, x)\n or\n NumRu::Lapack.zpbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPBRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and banded, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n* The upper or lower triangle of the Hermitian band matrix A,\n* stored in the first KD+1 rows of the array. The j-th column\n* of A is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A as computed by\n* ZPBTRF, in the same storage format as A (see AB).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPBTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_afb = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- kd = NUM2INT(rb_kd);
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zpbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbrfs", rb_zpbrfs, -1);
-}
diff --git a/zpbstf.c b/zpbstf.c
deleted file mode 100644
index 3339616..0000000
--- a/zpbstf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbstf_(char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_zpbstf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.zpbstf( uplo, kd, ab)\n or\n NumRu::Lapack.zpbstf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBSTF computes a split Cholesky factorization of a complex\n* Hermitian positive definite band matrix A.\n*\n* This routine is designed to be used in conjunction with ZHBGST.\n*\n* The factorization has the form A = S**H*S where S is a band matrix\n* of the same bandwidth as A and the following structure:\n*\n* S = ( U )\n* ( M L )\n*\n* where U is upper triangular of order m = (n+kd)/2, and L is lower\n* triangular of order n-m.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first kd+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the factor S from the split Cholesky\n* factorization A = S**H*S. See Further Details.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the factorization could not be completed,\n* because the updated element a(i,i) was negative; the\n* matrix A is not positive definite.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 7, KD = 2:\n*\n* S = ( s11 s12 s13 )\n* ( s22 s23 s24 )\n* ( s33 s34 )\n* ( s44 )\n* ( s53 s54 s55 )\n* ( s64 s65 s66 )\n* ( s75 s76 s77 )\n*\n* If UPLO = 'U', the array AB holds:\n*\n* on entry: on exit:\n*\n* * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'\n* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n*\n* If UPLO = 'L', the array AB holds:\n*\n* on entry: on exit:\n*\n* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n* a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *\n* a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *\n*\n* Array elements marked * are not used by the routine; s12' denotes\n* conjg(s12); the diagonal elements of S are real.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zpbstf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_zpbstf(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbstf", rb_zpbstf, -1);
-}
diff --git a/zpbsv.c b/zpbsv.c
deleted file mode 100644
index 68671d1..0000000
--- a/zpbsv.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbsv_(char *uplo, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zpbsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab, b = NumRu::Lapack.zpbsv( uplo, kd, ab, b)\n or\n NumRu::Lapack.zpbsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix, with the same number of superdiagonals or\n* subdiagonals as A. The factored form of A is then used to solve the\n* system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPBTRF, ZPBTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ab, rb_b);
-}
-
-void
-init_lapack_zpbsv(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbsv", rb_zpbsv, -1);
-}
diff --git a/zpbsvx.c b/zpbsvx.c
deleted file mode 100644
index 300d9e7..0000000
--- a/zpbsvx.c
+++ /dev/null
@@ -1,182 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbsvx_(char *fact, char *uplo, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zpbsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_afb;
- doublecomplex *afb;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
- VALUE rb_afb_out__;
- doublecomplex *afb_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldafb;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.zpbsvx( fact, uplo, kd, ab, afb, equed, s, b)\n or\n NumRu::Lapack.zpbsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite band matrix and X\n* and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular band matrix, and L is a lower\n* triangular band matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFB contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AB and AFB will not\n* be modified.\n* = 'N': The matrix A will be copied to AFB and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFB and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array, except\n* if FACT = 'F' and EQUED = 'Y', then A must contain the\n* equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n* is stored in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n* See below for further details.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array A. LDAB >= KD+1.\n*\n* AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n* If FACT = 'F', then AFB is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the band matrix\n* A, in the same storage format as A (see AB). If EQUED = 'Y',\n* then AFB is the factored form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* If FACT = 'E', then AFB is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAFB (input) INTEGER\n* The leading dimension of the array AFB. LDAFB >= KD+1.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13\n* a22 a23 a24\n* a33 a34 a35\n* a44 a45 a46\n* a55 a56\n* (aij=conjg(aji)) a66\n*\n* Band storage of the upper triangle of A:\n*\n* * * a13 a24 a35 a46\n* * a12 a23 a34 a45 a56\n* a11 a22 a33 a44 a55 a66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* a11 a22 a33 a44 a55 a66\n* a21 a32 a43 a54 a65 *\n* a31 a42 a53 a64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_kd = argv[2];
- rb_ab = argv[3];
- rb_afb = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- kd = NUM2INT(rb_kd);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_afb))
- rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
- if (NA_RANK(rb_afb) != 2)
- rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_afb) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
- ldafb = NA_SHAPE0(rb_afb);
- if (NA_TYPE(rb_afb) != NA_DCOMPLEX)
- rb_afb = na_change_type(rb_afb, NA_DCOMPLEX);
- afb = NA_PTR_TYPE(rb_afb, doublecomplex*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
- {
- int shape[2];
- shape[0] = ldafb;
- shape[1] = n;
- rb_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- afb_out__ = NA_PTR_TYPE(rb_afb_out__, doublecomplex*);
- MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rb_afb));
- rb_afb = rb_afb_out__;
- afb = afb_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ab, rb_afb, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_zpbsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbsvx", rb_zpbsvx, -1);
-}
diff --git a/zpbtf2.c b/zpbtf2.c
deleted file mode 100644
index dec3bac..0000000
--- a/zpbtf2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbtf2_(char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_zpbtf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.zpbtf2( uplo, kd, ab)\n or\n NumRu::Lapack.zpbtf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, U' is the conjugate transpose\n* of U, and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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* KD (input) INTEGER\n* The number of super-diagonals of the matrix A if UPLO = 'U',\n* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U'*U or A = L*L' of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_zpbtf2(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbtf2", rb_zpbtf2, -1);
-}
diff --git a/zpbtrf.c b/zpbtrf.c
deleted file mode 100644
index 11157cc..0000000
--- a/zpbtrf.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbtrf_(char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, integer *info);
-
-static VALUE
-rb_zpbtrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_info;
- integer info;
- VALUE rb_ab_out__;
- doublecomplex *ab_out__;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ab = NumRu::Lapack.zpbtrf( uplo, kd, ab)\n or\n NumRu::Lapack.zpbtrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite band matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n*\n* AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n* On entry, the upper or lower triangle of the Hermitian band\n* matrix A, stored in the first KD+1 rows of the array. The\n* j-th column of A is stored in the j-th column of the array AB\n* as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H of the band\n* matrix A, in the same storage format as A.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The band storage scheme is illustrated by the following example, when\n* N = 6, KD = 2, and UPLO = 'U':\n*\n* On entry: On exit:\n*\n* * * a13 a24 a35 a46 * * u13 u24 u35 u46\n* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n*\n* Similarly, if UPLO = 'L' the format of A is as follows:\n*\n* On entry: On exit:\n*\n* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n* a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n*\n* Array elements marked * are not used by the routine.\n*\n* Contributed by\n* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldab;
- shape[1] = n;
- rb_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- ab_out__ = NA_PTR_TYPE(rb_ab_out__, doublecomplex*);
- MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rb_ab));
- rb_ab = rb_ab_out__;
- ab = ab_out__;
-
- zpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ab);
-}
-
-void
-init_lapack_zpbtrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbtrf", rb_zpbtrf, -1);
-}
diff --git a/zpbtrs.c b/zpbtrs.c
deleted file mode 100644
index 6b54b76..0000000
--- a/zpbtrs.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpbtrs_(char *uplo, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zpbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpbtrs( uplo, kd, ab, b)\n or\n NumRu::Lapack.zpbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPBTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite band matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by ZPBTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor stored in AB;\n* = 'L': Lower triangular factor stored in AB.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* KD (input) INTEGER\n* The number of superdiagonals of the matrix A if UPLO = 'U',\n* or the number of subdiagonals if UPLO = 'L'. KD >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H of the band matrix A, stored in the\n* first KD+1 rows of the array. The j-th column of U or L is\n* stored in the j-th column of the array AB as follows:\n* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZTBSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_kd = argv[1];
- rb_ab = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- kd = NUM2INT(rb_kd);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zpbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zpbtrs", rb_zpbtrs, -1);
-}
diff --git a/zpftrf.c b/zpftrf.c
deleted file mode 100644
index 0137573..0000000
--- a/zpftrf.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpftrf_(char *transr, char *uplo, integer *n, complex *a, integer *info);
-
-static VALUE
-rb_zpftrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- complex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- complex *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zpftrf( transr, uplo, n, a)\n or\n NumRu::Lapack.zpftrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* ZPFTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization RFP A = U**H*U or RFP A = L*L**H.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n* Further Notes on RFP Format:\n* ============================\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_SCOMPLEX)
- rb_a = na_change_type(rb_a, NA_SCOMPLEX);
- a = NA_PTR_TYPE(rb_a, complex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, complex*);
- MEMCPY(a_out__, a, complex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zpftrf_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zpftrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zpftrf", rb_zpftrf, -1);
-}
diff --git a/zpftri.c b/zpftri.c
deleted file mode 100644
index 627c3d5..0000000
--- a/zpftri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpftri_(char *transr, char *uplo, integer *n, doublecomplex *a, integer *info);
-
-static VALUE
-rb_zpftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zpftri( transr, uplo, n, a)\n or\n NumRu::Lapack.zpftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPFTRI( TRANSR, UPLO, N, A, INFO )\n\n* Purpose\n* =======\n*\n* ZPFTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by ZPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the Hermitian matrix A in RFP format. RFP format is\n* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A. If UPLO = 'L' the RFP A contains the elements\n* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n* is odd. See the Note below for more details.\n*\n* On exit, the Hermitian inverse of the original matrix, in the\n* same 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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
-
- transr = StringValueCStr(rb_transr)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zpftri_(&transr, &uplo, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zpftri(VALUE mLapack){
- rb_define_module_function(mLapack, "zpftri", rb_zpftri, -1);
-}
diff --git a/zpftrs.c b/zpftrs.c
deleted file mode 100644
index cfc014f..0000000
--- a/zpftrs.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpftrs_(char *transr, char *uplo, integer *n, integer *nrhs, doublecomplex *a, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zpftrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpftrs( transr, uplo, n, a, b)\n or\n NumRu::Lapack.zpftrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPFTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by ZPFTRF.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of RFP A is stored;\n* = 'L': Lower triangle of RFP A is stored.\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* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* The triangular factor U or L from the Cholesky factorization\n* of RFP A = U**H*U or RFP A = L*L**H, as computed by ZPFTRF.\n* See note below for more details about RFP A.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zpftrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zpftrs", rb_zpftrs, -1);
-}
diff --git a/zpocon.c b/zpocon.c
deleted file mode 100644
index 0f2e853..0000000
--- a/zpocon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpocon_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zpocon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zpocon( uplo, a, anorm)\n or\n NumRu::Lapack.zpocon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPOCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite matrix using the\n* Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zpocon(VALUE mLapack){
- rb_define_module_function(mLapack, "zpocon", rb_zpocon, -1);
-}
diff --git a/zpoequ.c b/zpoequ.c
deleted file mode 100644
index 618d155..0000000
--- a/zpoequ.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpoequ_(integer *n, doublecomplex *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_zpoequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zpoequ( a)\n or\n NumRu::Lapack.zpoequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPOEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N Hermitian positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- zpoequ_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_zpoequ(VALUE mLapack){
- rb_define_module_function(mLapack, "zpoequ", rb_zpoequ, -1);
-}
diff --git a/zpoequb.c b/zpoequb.c
deleted file mode 100644
index d13d605..0000000
--- a/zpoequb.c
+++ /dev/null
@@ -1,56 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpoequb_(integer *n, doublecomplex *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_zpoequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zpoequb( a)\n or\n NumRu::Lapack.zpoequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPOEQUB computes row and column scalings intended to equilibrate a\n* symmetric positive definite matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N symmetric positive definite matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- zpoequb_(&n, a, &lda, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_zpoequb(VALUE mLapack){
- rb_define_module_function(mLapack, "zpoequb", rb_zpoequb, -1);
-}
diff --git a/zporfs.c b/zporfs.c
deleted file mode 100644
index bbb34bb..0000000
--- a/zporfs.c
+++ /dev/null
@@ -1,122 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zporfs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zporfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zporfs( uplo, a, af, b, x)\n or\n NumRu::Lapack.zporfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPORFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite,\n* and provides error bounds and backward error estimates for the\n* solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPOTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zporfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zporfs", rb_zporfs, -1);
-}
diff --git a/zporfsx.c b/zporfsx.c
deleted file mode 100644
index 8d3c126..0000000
--- a/zporfsx.c
+++ /dev/null
@@ -1,187 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zporfsx_(char *uplo, char *equed, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zporfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zporfsx( uplo, equed, a, af, s, b, x, params)\n or\n NumRu::Lapack.zporfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPORFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric positive\n* definite, and provides error bounds and backward error estimates\n* for the solution. In addition to normwise error bound, the code\n* provides maximum componentwise error bound if possible. See\n* comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n* error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_s = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
- rb_params = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (5th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_zporfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "zporfsx", rb_zporfsx, -1);
-}
diff --git a/zposv.c b/zposv.c
deleted file mode 100644
index 0992c77..0000000
--- a/zposv.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zposv_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zposv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b = NumRu::Lapack.zposv( uplo, a, b)\n or\n NumRu::Lapack.zposv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPOSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPOTRF, ZPOTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zposv(VALUE mLapack){
- rb_define_module_function(mLapack, "zposv", rb_zposv, -1);
-}
diff --git a/zposvx.c b/zposvx.c
deleted file mode 100644
index 748cb16..0000000
--- a/zposvx.c
+++ /dev/null
@@ -1,178 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zposvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zposvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.zposvx( fact, uplo, a, af, equed, s, b)\n or\n NumRu::Lapack.zposvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. A and AF will not\n* be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the Hermitian matrix A, except if FACT = 'F' and\n* EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). 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. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored form\n* of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS righthand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_zposvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zposvx", rb_zposvx, -1);
-}
diff --git a/zposvxx.c b/zposvxx.c
deleted file mode 100644
index 97c0438..0000000
--- a/zposvxx.c
+++ /dev/null
@@ -1,216 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zposvxx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zposvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.zposvxx( fact, uplo, a, af, equed, s, b, params)\n or\n NumRu::Lapack.zposvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n* to compute the solution to a complex*16 system of linear equations\n* A * X = B, where A is an N-by-N symmetric positive definite matrix\n* and X and B are N-by-NRHS matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZPOSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZPOSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZPOSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZPOSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U**T* U, if UPLO = 'U', or\n* A = L * L**T, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A (see argument RCOND). If the reciprocal of the condition number\n* is less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF contains the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A and AF are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n* 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n* triangular part of A contains the upper triangular part of the\n* matrix A, and the strictly lower triangular part of A is not\n* referenced. If UPLO = 'L', the leading N-by-N lower triangular\n* part of A contains the lower triangular part of the matrix A, and\n* the strictly upper triangular part of A is not referenced. A is\n* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n* 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T, in the same storage\n* format as A. If EQUED .ne. 'N', then AF is the factored\n* form of the equilibrated matrix diag(S)*A*diag(S).\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the original\n* matrix A.\n*\n* If FACT = 'E', then AF is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**T*U or A = L*L**T of the equilibrated\n* matrix A (see the description of A for the form of the\n* equilibrated matrix).\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The row scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_params = argv[7];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (8th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- n_err_bnds = 3;
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(13, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_zposvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "zposvxx", rb_zposvxx, -1);
-}
diff --git a/zpotf2.c b/zpotf2.c
deleted file mode 100644
index d146099..0000000
--- a/zpotf2.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpotf2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_zpotf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zpotf2( uplo, a)\n or\n NumRu::Lapack.zpotf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTF2 computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U' * U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the upper or lower triangular part of the\n* Hermitian 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 Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U'*U or A = 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* > 0: if INFO = k, the leading minor of order k is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zpotf2_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zpotf2(VALUE mLapack){
- rb_define_module_function(mLapack, "zpotf2", rb_zpotf2, -1);
-}
diff --git a/zpotrf.c b/zpotrf.c
deleted file mode 100644
index 26e8869..0000000
--- a/zpotrf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpotrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_zpotrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zpotrf( uplo, a)\n or\n NumRu::Lapack.zpotrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n* This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 Hermitian 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 INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H.\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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zpotrf_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zpotrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zpotrf", rb_zpotrf, -1);
-}
diff --git a/zpotri.c b/zpotri.c
deleted file mode 100644
index 845b51b..0000000
--- a/zpotri.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpotri_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_zpotri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zpotri( uplo, a)\n or\n NumRu::Lapack.zpotri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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 triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, as computed by\n* ZPOTRF.\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or 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 = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLAUUM, ZTRTRI\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zpotri_(&uplo, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zpotri(VALUE mLapack){
- rb_define_module_function(mLapack, "zpotri", rb_zpotri, -1);
-}
diff --git a/zpotrs.c b/zpotrs.c
deleted file mode 100644
index 5db5c50..0000000
--- a/zpotrs.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpotrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zpotrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpotrs( uplo, a, b)\n or\n NumRu::Lapack.zpotrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPOTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A using the Cholesky factorization\n* A = U**H*U or A = L*L**H computed by ZPOTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zpotrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zpotrs", rb_zpotrs, -1);
-}
diff --git a/zppcon.c b/zppcon.c
deleted file mode 100644
index 164326a..0000000
--- a/zppcon.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zppcon_(char *uplo, integer *n, doublecomplex *ap, doublereal *anorm, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zppcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zppcon( uplo, ap, anorm)\n or\n NumRu::Lapack.zppcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite packed matrix using\n* the Cholesky factorization A = U**H*U or A = L*L**H computed by\n* ZPPTRF.\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* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zppcon_(&uplo, &n, ap, &anorm, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zppcon(VALUE mLapack){
- rb_define_module_function(mLapack, "zppcon", rb_zppcon, -1);
-}
diff --git a/zppequ.c b/zppequ.c
deleted file mode 100644
index 2955ec1..0000000
--- a/zppequ.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zppequ_(char *uplo, integer *n, doublecomplex *ap, doublereal *s, doublereal *scond, doublereal *amax, integer *info);
-
-static VALUE
-rb_zppequ(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zppequ( uplo, ap)\n or\n NumRu::Lapack.zppequ # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n* Purpose\n* =======\n*\n* ZPPEQU computes row and column scalings intended to equilibrate a\n* Hermitian positive definite matrix A in packed storage and reduce\n* its condition number (with respect to the two-norm). S contains the\n* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n* This choice of S puts the condition number of B within a factor N of\n* the smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\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, the i-th diagonal element is nonpositive.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
-
- zppequ_(&uplo, &n, ap, s, &scond, &amax, &info);
-
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_zppequ(VALUE mLapack){
- rb_define_module_function(mLapack, "zppequ", rb_zppequ, -1);
-}
diff --git a/zpprfs.c b/zpprfs.c
deleted file mode 100644
index 9072c1c..0000000
--- a/zpprfs.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpprfs_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *afp, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zpprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_afp;
- doublecomplex *afp;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zpprfs( uplo, ap, afp, b, x)\n or\n NumRu::Lapack.zpprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the Hermitian matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,\n* packed columnwise in a linear array in the same format as A\n* (see AP).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_b = argv[3];
- rb_x = argv[4];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_DCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zpprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zpprfs", rb_zpprfs, -1);
-}
diff --git a/zppsv.c b/zppsv.c
deleted file mode 100644
index badda5b..0000000
--- a/zppsv.c
+++ /dev/null
@@ -1,85 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zppsv_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zppsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap, b = NumRu::Lapack.zppsv( uplo, n, ap, b)\n or\n NumRu::Lapack.zppsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* The Cholesky decomposition is used to factor A as\n* A = U**H* U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is a lower triangular\n* matrix. The factored form of A is then used to solve the system of\n* equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i of A is not\n* positive definite, so the factorization could not be\n* completed, and the solution has not been computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPPTRF, ZPPTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_zppsv(VALUE mLapack){
- rb_define_module_function(mLapack, "zppsv", rb_zppsv, -1);
-}
diff --git a/zppsvx.c b/zppsvx.c
deleted file mode 100644
index b7234b7..0000000
--- a/zppsvx.c
+++ /dev/null
@@ -1,172 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zppsvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *afp, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zppsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_afp;
- doublecomplex *afp;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- VALUE rb_afp_out__;
- doublecomplex *afp_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.zppsvx( fact, uplo, ap, afp, equed, s, b)\n or\n NumRu::Lapack.zppsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n* compute the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N Hermitian positive definite matrix stored in\n* packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', real scaling factors are computed to equilibrate\n* the system:\n* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n* factor the matrix A (after equilibration if FACT = 'E') as\n* A = U'* U , if UPLO = 'U', or\n* A = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix, L is a lower triangular\n* matrix, and ' indicates conjugate transpose.\n*\n* 3. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(S) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AFP contains the factored form of A.\n* If EQUED = 'Y', the matrix A has been equilibrated\n* with scaling factors given by S. AP and AFP will not\n* be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array, except if FACT = 'F'\n* and EQUED = 'Y', then A must contain the equilibrated matrix\n* diag(S)*A*diag(S). The j-th column of A is stored in the\n* 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details. A is not modified if\n* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, in the same storage\n* format as A. If EQUED .ne. 'N', then AFP is the factored\n* form of the equilibrated matrix A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the original\n* matrix A.\n*\n* If FACT = 'E', then AFP is an output argument and on exit\n* returns the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H of the equilibrated\n* matrix A (see the description of AP for the form of the\n* equilibrated matrix).\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Equilibration was done, i.e., A has been replaced by\n* diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A; not accessed if EQUED = 'N'. S is\n* an input argument if FACT = 'F'; otherwise, S is an output\n* argument. If FACT = 'F' and EQUED = 'Y', each element of S\n* must be positive.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n* B is overwritten by diag(S) * B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n* the original system of equations. Note that if EQUED = 'Y',\n* A and B are modified on exit, and the solution to the\n* equilibrated system is inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A after equilibration (if done). If RCOND is less than the\n* machine precision (in particular, if RCOND = 0), the matrix\n* is singular to working precision. This condition is\n* indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_equed = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- equed = StringValueCStr(rb_equed)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- n = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_DCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, doublecomplex*);
- MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(10, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_ap, rb_afp, rb_equed, rb_s, rb_b);
-}
-
-void
-init_lapack_zppsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zppsvx", rb_zppsvx, -1);
-}
diff --git a/zpptrf.c b/zpptrf.c
deleted file mode 100644
index a5e5574..0000000
--- a/zpptrf.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpptrf_(char *uplo, integer *n, doublecomplex *ap, integer *info);
-
-static VALUE
-rb_zpptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zpptrf( uplo, n, ap)\n or\n NumRu::Lapack.zpptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZPPTRF computes the Cholesky factorization of a complex Hermitian\n* positive definite matrix A stored in packed format.\n*\n* The factorization has the form\n* A = U**H * U, if UPLO = 'U', or\n* A = L * L**H, if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the Hermitian matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, if INFO = 0, the triangular factor U or L from the\n* Cholesky factorization A = U**H*U or A = L*L**H, in the same\n* storage format as A.\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, the leading minor of order i is not\n* positive definite, and the factorization could not be\n* completed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the Hermitian matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = conjg(aji))\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zpptrf_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_zpptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zpptrf", rb_zpptrf, -1);
-}
diff --git a/zpptri.c b/zpptri.c
deleted file mode 100644
index 2f13ef9..0000000
--- a/zpptri.c
+++ /dev/null
@@ -1,59 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpptri_(char *uplo, integer *n, doublecomplex *ap, integer *info);
-
-static VALUE
-rb_zpptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zpptri( uplo, n, ap)\n or\n NumRu::Lapack.zpptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPTRI( UPLO, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZPPTRI computes the inverse of a complex Hermitian positive definite\n* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n* computed by ZPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular factor is stored in AP;\n* = 'L': Lower triangular factor is stored in AP.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the triangular factor U or L from the Cholesky\n* factorization A = U**H*U or A = L*L**H, packed columnwise as\n* a linear array. The j-th column of U or L is stored in the\n* array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* On exit, the upper or lower triangle of the (Hermitian)\n* inverse of A, overwriting the input factor U or L.\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, the (i,i) element of the factor U or L is\n* zero, and the inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
-
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zpptri_(&uplo, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_zpptri(VALUE mLapack){
- rb_define_module_function(mLapack, "zpptri", rb_zpptri, -1);
-}
diff --git a/zpptrs.c b/zpptrs.c
deleted file mode 100644
index ce96734..0000000
--- a/zpptrs.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpptrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zpptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpptrs( uplo, n, ap, b)\n or\n NumRu::Lapack.zpptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPPTRS solves a system of linear equations A*X = B with a Hermitian\n* positive definite matrix A in packed storage using the Cholesky\n* factorization A = U**H*U or A = L*L**H computed by ZPPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The triangular factor U or L from the Cholesky factorization\n* A = U**H*U or A = L*L**H, packed columnwise in a linear\n* array. The j-th column of U or L is stored in the array AP\n* as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZTPSV\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_ap = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zpptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zpptrs", rb_zpptrs, -1);
-}
diff --git a/zpstf2.c b/zpstf2.c
deleted file mode 100644
index 871b16e..0000000
--- a/zpstf2.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpstf2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, integer *info);
-
-static VALUE
-rb_zpstf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.zpstf2( uplo, a, tol)\n or\n NumRu::Lapack.zpstf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPSTF2 computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 2 BLAS.\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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- tol = NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- zpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_zpstf2(VALUE mLapack){
- rb_define_module_function(mLapack, "zpstf2", rb_zpstf2, -1);
-}
diff --git a/zpstrf.c b/zpstrf.c
deleted file mode 100644
index 713de6b..0000000
--- a/zpstrf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpstrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *piv, integer *rank, doublereal *tol, doublereal *work, integer *info);
-
-static VALUE
-rb_zpstrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tol;
- doublereal tol;
- VALUE rb_piv;
- integer *piv;
- VALUE rb_rank;
- integer rank;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublereal *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n piv, rank, info, a = NumRu::Lapack.zpstrf( uplo, a, tol)\n or\n NumRu::Lapack.zpstrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPSTRF computes the Cholesky factorization with complete\n* pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n* The factorization has the form\n* P' * A * P = U' * U , if UPLO = 'U',\n* P' * A * P = L * L', if UPLO = 'L',\n* where U is an upper triangular matrix and L is lower triangular, and\n* P is stored as vector PIV.\n*\n* This algorithm does not attempt to check that A is positive\n* semidefinite. This version of the algorithm calls level 3 BLAS.\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 INFO = 0, the factor U or L from the Cholesky\n* factorization as above.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* PIV (output) INTEGER array, dimension (N)\n* PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n* RANK (output) INTEGER\n* The rank of A given by the number of steps the algorithm\n* completed.\n*\n* TOL (input) DOUBLE PRECISION\n* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n* will be used. The algorithm terminates at the (K-1)st step\n* if the pivot <= TOL.\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n* Work space.\n*\n* INFO (output) INTEGER\n* < 0: If INFO = -K, the K-th argument had an illegal value,\n* = 0: algorithm completed successfully, and\n* > 0: the matrix A is either rank deficient with computed rank\n* as returned in RANK, or is indefinite. See Section 7 of\n* LAPACK Working Note #161 for further information.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tol = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- tol = NUM2DBL(rb_tol);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_piv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- piv = NA_PTR_TYPE(rb_piv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublereal, (2*n));
-
- zpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);
-
- free(work);
- rb_rank = INT2NUM(rank);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_piv, rb_rank, rb_info, rb_a);
-}
-
-void
-init_lapack_zpstrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zpstrf", rb_zpstrf, -1);
-}
diff --git a/zptcon.c b/zptcon.c
deleted file mode 100644
index bac6e7e..0000000
--- a/zptcon.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zptcon_(integer *n, doublereal *d, doublecomplex *e, doublereal *anorm, doublereal *rcond, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zptcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublereal *rwork;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zptcon( d, e, anorm)\n or\n NumRu::Lapack.zptcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTCON computes the reciprocal of the condition number (in the\n* 1-norm) of a complex Hermitian positive definite tridiagonal matrix\n* using the factorization A = L*D*L**H or A = U**H*D*U computed by\n* ZPTTRF.\n*\n* Norm(inv(A)) is computed by a direct method, and the reciprocal of\n* the condition number is computed as\n* RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization of A, as computed by ZPTTRF.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal factor\n* U or L from the factorization of A, as computed by ZPTTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal of the condition number of the matrix A,\n* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n* 1-norm of inv(A) computed in this routine.\n*\n* RWORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The method used is described in Nicholas J. Higham, \"Efficient\n* Algorithms for Computing the Condition Number of a Tridiagonal\n* Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_anorm = argv[2];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- rwork = ALLOC_N(doublereal, (n));
-
- zptcon_(&n, d, e, &anorm, &rcond, rwork, &info);
-
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zptcon(VALUE mLapack){
- rb_define_module_function(mLapack, "zptcon", rb_zptcon, -1);
-}
diff --git a/zpteqr.c b/zpteqr.c
deleted file mode 100644
index 04487b6..0000000
--- a/zpteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpteqr_(char *compz, integer *n, doublereal *d, doublereal *e, doublecomplex *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_zpteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
- doublereal *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.zpteqr( compz, d, e, z)\n or\n NumRu::Lapack.zpteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric positive definite tridiagonal matrix by first factoring the\n* matrix using DPTTRF and then calling ZBDSQR to compute the singular\n* values of the bidiagonal factor.\n*\n* This routine computes the eigenvalues of the positive definite\n* tridiagonal matrix to high relative accuracy. This means that if the\n* eigenvalues range over many orders of magnitude in size, then the\n* small eigenvalues and corresponding eigenvectors will be computed\n* more accurately than, for example, with the standard QR method.\n*\n* The eigenvectors of a full or band positive definite Hermitian matrix\n* can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to\n* reduce this matrix to tridiagonal form. (The reduction to\n* tridiagonal form, however, may preclude the possibility of obtaining\n* high relative accuracy in the small eigenvalues of the original\n* matrix, if these eigenvalues range over many orders of magnitude.)\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvectors of original Hermitian\n* matrix also. Array Z contains the unitary matrix\n* used to reduce the original matrix to tridiagonal\n* form.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix.\n* On normal exit, D contains the eigenvalues, in descending\n* order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', the unitary matrix used in the\n* reduction to tridiagonal form.\n* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n* original Hermitian matrix;\n* if COMPZ = 'I', the orthonormal eigenvectors of the\n* tridiagonal matrix.\n* If INFO > 0 on exit, Z contains the eigenvectors associated\n* with only the stored eigenvalues.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: if INFO = i, and i is:\n* <= N the Cholesky factorization of the matrix could\n* not be performed because the i-th principal minor\n* was not positive definite.\n* > N the SVD algorithm failed to converge;\n* if INFO = N+i, i off-diagonal elements of the\n* bidiagonal factor did not converge to zero.\n*\n\n* ====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(doublereal, (4*n));
-
- zpteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_zpteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "zpteqr", rb_zpteqr, -1);
-}
diff --git a/zptrfs.c b/zptrfs.c
deleted file mode 100644
index 501b900..0000000
--- a/zptrfs.c
+++ /dev/null
@@ -1,142 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zptrfs_(char *uplo, integer *n, integer *nrhs, doublereal *d, doublecomplex *e, doublereal *df, doublecomplex *ef, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zptrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_df;
- doublereal *df;
- VALUE rb_ef;
- doublecomplex *ef;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zptrfs( uplo, d, e, df, ef, b, x)\n or\n NumRu::Lapack.zptrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is Hermitian positive definite\n* and tridiagonal, and provides error bounds and backward error\n* estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the superdiagonal or the subdiagonal of the\n* tridiagonal matrix A is stored and the form of the\n* factorization:\n* = 'U': E is the superdiagonal of A, and A = U**H*D*U;\n* = 'L': E is the subdiagonal of A, and A = L*D*L**H.\n* (The two forms are equivalent if A is real.)\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n real diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) off-diagonal elements of the tridiagonal matrix A\n* (see UPLO).\n*\n* DF (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from\n* the factorization computed by ZPTTRF.\n*\n* EF (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) off-diagonal elements of the unit bidiagonal\n* factor U or L from the factorization computed by ZPTTRF\n* (see UPLO).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZPTTRS.\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) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_df = argv[3];
- rb_ef = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (4th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_df) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
- if (NA_TYPE(rb_df) != NA_DFLOAT)
- rb_df = na_change_type(rb_df, NA_DFLOAT);
- df = NA_PTR_TYPE(rb_df, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_DCOMPLEX)
- rb_ef = na_change_type(rb_ef, NA_DCOMPLEX);
- ef = NA_PTR_TYPE(rb_ef, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (n));
-
- zptrfs_(&uplo, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zptrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zptrfs", rb_zptrfs, -1);
-}
diff --git a/zptsv.c b/zptsv.c
deleted file mode 100644
index 7dc32ad..0000000
--- a/zptsv.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zptsv_(integer *n, integer *nrhs, doublereal *d, doublecomplex *e, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zptsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_nrhs;
- integer nrhs;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublecomplex *e_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, b = NumRu::Lapack.zptsv( nrhs, d, e, b)\n or\n NumRu::Lapack.zptsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPTSV computes the solution to a complex system of linear equations\n* A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n* matrix, and X and B are N-by-NRHS matrices.\n*\n* A is factored as A = L*D*L**H, and the factored form of A is then\n* used to solve the system of equations.\n*\n\n* Arguments\n* =========\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* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the factorization A = L*D*L**H.\n*\n* E (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L**H factorization of\n* A. E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U**H*D*U factorization of A.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the leading minor of order i is not\n* positive definite, and the solution has not been\n* computed. The factorization has not been completed\n* unless i = N.\n*\n\n* =====================================================================\n*\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPTTRF, ZPTTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_nrhs = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of b");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- nrhs = NUM2INT(rb_nrhs);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublecomplex*);
- MEMCPY(e_out__, e, doublecomplex, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zptsv_(&n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_b);
-}
-
-void
-init_lapack_zptsv(VALUE mLapack){
- rb_define_module_function(mLapack, "zptsv", rb_zptsv, -1);
-}
diff --git a/zptsvx.c b/zptsvx.c
deleted file mode 100644
index 9e9b325..0000000
--- a/zptsvx.c
+++ /dev/null
@@ -1,152 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zptsvx_(char *fact, integer *n, integer *nrhs, doublereal *d, doublecomplex *e, doublereal *df, doublecomplex *ef, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zptsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_df;
- doublereal *df;
- VALUE rb_ef;
- doublecomplex *ef;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_df_out__;
- doublereal *df_out__;
- VALUE rb_ef_out__;
- doublecomplex *ef_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.zptsvx( fact, d, e, df, ef, b)\n or\n NumRu::Lapack.zptsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZPTSVX uses the factorization A = L*D*L**H to compute the solution\n* to a complex system of linear equations A*X = B, where A is an\n* N-by-N Hermitian positive definite tridiagonal matrix and X and B\n* are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n* is a unit lower bidiagonal matrix and D is diagonal. The\n* factorization can also be regarded as having the form\n* A = U**H*D*U.\n*\n* 2. If the leading i-by-i principal minor is not positive definite,\n* then the routine returns with INFO = i. Otherwise, the factored\n* form of A is used to estimate the condition number of the matrix\n* A. If the reciprocal of the condition number is less than machine\n* precision, INFO = N+1 is returned as a warning, but the routine\n* still goes on to solve for X and compute error bounds as\n* described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix\n* A is supplied on entry.\n* = 'F': On entry, DF and EF contain the factored form of A.\n* D, E, DF, and EF will not be modified.\n* = 'N': The matrix A will be copied to DF and EF and\n* factored.\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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix A.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n* DF (input or output) DOUBLE PRECISION array, dimension (N)\n* If FACT = 'F', then DF is an input argument and on entry\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n* If FACT = 'N', then DF is an output argument and on exit\n* contains the n diagonal elements of the diagonal matrix D\n* from the L*D*L**H factorization of A.\n*\n* EF (input or output) COMPLEX*16 array, dimension (N-1)\n* If FACT = 'F', then EF is an input argument and on entry\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n* If FACT = 'N', then EF is an output argument and on exit\n* contains the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the L*D*L**H factorization of A.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The reciprocal condition number of the matrix A. If RCOND\n* is less than the machine precision (in particular, if\n* RCOND = 0), the matrix is singular to working precision.\n* This condition is indicated by a return code of INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The 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).\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* The componentwise relative backward error of each solution\n* vector X(j) (i.e., the smallest relative change in any\n* element of A or B that makes X(j) an exact solution).\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: the leading minor of order i of A is\n* not positive definite, so the factorization\n* could not be completed, and the solution has not\n* been computed. RCOND = 0 is returned.\n* = N+1: U is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_df = argv[3];
- rb_ef = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_df))
- rb_raise(rb_eArgError, "df (4th argument) must be NArray");
- if (NA_RANK(rb_df) != 1)
- rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_df);
- if (NA_TYPE(rb_df) != NA_DFLOAT)
- rb_df = na_change_type(rb_df, NA_DFLOAT);
- df = NA_PTR_TYPE(rb_df, doublereal*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- if (!NA_IsNArray(rb_ef))
- rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
- if (NA_RANK(rb_ef) != 1)
- rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ef) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
- if (NA_TYPE(rb_ef) != NA_DCOMPLEX)
- rb_ef = na_change_type(rb_ef, NA_DCOMPLEX);
- ef = NA_PTR_TYPE(rb_ef, doublecomplex*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- df_out__ = NA_PTR_TYPE(rb_df_out__, doublereal*);
- MEMCPY(df_out__, df, doublereal, NA_TOTAL(rb_df));
- rb_df = rb_df_out__;
- df = df_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_ef_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ef_out__ = NA_PTR_TYPE(rb_ef_out__, doublecomplex*);
- MEMCPY(ef_out__, ef, doublecomplex, NA_TOTAL(rb_ef));
- rb_ef = rb_ef_out__;
- ef = ef_out__;
- work = ALLOC_N(doublecomplex, (n));
- rwork = ALLOC_N(doublereal, (n));
-
- zptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_df, rb_ef);
-}
-
-void
-init_lapack_zptsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zptsvx", rb_zptsvx, -1);
-}
diff --git a/zpttrf.c b/zpttrf.c
deleted file mode 100644
index 355e0d9..0000000
--- a/zpttrf.c
+++ /dev/null
@@ -1,74 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpttrf_(integer *n, doublereal *d, doublecomplex *e, integer *info);
-
-static VALUE
-rb_zpttrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublecomplex *e_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e = NumRu::Lapack.zpttrf( d, e)\n or\n NumRu::Lapack.zpttrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTTRF( N, D, E, INFO )\n\n* Purpose\n* =======\n*\n* ZPTTRF computes the L*D*L' factorization of a complex Hermitian\n* positive definite tridiagonal matrix A. The factorization may also\n* be regarded as having the form A = U'*D*U.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the n diagonal elements of the tridiagonal matrix\n* A. On exit, the n diagonal elements of the diagonal matrix\n* D from the L*D*L' factorization of A.\n*\n* E (input/output) COMPLEX*16 array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix A. On exit, the (n-1) subdiagonal elements of the\n* unit bidiagonal factor L from the L*D*L' factorization of A.\n* E can also be regarded as the superdiagonal of the unit\n* bidiagonal factor U from the U'*D*U factorization of A.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, the leading minor of order k is not\n* positive definite; if k < N, the factorization could not\n* be completed, while if k = N, the factorization was\n* completed, but D(N) <= 0.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
-
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublecomplex*);
- MEMCPY(e_out__, e, doublecomplex, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- zpttrf_(&n, d, e, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_zpttrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zpttrf", rb_zpttrf, -1);
-}
diff --git a/zpttrs.c b/zpttrs.c
deleted file mode 100644
index 821f686..0000000
--- a/zpttrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zpttrs_(char *uplo, integer *n, integer *nrhs, doublereal *d, doublecomplex *e, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zpttrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zpttrs( uplo, d, e, b)\n or\n NumRu::Lapack.zpttrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZPTTRS solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 'U': A = U'*D*U, E is the superdiagonal of U\n* = 'L': A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= 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* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER IUPLO, J, JB, NB\n* ..\n* .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZPTTS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zpttrs_(&uplo, &n, &nrhs, d, e, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zpttrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zpttrs", rb_zpttrs, -1);
-}
diff --git a/zptts2.c b/zptts2.c
deleted file mode 100644
index 97aa8fd..0000000
--- a/zptts2.c
+++ /dev/null
@@ -1,79 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zptts2_(integer *iuplo, integer *n, integer *nrhs, doublereal *d, doublecomplex *e, doublecomplex *b, integer *ldb);
-
-static VALUE
-rb_zptts2(int argc, VALUE *argv, VALUE self){
- VALUE rb_iuplo;
- integer iuplo;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.zptts2( iuplo, d, e, b)\n or\n NumRu::Lapack.zptts2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n* Purpose\n* =======\n*\n* ZPTTS2 solves a tridiagonal system of the form\n* A * X = B\n* using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n* D is a diagonal matrix specified in the vector D, U (or L) is a unit\n* bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n* the vector E, and X and B are N by NRHS matrices.\n*\n\n* Arguments\n* =========\n*\n* IUPLO (input) INTEGER\n* Specifies the form of the factorization and whether the\n* vector E is the superdiagonal of the upper bidiagonal factor\n* U or the subdiagonal of the lower bidiagonal factor L.\n* = 1: A = U'*D*U, E is the superdiagonal of U\n* = 0: A = L*D*L', E is the subdiagonal of L\n*\n* N (input) INTEGER\n* The order of the tridiagonal 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* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the diagonal matrix D from the\n* factorization A = U'*D*U or A = L*D*L'.\n*\n* E (input) COMPLEX*16 array, dimension (N-1)\n* If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n* bidiagonal factor U from the factorization A = U'*D*U.\n* If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n* bidiagonal factor L from the factorization A = L*D*L'.\n*\n* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n* On entry, the right hand side vectors B for the system of\n* linear equations.\n* On exit, the solution vectors, X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, J\n* ..\n* .. External Subroutines ..\n EXTERNAL ZDSCAL\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_iuplo = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- iuplo = NUM2INT(rb_iuplo);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zptts2_(&iuplo, &n, &nrhs, d, e, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_zptts2(VALUE mLapack){
- rb_define_module_function(mLapack, "zptts2", rb_zptts2, -1);
-}
diff --git a/zrot.c b/zrot.c
deleted file mode 100644
index d106579..0000000
--- a/zrot.c
+++ /dev/null
@@ -1,88 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zrot_(integer *n, doublecomplex *cx, integer *incx, doublecomplex *cy, integer *incy, doublereal *c, doublecomplex *s);
-
-static VALUE
-rb_zrot(int argc, VALUE *argv, VALUE self){
- VALUE rb_cx;
- doublecomplex *cx;
- VALUE rb_incx;
- integer incx;
- VALUE rb_cy;
- doublecomplex *cy;
- VALUE rb_incy;
- integer incy;
- VALUE rb_c;
- doublereal c;
- VALUE rb_s;
- doublecomplex s;
- VALUE rb_cx_out__;
- doublecomplex *cx_out__;
- VALUE rb_cy_out__;
- doublecomplex *cy_out__;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n cx, cy = NumRu::Lapack.zrot( cx, incx, cy, incy, c, s)\n or\n NumRu::Lapack.zrot # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )\n\n* Purpose\n* =======\n*\n* ZROT applies a plane rotation, where the cos (C) is real and the\n* sin (S) is complex, and the vectors CX and CY are complex.\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The number of elements in the vectors CX and CY.\n*\n* CX (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector X.\n* On output, CX is overwritten with C*X + S*Y.\n*\n* INCX (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* CY (input/output) COMPLEX*16 array, dimension (N)\n* On input, the vector Y.\n* On output, CY is overwritten with -CONJG(S)*X + C*Y.\n*\n* INCY (input) INTEGER\n* The increment between successive values of CY. INCX <> 0.\n*\n* C (input) DOUBLE PRECISION\n* S (input) COMPLEX*16\n* C and S define a rotation\n* [ C S ]\n* [ -conjg(S) C ]\n* where C*C + S*CONJG(S) = 1.0.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX*16 STEMP\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_cx = argv[0];
- rb_incx = argv[1];
- rb_cy = argv[2];
- rb_incy = argv[3];
- rb_c = argv[4];
- rb_s = argv[5];
-
- if (!NA_IsNArray(rb_cy))
- rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
- if (NA_RANK(rb_cy) != 1)
- rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_cy);
- if (NA_TYPE(rb_cy) != NA_DCOMPLEX)
- rb_cy = na_change_type(rb_cy, NA_DCOMPLEX);
- cy = NA_PTR_TYPE(rb_cy, doublecomplex*);
- c = NUM2DBL(rb_c);
- incx = NUM2INT(rb_incx);
- incy = NUM2INT(rb_incy);
- s.r = NUM2DBL(rb_funcall(rb_s, rb_intern("real"), 0));
- s.i = NUM2DBL(rb_funcall(rb_s, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_cx))
- rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
- if (NA_RANK(rb_cx) != 1)
- rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_cx) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of cx must be the same as shape 0 of cy");
- if (NA_TYPE(rb_cx) != NA_DCOMPLEX)
- rb_cx = na_change_type(rb_cx, NA_DCOMPLEX);
- cx = NA_PTR_TYPE(rb_cx, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_cx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- cx_out__ = NA_PTR_TYPE(rb_cx_out__, doublecomplex*);
- MEMCPY(cx_out__, cx, doublecomplex, NA_TOTAL(rb_cx));
- rb_cx = rb_cx_out__;
- cx = cx_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_cy_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- cy_out__ = NA_PTR_TYPE(rb_cy_out__, doublecomplex*);
- MEMCPY(cy_out__, cy, doublecomplex, NA_TOTAL(rb_cy));
- rb_cy = rb_cy_out__;
- cy = cy_out__;
-
- zrot_(&n, cx, &incx, cy, &incy, &c, &s);
-
- return rb_ary_new3(2, rb_cx, rb_cy);
-}
-
-void
-init_lapack_zrot(VALUE mLapack){
- rb_define_module_function(mLapack, "zrot", rb_zrot, -1);
-}
diff --git a/zspcon.c b/zspcon.c
deleted file mode 100644
index 7ce4cc6..0000000
--- a/zspcon.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zspcon_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zspcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zspcon( uplo, ap, ipiv, anorm)\n or\n NumRu::Lapack.zspcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric packed matrix A using the\n* factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- work = ALLOC_N(doublecomplex, (2*n));
-
- zspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zspcon(VALUE mLapack){
- rb_define_module_function(mLapack, "zspcon", rb_zspcon, -1);
-}
diff --git a/zspmv.c b/zspmv.c
deleted file mode 100644
index 321254a..0000000
--- a/zspmv.c
+++ /dev/null
@@ -1,98 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zspmv_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *ap, doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *incy);
-
-static VALUE
-rb_zspmv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublecomplex beta;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy)\n or\n NumRu::Lapack.zspmv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZSPMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* AP (input) COMPLEX*16 array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on.\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX*16\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_alpha = argv[2];
- rb_ap = argv[3];
- rb_x = argv[4];
- rb_incx = argv[5];
- rb_beta = argv[6];
- rb_y = argv[7];
- rb_incy = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- n = NUM2INT(rb_n);
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- beta.r = NUM2DBL(rb_funcall(rb_beta, rb_intern("real"), 0));
- beta.i = NUM2DBL(rb_funcall(rb_beta, rb_intern("imag"), 0));
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*( n + 1 ) )/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*( n + 1 ) )/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (8th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (5th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zspmv_(&uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_zspmv(VALUE mLapack){
- rb_define_module_function(mLapack, "zspmv", rb_zspmv, -1);
-}
diff --git a/zspr.c b/zspr.c
deleted file mode 100644
index b0d0bfb..0000000
--- a/zspr.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zspr_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *ap);
-
-static VALUE
-rb_zspr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap = NumRu::Lapack.zspr( uplo, n, alpha, x, incx, ap)\n or\n NumRu::Lapack.zspr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n* Purpose\n* =======\n*\n* ZSPR performs the symmetric rank 1 operation\n*\n* A := alpha*x*conjg( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix, supplied in packed form.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the matrix A is supplied in the packed\n* array AP as follows:\n*\n* UPLO = 'U' or 'u' The upper triangular part of A is\n* supplied in AP.\n*\n* UPLO = 'L' or 'l' The lower triangular part of A is\n* supplied in AP.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* AP (input/output) COMPLEX*16 array, dimension at least\n* ( ( N*( N + 1 ) )/2 ).\n* Before entry, with UPLO = 'U' or 'u', the array AP must\n* contain the upper triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n* and a( 2, 2 ) respectively, and so on. On exit, the array\n* AP is overwritten by the upper triangular part of the\n* updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the array AP must\n* contain the lower triangular part of the symmetric matrix\n* packed sequentially, column by column, so that AP( 1 )\n* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n* and a( 3, 1 ) respectively, and so on. On exit, the array\n* AP is overwritten by the lower triangular part of the\n* updated matrix.\n* Note that the imaginary parts of the diagonal elements need\n* not be set, they are assumed to be zero, and on exit they\n* are set to zero.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_n = argv[1];
- rb_alpha = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_ap = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (6th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*( n + 1 ) )/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*( n + 1 ) )/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = ( n*( n + 1 ) )/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zspr_(&uplo, &n, &alpha, x, &incx, ap);
-
- return rb_ap;
-}
-
-void
-init_lapack_zspr(VALUE mLapack){
- rb_define_module_function(mLapack, "zspr", rb_zspr, -1);
-}
diff --git a/zsprfs.c b/zsprfs.c
deleted file mode 100644
index b282e2d..0000000
--- a/zsprfs.c
+++ /dev/null
@@ -1,130 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsprfs_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zsprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_afp;
- doublecomplex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zsprfs( uplo, ap, afp, ipiv, b, x)\n or\n NumRu::Lapack.zsprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite\n* and packed, and provides error bounds and backward error estimates\n* for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The factored form of the matrix A. AFP contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by ZSPTRF, stored as a packed\n* triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZSPTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_afp = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_DCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zsprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zsprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zsprfs", rb_zsprfs, -1);
-}
diff --git a/zspsv.c b/zspsv.c
deleted file mode 100644
index 57ddd14..0000000
--- a/zspsv.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zspsv_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zspsv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldb;
- integer nrhs;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap, b = NumRu::Lapack.zspsv( uplo, ap, b)\n or\n NumRu::Lapack.zspsv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZSPSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix stored in packed format and X\n* and B are N-by-NRHS matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, D is symmetric and block diagonal with 1-by-1\n* and 2-by-2 diagonal blocks. The factored form of A is then used to\n* solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n* See below for further details.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZSPTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be\n* computed.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZSPTRF, ZSPTRS\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_b = argv[2];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_info, rb_ap, rb_b);
-}
-
-void
-init_lapack_zspsv(VALUE mLapack){
- rb_define_module_function(mLapack, "zspsv", rb_zspsv, -1);
-}
diff --git a/zspsvx.c b/zspsvx.c
deleted file mode 100644
index ef68dca..0000000
--- a/zspsvx.c
+++ /dev/null
@@ -1,144 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zspsvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zspsvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_afp;
- doublecomplex *afp;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_afp_out__;
- doublecomplex *afp_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zspsvx( fact, uplo, ap, afp, ipiv, b)\n or\n NumRu::Lapack.zspsvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n* A = L*D*L**T to compute the solution to a complex system of linear\n* equations A * X = B, where A is an N-by-N symmetric matrix stored\n* in packed format and X and B are N-by-NRHS matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AFP and IPIV contain the factored form\n* of A. AP, AFP and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AFP and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The upper or lower triangle of the symmetric matrix A, packed\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*\n* AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* If FACT = 'F', then AFP is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* If FACT = 'N', then AFP is an output argument and on exit\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n* a packed triangular matrix in the same storage format as A.\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSPTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSPTRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* Further Details\n* ===============\n*\n* The packed storage scheme is illustrated by the following example\n* when N = 4, UPLO = 'U':\n*\n* Two-dimensional storage of the symmetric matrix A:\n*\n* a11 a12 a13 a14\n* a22 a23 a24\n* a33 a34 (aij = aji)\n* a44\n*\n* Packed storage of the upper triangle of A:\n*\n* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_ap = argv[2];
- rb_afp = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- fact = StringValueCStr(rb_fact)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_afp))
- rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
- if (NA_RANK(rb_afp) != 1)
- rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_afp) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_afp) != NA_DCOMPLEX)
- rb_afp = na_change_type(rb_afp, NA_DCOMPLEX);
- afp = NA_PTR_TYPE(rb_afp, doublecomplex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- afp_out__ = NA_PTR_TYPE(rb_afp_out__, doublecomplex*);
- MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rb_afp));
- rb_afp = rb_afp_out__;
- afp = afp_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_x, rb_rcond, rb_ferr, rb_berr, rb_info, rb_afp, rb_ipiv);
-}
-
-void
-init_lapack_zspsvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zspsvx", rb_zspsvx, -1);
-}
diff --git a/zsptrf.c b/zsptrf.c
deleted file mode 100644
index c46129e..0000000
--- a/zsptrf.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsptrf_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, integer *info);
-
-static VALUE
-rb_zsptrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, ap = NumRu::Lapack.zsptrf( uplo, ap)\n or\n NumRu::Lapack.zsptrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZSPTRF computes the factorization of a complex symmetric matrix A\n* stored in packed format using the Bunch-Kaufman diagonal pivoting\n* method:\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the upper or lower triangle of the symmetric matrix\n* A, packed columnwise in a linear array. The j-th column of A\n* is stored 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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* On exit, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L, stored as a packed triangular\n* matrix overwriting A (see below for further details).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = ldap;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- zsptrf_(&uplo, &n, ap, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_ap);
-}
-
-void
-init_lapack_zsptrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zsptrf", rb_zsptrf, -1);
-}
diff --git a/zsptri.c b/zsptri.c
deleted file mode 100644
index 07bd092..0000000
--- a/zsptri.c
+++ /dev/null
@@ -1,70 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsptri_(char *uplo, integer *n, doublecomplex *ap, integer *ipiv, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zsptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
- doublecomplex *work;
-
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.zsptri( uplo, ap, ipiv)\n or\n NumRu::Lapack.zsptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSPTRI computes the inverse of a complex symmetric indefinite matrix\n* A in packed storage using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n* On entry, the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSPTRF,\n* stored as a packed triangular matrix.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix, stored as a packed triangular matrix. The j-th column\n* of inv(A) is stored in the array AP as follows:\n* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n* if UPLO = 'L',\n* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* WORK (workspace) COMPLEX*16 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zsptri_(&uplo, &n, ap, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_zsptri(VALUE mLapack){
- rb_define_module_function(mLapack, "zsptri", rb_zsptri, -1);
-}
diff --git a/zsptrs.c b/zsptrs.c
deleted file mode 100644
index 4bbbc59..0000000
--- a/zsptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsptrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zsptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zsptrs( uplo, ap, ipiv, b)\n or\n NumRu::Lapack.zsptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZSPTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A stored in packed format using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSPTRF, stored as a\n* packed triangular matrix.\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSPTRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zsptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zsptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zsptrs", rb_zsptrs, -1);
-}
diff --git a/zstedc.c b/zstedc.c
deleted file mode 100644
index 2be7180..0000000
--- a/zstedc.c
+++ /dev/null
@@ -1,140 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zstedc_(char *compz, integer *n, doublereal *d, doublereal *e, doublecomplex *z, integer *ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zstedc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_rwork;
- doublereal *rwork;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, rwork, iwork, info, d, e, z = NumRu::Lapack.zstedc( compz, d, e, z, lwork, lrwork, liwork)\n or\n NumRu::Lapack.zstedc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the divide and conquer method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n* This code makes very mild assumptions about floating point\n* arithmetic. It will work on machines with a guard digit in\n* add/subtract, or on those binary machines without guard digits\n* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n* It could conceivably fail on hexadecimal or decimal machines\n* without guard digits, but we know of none. See DLAED3 for details.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'I': Compute eigenvectors of tridiagonal matrix also.\n* = 'V': Compute eigenvectors of original Hermitian matrix\n* also. On entry, Z contains the unitary matrix used\n* to reduce the original matrix to tridiagonal form.\n*\n* N (input) INTEGER\n* The dimension of the symmetric tridiagonal matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the subdiagonal elements of the tridiagonal matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n* Note that for COMPZ = 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LWORK need\n* only be 1.\n*\n* If LWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal sizes of the WORK, RWORK and\n* IWORK arrays, returns these values as the first entries of\n* the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* RWORK (workspace/output) DOUBLE PRECISION array,\n* dimension (LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n* If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n* If COMPZ = 'V' and N > 1, LRWORK must be at least\n* 1 + 3*N + 2*N*lg N + 3*N**2 ,\n* where lg( N ) = smallest integer k such\n* that 2**k >= N.\n* If COMPZ = 'I' and N > 1, LRWORK must be at least\n* 1 + 4*N + 2*N**2 .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LRWORK\n* need only be max(1,2*(N-1)).\n*\n* If LRWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK.\n* If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n* If COMPZ = 'V' or N > 1, LIWORK must be at least\n* 6 + 6*N + 5*N*lg N.\n* If COMPZ = 'I' or N > 1, LIWORK must be at least\n* 3 + 5*N .\n* Note that for COMPZ = 'I' or 'V', then if N is less than or\n* equal to the minimum divide size, usually 25, then LIWORK\n* need only be 1.\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal sizes of the WORK, RWORK\n* and IWORK arrays, returns these values as the first entries\n* of the WORK, RWORK and IWORK arrays, and no error message\n* related to LWORK or LRWORK or LIWORK 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* > 0: The algorithm failed to compute an eigenvalue while\n* working on the submatrix lying in rows and columns\n* INFO/(N+1) through mod(INFO,N+1).\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Jeff Rutter, Computer Science Division, University of California\n* at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
- rb_lwork = argv[4];
- rb_lrwork = argv[5];
- rb_liwork = argv[6];
-
- compz = StringValueCStr(rb_compz)[0];
- liwork = NUM2INT(rb_liwork);
- lrwork = NUM2INT(rb_lrwork);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of d");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lrwork);
- rb_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- rwork = NA_PTR_TYPE(rb_rwork, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- zstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(7, rb_work, rb_rwork, rb_iwork, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_zstedc(VALUE mLapack){
- rb_define_module_function(mLapack, "zstedc", rb_zstedc, -1);
-}
diff --git a/zstegr.c b/zstegr.c
deleted file mode 100644
index 1b53ea3..0000000
--- a/zstegr.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zstegr_(char *jobz, char *range, integer *n, doublereal *d, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublecomplex *z, integer *ldz, integer *isuppz, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zstegr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_abstol;
- doublereal abstol;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.zstegr( jobz, range, d, e, vl, vu, il, iu, abstol, lwork, liwork)\n or\n NumRu::Lapack.zstegr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEGR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* ZSTEGR is a compatability wrapper around the improved ZSTEMR routine.\n* See DSTEMR for further details.\n*\n* One important change is that the ABSTOL parameter no longer provides any\n* benefit and hence is no longer used.\n*\n* Note : ZSTEGR and ZSTEMR work only on machines which follow\n* IEEE-754 floating-point standard in their handling of infinities and\n* NaNs. Normal execution may create these exceptiona values and hence\n* may abort due to a floating point exception in environments which\n* do not conform to the IEEE-754 standard.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* ABSTOL (input) DOUBLE PRECISION\n* Unused. Was the absolute error tolerance for the\n* eigenvalues/eigenvectors in previous versions.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and an upper bound must be used.\n* Supplying N columns is always safe.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in ZLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* ZLARRV, respectively.\n*\n\n* Further Details\n* ===============\n*\n* Based on contributions by\n* Inderjit Dhillon, IBM Almaden, USA\n* Osni Marques, LBNL/NERSC, USA\n* Christof Voemel, LBNL/NERSC, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL TRYRAC\n* ..\n* .. External Subroutines ..\n EXTERNAL ZSTEMR\n* ..\n\n");
- return Qnil;
- }
- if (argc != 11)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_abstol = argv[8];
- rb_lwork = argv[9];
- rb_liwork = argv[10];
-
- abstol = NUM2DBL(rb_abstol);
- vl = NUM2DBL(rb_vl);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- il = NUM2INT(rb_il);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- zstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e);
-}
-
-void
-init_lapack_zstegr(VALUE mLapack){
- rb_define_module_function(mLapack, "zstegr", rb_zstegr, -1);
-}
diff --git a/zstein.c b/zstein.c
deleted file mode 100644
index 7d1bb08..0000000
--- a/zstein.c
+++ /dev/null
@@ -1,115 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zstein_(integer *n, doublereal *d, doublereal *e, integer *m, doublereal *w, integer *iblock, integer *isplit, doublecomplex *z, integer *ldz, doublereal *work, integer *iwork, integer *ifail, integer *info);
-
-static VALUE
-rb_zstein(int argc, VALUE *argv, VALUE self){
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_iblock;
- integer *iblock;
- VALUE rb_isplit;
- integer *isplit;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ifail;
- integer *ifail;
- VALUE rb_info;
- integer info;
- doublereal *work;
- integer *iwork;
-
- integer n;
- integer ldz;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n z, ifail, info = NumRu::Lapack.zstein( d, e, w, iblock, isplit)\n or\n NumRu::Lapack.zstein # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEIN computes the eigenvectors of a real symmetric tridiagonal\n* matrix T corresponding to specified eigenvalues, using inverse\n* iteration.\n*\n* The maximum number of iterations allowed for each eigenvector is\n* specified by an internal parameter MAXITS (currently set to 5).\n*\n* Although the eigenvectors are real, they are stored in a complex\n* array, which may be passed to ZUNMTR or ZUPMTR for back\n* transformation to the eigenvectors of a complex Hermitian matrix\n* which was reduced to tridiagonal form.\n*\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input) DOUBLE PRECISION array, dimension (N)\n* The n diagonal elements of the tridiagonal matrix T.\n*\n* E (input) DOUBLE PRECISION array, dimension (N-1)\n* The (n-1) subdiagonal elements of the tridiagonal matrix\n* T, stored in elements 1 to N-1.\n*\n* M (input) INTEGER\n* The number of eigenvectors to be found. 0 <= M <= N.\n*\n* W (input) DOUBLE PRECISION array, dimension (N)\n* The first M elements of W contain the eigenvalues for\n* which eigenvectors are to be computed. The eigenvalues\n* should be grouped by split-off block and ordered from\n* smallest to largest within the block. ( The output array\n* W from DSTEBZ with ORDER = 'B' is expected here. )\n*\n* IBLOCK (input) INTEGER array, dimension (N)\n* The submatrix indices associated with the corresponding\n* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n* the first submatrix from the top, =2 if W(i) belongs to\n* the second submatrix, etc. ( The output array IBLOCK\n* from DSTEBZ is expected here. )\n*\n* ISPLIT (input) INTEGER array, dimension (N)\n* The splitting points, at which T breaks up into submatrices.\n* The first submatrix consists of rows/columns 1 to\n* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n* through ISPLIT( 2 ), etc.\n* ( The output array ISPLIT from DSTEBZ is expected here. )\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, M)\n* The computed eigenvectors. The eigenvector associated\n* with the eigenvalue W(i) is stored in the i-th column of\n* Z. Any vector which fails to converge is set to its current\n* iterate after MAXITS iterations.\n* The imaginary parts of the eigenvectors are set to zero.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n* IWORK (workspace) INTEGER array, dimension (N)\n*\n* IFAIL (output) INTEGER array, dimension (M)\n* On normal exit, all elements of IFAIL are zero.\n* If one or more eigenvectors fail to converge after\n* MAXITS iterations, then their indices are stored in\n* array IFAIL.\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, then i eigenvectors failed to converge\n* in MAXITS iterations. Their indices are stored in\n* array IFAIL.\n*\n* Internal Parameters\n* ===================\n*\n* MAXITS INTEGER, default = 5\n* The maximum number of iterations performed.\n*\n* EXTRA INTEGER, default = 2\n* The number of iterations performed after norm growth\n* criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_d = argv[0];
- rb_e = argv[1];
- rb_w = argv[2];
- rb_iblock = argv[3];
- rb_isplit = argv[4];
-
- if (!NA_IsNArray(rb_w))
- rb_raise(rb_eArgError, "w (3th argument) must be NArray");
- if (NA_RANK(rb_w) != 1)
- rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_w);
- if (NA_TYPE(rb_w) != NA_DFLOAT)
- rb_w = na_change_type(rb_w, NA_DFLOAT);
- w = NA_PTR_TYPE(rb_w, doublereal*);
- if (!NA_IsNArray(rb_iblock))
- rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
- if (NA_RANK(rb_iblock) != 1)
- rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_iblock) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of w");
- if (NA_TYPE(rb_iblock) != NA_LINT)
- rb_iblock = na_change_type(rb_iblock, NA_LINT);
- iblock = NA_PTR_TYPE(rb_iblock, integer*);
- if (!NA_IsNArray(rb_isplit))
- rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
- if (NA_RANK(rb_isplit) != 1)
- rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_isplit) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of w");
- if (NA_TYPE(rb_isplit) != NA_LINT)
- rb_isplit = na_change_type(rb_isplit, NA_LINT);
- isplit = NA_PTR_TYPE(rb_isplit, integer*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (1th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of w");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (2th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- m = n;
- ldz = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = m;
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = m;
- rb_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ifail = NA_PTR_TYPE(rb_ifail, integer*);
- work = ALLOC_N(doublereal, (5*n));
- iwork = ALLOC_N(integer, (n));
-
- zstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);
-
- free(work);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_z, rb_ifail, rb_info);
-}
-
-void
-init_lapack_zstein(VALUE mLapack){
- rb_define_module_function(mLapack, "zstein", rb_zstein, -1);
-}
diff --git a/zstemr.c b/zstemr.c
deleted file mode 100644
index 5be5c92..0000000
--- a/zstemr.c
+++ /dev/null
@@ -1,162 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zstemr_(char *jobz, char *range, integer *n, doublereal *d, doublereal *e, doublereal *vl, doublereal *vu, integer *il, integer *iu, integer *m, doublereal *w, doublecomplex *z, integer *ldz, integer *nzc, integer *isuppz, logical *tryrac, doublereal *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_zstemr(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobz;
- char jobz;
- VALUE rb_range;
- char range;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_vl;
- doublereal vl;
- VALUE rb_vu;
- doublereal vu;
- VALUE rb_il;
- integer il;
- VALUE rb_iu;
- integer iu;
- VALUE rb_nzc;
- integer nzc;
- VALUE rb_tryrac;
- logical tryrac;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_m;
- integer m;
- VALUE rb_w;
- doublereal *w;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_isuppz;
- integer *isuppz;
- VALUE rb_work;
- doublereal *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.zstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, lwork, liwork)\n or\n NumRu::Lapack.zstemr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEMR computes selected eigenvalues and, optionally, eigenvectors\n* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n* a well defined set of pairwise different real eigenvalues, the corresponding\n* real eigenvectors are pairwise orthogonal.\n*\n* The spectrum may be computed either completely or partially by specifying\n* either an interval (VL,VU] or a range of indices IL:IU for the desired\n* eigenvalues.\n*\n* Depending on the number of desired eigenvalues, these are computed either\n* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n* computed by the use of various suitable L D L^T factorizations near clusters\n* of close eigenvalues (referred to as RRRs, Relatively Robust\n* Representations). An informal sketch of the algorithm follows.\n*\n* For each unreduced block (submatrix) of T,\n* (a) Compute T - sigma I = L D L^T, so that L and D\n* define all the wanted eigenvalues to high relative accuracy.\n* This means that small relative changes in the entries of D and L\n* cause only small relative changes in the eigenvalues and\n* eigenvectors. The standard (unfactored) representation of the\n* tridiagonal matrix T does not have this property in general.\n* (b) Compute the eigenvalues to suitable accuracy.\n* If the eigenvectors are desired, the algorithm attains full\n* accuracy of the computed eigenvalues only right before\n* the corresponding vectors have to be computed, see steps c) and d).\n* (c) For each cluster of close eigenvalues, select a new\n* shift close to the cluster, find a new factorization, and refine\n* the shifted eigenvalues to suitable accuracy.\n* (d) For each eigenvalue with a large enough relative separation compute\n* the corresponding eigenvector by forming a rank revealing twisted\n* factorization. Go back to (c) for any clusters that remain.\n*\n* For more details, see:\n* - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n* - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n* Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n* 2004. Also LAPACK Working Note 154.\n* - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n* tridiagonal eigenvalue/eigenvector problem\",\n* Computer Science Division Technical Report No. UCB/CSD-97-971,\n* UC Berkeley, May 1997.\n*\n* Further Details\n* 1.ZSTEMR works only on machines which follow IEEE-754\n* floating-point standard in their handling of infinities and NaNs.\n* This permits the use of efficient inner loops avoiding a check for\n* zero divisors.\n*\n* 2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n* real symmetric tridiagonal form.\n*\n* (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n* and potentially complex numbers on its off-diagonals. By applying a\n* similarity transform with an appropriate diagonal matrix\n* diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n* matrix can be transformed into a real symmetric matrix and complex\n* arithmetic can be entirely avoided.)\n*\n* While the eigenvectors of the real symmetric tridiagonal matrix are real,\n* the eigenvectors of original complex Hermitean matrix have complex entries\n* in general.\n* Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n* ZSTEMR accepts complex workspace to facilitate interoperability\n* with ZUNMTR or ZUPMTR.\n*\n\n* Arguments\n* =========\n*\n* JOBZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only;\n* = 'V': Compute eigenvalues and eigenvectors.\n*\n* RANGE (input) CHARACTER*1\n* = 'A': all eigenvalues will be found.\n* = 'V': all eigenvalues in the half-open interval (VL,VU]\n* will be found.\n* = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the N diagonal elements of the tridiagonal matrix\n* T. On exit, D is overwritten.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the (N-1) subdiagonal elements of the tridiagonal\n* matrix T in elements 1 to N-1 of E. E(N) need not be set on\n* input, but is used internally as workspace.\n* On exit, E is overwritten.\n*\n* VL (input) DOUBLE PRECISION\n* VU (input) DOUBLE PRECISION\n* If RANGE='V', the lower and upper bounds of the interval to\n* be searched for eigenvalues. VL < VU.\n* Not referenced if RANGE = 'A' or 'I'.\n*\n* IL (input) INTEGER\n* IU (input) INTEGER\n* If RANGE='I', the indices (in ascending order) of the\n* smallest and largest eigenvalues to be returned.\n* 1 <= IL <= IU <= N, if N > 0.\n* Not referenced if RANGE = 'A' or 'V'.\n*\n* M (output) INTEGER\n* The total number of eigenvalues found. 0 <= M <= N.\n* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n* W (output) DOUBLE PRECISION array, dimension (N)\n* The first M elements contain the selected eigenvalues in\n* ascending order.\n*\n* Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n* contain the orthonormal eigenvectors of the matrix T\n* corresponding to the selected eigenvalues, with the i-th\n* column of Z holding the eigenvector associated with W(i).\n* If JOBZ = 'N', then Z is not referenced.\n* Note: the user must ensure that at least max(1,M) columns are\n* supplied in the array Z; if RANGE = 'V', the exact value of M\n* is not known in advance and can be computed with a workspace\n* query by setting NZC = -1, see below.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* JOBZ = 'V', then LDZ >= max(1,N).\n*\n* NZC (input) INTEGER\n* The number of eigenvectors to be held in the array Z.\n* If RANGE = 'A', then NZC >= max(1,N).\n* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n* If RANGE = 'I', then NZC >= IU-IL+1.\n* If NZC = -1, then a workspace query is assumed; the\n* routine calculates the number of columns of the array Z that\n* are needed to hold the eigenvectors.\n* This value is returned as the first entry of the Z array, and\n* no error message related to NZC is issued by XERBLA.\n*\n* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n* The support of the eigenvectors in Z, i.e., the indices\n* indicating the nonzero elements in Z. The i-th computed eigenvector\n* is nonzero only in elements ISUPPZ( 2*i-1 ) through\n* ISUPPZ( 2*i ). This is relevant in the case when the matrix\n* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n* TRYRAC (input/output) LOGICAL\n* If TRYRAC.EQ..TRUE., indicates that the code should check whether\n* the tridiagonal matrix defines its eigenvalues to high relative\n* accuracy. If so, the code uses relative-accuracy preserving\n* algorithms that might be (a bit) slower depending on the matrix.\n* If the matrix does not define its eigenvalues to high relative\n* accuracy, the code can uses possibly faster algorithms.\n* If TRYRAC.EQ..FALSE., the code is not required to guarantee\n* relatively accurate eigenvalues and can use the fastest possible\n* techniques.\n* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n* does not define its eigenvalues to high relative accuracy.\n*\n* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n* On exit, if INFO = 0, WORK(1) returns the optimal\n* (and minimal) LWORK.\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK. LWORK >= max(1,18*N)\n* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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/output) INTEGER array, dimension (LIWORK)\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= max(1,10*N)\n* if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n* if only the eigenvalues are to be computed.\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK is issued by XERBLA.\n*\n* INFO (output) INTEGER\n* On exit, INFO\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = 1X, internal error in DLARRE,\n* if INFO = 2X, internal error in ZLARRV.\n* Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n* the nonzero error code returned by DLARRE or\n* ZLARRV, respectively.\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 (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobz = argv[0];
- rb_range = argv[1];
- rb_d = argv[2];
- rb_e = argv[3];
- rb_vl = argv[4];
- rb_vu = argv[5];
- rb_il = argv[6];
- rb_iu = argv[7];
- rb_nzc = argv[8];
- rb_tryrac = argv[9];
- rb_lwork = argv[10];
- rb_liwork = argv[11];
-
- vl = NUM2DBL(rb_vl);
- nzc = NUM2INT(rb_nzc);
- iu = NUM2INT(rb_iu);
- jobz = StringValueCStr(rb_jobz)[0];
- vu = NUM2DBL(rb_vu);
- liwork = NUM2INT(rb_liwork);
- il = NUM2INT(rb_il);
- tryrac = (rb_tryrac == Qtrue);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (4th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- range = StringValueCStr(rb_range)[0];
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (3th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
- ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublereal*);
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = MAX(1,m);
- rb_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[1];
- shape[0] = 2*MAX(1,m);
- rb_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- isuppz = NA_PTR_TYPE(rb_isuppz, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
-
- zstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- rb_tryrac = tryrac ? Qtrue : Qfalse;
- return rb_ary_new3(10, rb_m, rb_w, rb_z, rb_isuppz, rb_work, rb_iwork, rb_info, rb_d, rb_e, rb_tryrac);
-}
-
-void
-init_lapack_zstemr(VALUE mLapack){
- rb_define_module_function(mLapack, "zstemr", rb_zstemr, -1);
-}
diff --git a/zsteqr.c b/zsteqr.c
deleted file mode 100644
index da37322..0000000
--- a/zsteqr.c
+++ /dev/null
@@ -1,107 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsteqr_(char *compz, integer *n, doublereal *d, doublereal *e, doublecomplex *z, integer *ldz, doublereal *work, integer *info);
-
-static VALUE
-rb_zsteqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_compz;
- char compz;
- VALUE rb_d;
- doublereal *d;
- VALUE rb_e;
- doublereal *e;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_info;
- integer info;
- VALUE rb_d_out__;
- doublereal *d_out__;
- VALUE rb_e_out__;
- doublereal *e_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
- doublereal *work;
-
- integer n;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, d, e, z = NumRu::Lapack.zsteqr( compz, d, e, z)\n or\n NumRu::Lapack.zsteqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n* symmetric tridiagonal matrix using the implicit QL or QR method.\n* The eigenvectors of a full or band complex Hermitian matrix can also\n* be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n* matrix to tridiagonal form.\n*\n\n* Arguments\n* =========\n*\n* COMPZ (input) CHARACTER*1\n* = 'N': Compute eigenvalues only.\n* = 'V': Compute eigenvalues and eigenvectors of the original\n* Hermitian matrix. On entry, Z must contain the\n* unitary matrix used to reduce the original matrix\n* to tridiagonal form.\n* = 'I': Compute eigenvalues and eigenvectors of the\n* tridiagonal matrix. Z is initialized to the identity\n* matrix.\n*\n* N (input) INTEGER\n* The order of the matrix. N >= 0.\n*\n* D (input/output) DOUBLE PRECISION array, dimension (N)\n* On entry, the diagonal elements of the tridiagonal matrix.\n* On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n* E (input/output) DOUBLE PRECISION array, dimension (N-1)\n* On entry, the (n-1) subdiagonal elements of the tridiagonal\n* matrix.\n* On exit, E has been destroyed.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n* On entry, if COMPZ = 'V', then Z contains the unitary\n* matrix used in the reduction to tridiagonal form.\n* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n* orthonormal eigenvectors of the original Hermitian matrix,\n* and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n* of the symmetric tridiagonal matrix.\n* If COMPZ = 'N', then Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1, and if\n* eigenvectors are desired, then LDZ >= max(1,N).\n*\n* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n* If COMPZ = 'N', then WORK is not referenced.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: the algorithm has failed to find all the eigenvalues in\n* a total of 30*N iterations; if INFO = i, then i\n* elements of E have not converged to zero; on exit, D\n* and E contain the elements of a symmetric tridiagonal\n* matrix which is unitarily similar to the original\n* matrix.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_compz = argv[0];
- rb_d = argv[1];
- rb_e = argv[2];
- rb_z = argv[3];
-
- compz = StringValueCStr(rb_compz)[0];
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (4th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_z);
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (2th argument) must be NArray");
- if (NA_RANK(rb_d) != 1)
- rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
- if (NA_SHAPE0(rb_d) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
- if (NA_TYPE(rb_d) != NA_DFLOAT)
- rb_d = na_change_type(rb_d, NA_DFLOAT);
- d = NA_PTR_TYPE(rb_d, doublereal*);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (3th argument) must be NArray");
- if (NA_RANK(rb_e) != 1)
- rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_e) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
- if (NA_TYPE(rb_e) != NA_DFLOAT)
- rb_e = na_change_type(rb_e, NA_DFLOAT);
- e = NA_PTR_TYPE(rb_e, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- d_out__ = NA_PTR_TYPE(rb_d_out__, doublereal*);
- MEMCPY(d_out__, d, doublereal, NA_TOTAL(rb_d));
- rb_d = rb_d_out__;
- d = d_out__;
- {
- int shape[1];
- shape[0] = n-1;
- rb_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- e_out__ = NA_PTR_TYPE(rb_e_out__, doublereal*);
- MEMCPY(e_out__, e, doublereal, NA_TOTAL(rb_e));
- rb_e = rb_e_out__;
- e = e_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
- work = ALLOC_N(doublereal, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));
-
- zsteqr_(&compz, &n, d, e, z, &ldz, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_info, rb_d, rb_e, rb_z);
-}
-
-void
-init_lapack_zsteqr(VALUE mLapack){
- rb_define_module_function(mLapack, "zsteqr", rb_zsteqr, -1);
-}
diff --git a/zsycon.c b/zsycon.c
deleted file mode 100644
index 8d5bf35..0000000
--- a/zsycon.c
+++ /dev/null
@@ -1,68 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsycon_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zsycon(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_anorm;
- doublereal anorm;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.zsycon( uplo, a, ipiv, anorm)\n or\n NumRu::Lapack.zsycon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYCON estimates the reciprocal of the condition number (in the\n* 1-norm) of a complex symmetric matrix A using the factorization\n* A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.\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* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* ANORM (input) DOUBLE PRECISION\n* The 1-norm of the original matrix A.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_anorm = argv[3];
-
- anorm = NUM2DBL(rb_anorm);
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublecomplex, (2*n));
-
- zsycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);
-
- free(work);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_zsycon(VALUE mLapack){
- rb_define_module_function(mLapack, "zsycon", rb_zsycon, -1);
-}
diff --git a/zsyconv.c b/zsyconv.c
deleted file mode 100644
index 5bc1afc..0000000
--- a/zsyconv.c
+++ /dev/null
@@ -1,65 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsyconv_(char *uplo, char *way, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zsyconv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_way;
- char way;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info = NumRu::Lapack.zsyconv( uplo, way, a, ipiv)\n or\n NumRu::Lapack.zsyconv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYCONV converts A given by ZHETRF into L and D or vice-versa.\n* Get nondiagonal elements of D (returned in workspace) and \n* apply or reverse permutation done in TRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n* \n* WAY (input) CHARACTER*1\n* = 'C': Convert \n* = 'R': Revert\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) DOUBLE COMPLEX array, dimension (N)\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. \n* LWORK = 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* 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_way = argv[1];
- rb_a = argv[2];
- rb_ipiv = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- way = StringValueCStr(rb_way)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublecomplex, (MAX(1,n)));
-
- zsyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_info;
-}
-
-void
-init_lapack_zsyconv(VALUE mLapack){
- rb_define_module_function(mLapack, "zsyconv", rb_zsyconv, -1);
-}
diff --git a/zsyequb.c b/zsyequb.c
deleted file mode 100644
index 428fe65..0000000
--- a/zsyequb.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsyequb_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *s, doublereal *scond, doublereal *amax, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zsyequb(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_scond;
- doublereal scond;
- VALUE rb_amax;
- doublereal amax;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, scond, amax, info = NumRu::Lapack.zsyequb( uplo, a)\n or\n NumRu::Lapack.zsyequb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYEQUB computes row and column scalings intended to equilibrate a\n* symmetric matrix A and reduce its condition number\n* (with respect to the two-norm). S contains the scale factors,\n* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n* choice of S puts the condition number of B within a factor N of the\n* smallest possible condition number over all possible diagonal\n* scalings.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The N-by-N symmetric matrix whose scaling\n* factors are to be computed. Only the diagonal elements of A\n* are referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* S (output) DOUBLE PRECISION array, dimension (N)\n* If INFO = 0, S contains the scale factors for A.\n*\n* SCOND (output) DOUBLE PRECISION\n* If INFO = 0, S contains the ratio of the smallest S(i) to\n* the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n* large nor too small, it is not worth scaling by S.\n*\n* AMAX (output) DOUBLE PRECISION\n* Absolute value of largest matrix element. If AMAX is very\n* close to overflow or very close to underflow, the matrix\n* should be scaled.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (3*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element is nonpositive.\n*\n\n* Further Details\n* ======= =======\n*\n* Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n* Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n* DOI 10.1023/B:NUMA.0000016606.32820.69\n* Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- work = ALLOC_N(doublecomplex, (3*n));
-
- zsyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);
-
- free(work);
- rb_scond = rb_float_new((double)scond);
- rb_amax = rb_float_new((double)amax);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_scond, rb_amax, rb_info);
-}
-
-void
-init_lapack_zsyequb(VALUE mLapack){
- rb_define_module_function(mLapack, "zsyequb", rb_zsyequb, -1);
-}
diff --git a/zsymv.c b/zsymv.c
deleted file mode 100644
index 21d39ee..0000000
--- a/zsymv.c
+++ /dev/null
@@ -1,96 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsymv_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, doublecomplex *beta, doublecomplex *y, integer *incy);
-
-static VALUE
-rb_zsymv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_beta;
- doublecomplex beta;
- VALUE rb_y;
- doublecomplex *y;
- VALUE rb_incy;
- integer incy;
- VALUE rb_y_out__;
- doublecomplex *y_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n y = NumRu::Lapack.zsymv( uplo, alpha, a, x, incx, beta, y, incy)\n or\n NumRu::Lapack.zsymv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n* Purpose\n* =======\n*\n* ZSYMV performs the matrix-vector operation\n*\n* y := alpha*A*x + beta*y,\n*\n* where alpha and beta are scalars, x and y are n element vectors and\n* A is an n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* A (input) COMPLEX*16 array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced.\n* Unchanged on exit.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* BETA (input) COMPLEX*16\n* On entry, BETA specifies the scalar beta. When BETA is\n* supplied as zero then Y need not be set on input.\n* Unchanged on exit.\n*\n* Y (input/output) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCY ) ).\n* Before entry, the incremented array Y must contain the n\n* element vector y. On exit, Y is overwritten by the updated\n* vector y.\n*\n* INCY (input) INTEGER\n* On entry, INCY specifies the increment for the elements of\n* Y. INCY must not be zero.\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_a = argv[2];
- rb_x = argv[3];
- rb_incx = argv[4];
- rb_beta = argv[5];
- rb_y = argv[6];
- rb_incy = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- beta.r = NUM2DBL(rb_funcall(rb_beta, rb_intern("real"), 0));
- beta.i = NUM2DBL(rb_funcall(rb_beta, rb_intern("imag"), 0));
- incy = NUM2INT(rb_incy);
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_y))
- rb_raise(rb_eArgError, "y (7th argument) must be NArray");
- if (NA_RANK(rb_y) != 1)
- rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_y) != (1 + ( n - 1 )*abs( incy )))
- rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
- if (NA_TYPE(rb_y) != NA_DCOMPLEX)
- rb_y = na_change_type(rb_y, NA_DCOMPLEX);
- y = NA_PTR_TYPE(rb_y, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (4th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = 1 + ( n - 1 )*abs( incy );
- rb_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- y_out__ = NA_PTR_TYPE(rb_y_out__, doublecomplex*);
- MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rb_y));
- rb_y = rb_y_out__;
- y = y_out__;
-
- zsymv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);
-
- return rb_y;
-}
-
-void
-init_lapack_zsymv(VALUE mLapack){
- rb_define_module_function(mLapack, "zsymv", rb_zsymv, -1);
-}
diff --git a/zsyr.c b/zsyr.c
deleted file mode 100644
index e53c936..0000000
--- a/zsyr.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsyr_(char *uplo, integer *n, doublecomplex *alpha, doublecomplex *x, integer *incx, doublecomplex *a, integer *lda);
-
-static VALUE
-rb_zsyr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_incx;
- integer incx;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.zsyr( uplo, alpha, x, incx, a)\n or\n NumRu::Lapack.zsyr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n* Purpose\n* =======\n*\n* ZSYR performs the symmetric rank 1 operation\n*\n* A := alpha*x*( x' ) + A,\n*\n* where alpha is a complex scalar, x is an n element vector and A is an\n* n by n symmetric matrix.\n*\n\n* Arguments\n* ==========\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the upper or lower\n* triangular part of the array A is to be referenced as\n* follows:\n*\n* UPLO = 'U' or 'u' Only the upper triangular part of A\n* is to be referenced.\n*\n* UPLO = 'L' or 'l' Only the lower triangular part of A\n* is to be referenced.\n*\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of the matrix A.\n* N must be at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha.\n* Unchanged on exit.\n*\n* X (input) COMPLEX*16 array, dimension at least\n* ( 1 + ( N - 1 )*abs( INCX ) ).\n* Before entry, the incremented array X must contain the N-\n* element vector x.\n* Unchanged on exit.\n*\n* INCX (input) INTEGER\n* On entry, INCX specifies the increment for the elements of\n* X. INCX must not be zero.\n* Unchanged on exit.\n*\n* A (input/output) COMPLEX*16 array, dimension ( LDA, N )\n* Before entry, with UPLO = 'U' or 'u', the leading n by n\n* upper triangular part of the array A must contain the upper\n* triangular part of the symmetric matrix and the strictly\n* lower triangular part of A is not referenced. On exit, the\n* upper triangular part of the array A is overwritten by the\n* upper triangular part of the updated matrix.\n* Before entry, with UPLO = 'L' or 'l', the leading n by n\n* lower triangular part of the array A must contain the lower\n* triangular part of the symmetric matrix and the strictly\n* upper triangular part of A is not referenced. On exit, the\n* lower triangular part of the array A is overwritten by the\n* lower triangular part of the updated matrix.\n*\n* LDA (input) INTEGER\n* On entry, LDA specifies the first dimension of A as declared\n* in the calling (sub) program. LDA must be at least\n* max( 1, N ).\n* Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_alpha = argv[1];
- rb_x = argv[2];
- rb_incx = argv[3];
- rb_a = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- incx = NUM2INT(rb_incx);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (3th argument) must be NArray");
- if (NA_RANK(rb_x) != 1)
- rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_x) != (1 + ( n - 1 )*abs( incx )))
- rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zsyr_(&uplo, &n, &alpha, x, &incx, a, &lda);
-
- return rb_a;
-}
-
-void
-init_lapack_zsyr(VALUE mLapack){
- rb_define_module_function(mLapack, "zsyr", rb_zsyr, -1);
-}
diff --git a/zsyrfs.c b/zsyrfs.c
deleted file mode 100644
index ca6a8ea..0000000
--- a/zsyrfs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsyrfs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zsyrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info, x = NumRu::Lapack.zsyrfs( uplo, a, af, ipiv, b, x)\n or\n NumRu::Lapack.zsyrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYRFS improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the solution.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or\n* A = L*D*L**T as computed by ZSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by ZSYTRS.\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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_af = argv[2];
- rb_ipiv = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (3th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- zsyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ferr, rb_berr, rb_info, rb_x);
-}
-
-void
-init_lapack_zsyrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "zsyrfs", rb_zsyrfs, -1);
-}
diff --git a/zsyrfsx.c b/zsyrfsx.c
deleted file mode 100644
index d41619f..0000000
--- a/zsyrfsx.c
+++ /dev/null
@@ -1,199 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsyrfsx_(char *uplo, char *equed, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zsyrfsx(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_equed;
- char equed;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_x_out__;
- doublecomplex *x_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
- integer nparams;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params)\n or\n NumRu::Lapack.zsyrfsx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYRFSX improves the computed solution to a system of linear\n* equations when the coefficient matrix is symmetric indefinite, and\n* provides error bounds and backward error estimates for the\n* solution. In addition to normwise error bound, the code provides\n* maximum componentwise error bound if possible. See comments for\n* ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n* The original system of linear equations may have been equilibrated\n* before calling this routine, as described by arguments EQUED and S\n* below. In this case, the solution and error bounds returned are\n* for the original unequilibrated system.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* EQUED (input) CHARACTER*1\n* Specifies the form of equilibration that was done to A\n* before calling this routine. This is needed to compute\n* the solution and error bounds correctly.\n* = 'N': No equilibration\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* The right hand side B has been changed accordingly.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input) COMPLEX*16 array, dimension (LDAF,N)\n* The factored form of the matrix A. AF contains the block\n* diagonal matrix D and the multipliers used to obtain the\n* factor U or L from the factorization A = U*D*U**T or A =\n* L*D*L**T as computed by DSYTRF.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by DSYTRF.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 array, dimension (LDX,NRHS)\n* On entry, the solution matrix X, as computed by DGETRS.\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* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the double-precision refinement algorithm,\n* possibly with doubled-single computations if the\n* compilation environment does not support DOUBLE\n* PRECISION.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_uplo = argv[0];
- rb_equed = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_s = argv[5];
- rb_b = argv[6];
- rb_x = argv[7];
- rb_params = argv[8];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (8th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (6th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- equed = StringValueCStr(rb_equed)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x_out__ = NA_PTR_TYPE(rb_x_out__, doublecomplex*);
- MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rb_x));
- rb_x = rb_x_out__;
- x = x_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zsyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_rcond, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_s, rb_x, rb_params);
-}
-
-void
-init_lapack_zsyrfsx(VALUE mLapack){
- rb_define_module_function(mLapack, "zsyrfsx", rb_zsyrfsx, -1);
-}
diff --git a/zsysv.c b/zsysv.c
deleted file mode 100644
index 58790c1..0000000
--- a/zsysv.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsysv_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zsysv(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a, b = NumRu::Lapack.zsysv( uplo, a, b, lwork)\n or\n NumRu::Lapack.zsysv # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYSV computes the solution to a complex system of linear equations\n* A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* The diagonal pivoting method is used to factor A as\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n* used to solve the system of equations A * X = B.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* 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 INFO = 0, the block diagonal matrix D and the\n* multipliers used to obtain the factor U or L from the\n* factorization A = U*D*U**T or A = L*D*L**T as computed by\n* ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D, as\n* determined by ZSYTRF. If IPIV(k) > 0, then rows and columns\n* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n* then rows and columns k-1 and -IPIV(k) were interchanged and\n* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n* diagonal block.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= 1, and for best performance\n* LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n* ZSYTRF.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, so the solution could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZSYTRF, ZSYTRS2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_b = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (3th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zsysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_ipiv, rb_work, rb_info, rb_a, rb_b);
-}
-
-void
-init_lapack_zsysv(VALUE mLapack){
- rb_define_module_function(mLapack, "zsysv", rb_zsysv, -1);
-}
diff --git a/zsysvx.c b/zsysvx.c
deleted file mode 100644
index d537af0..0000000
--- a/zsysvx.c
+++ /dev/null
@@ -1,158 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsysvx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zsysvx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zsysvx( fact, uplo, a, af, ipiv, b, lwork)\n or\n NumRu::Lapack.zsysvx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYSVX uses the diagonal pivoting factorization to compute the\n* solution to a complex system of linear equations A * X = B,\n* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* Error bounds on the solution and a condition estimate are also\n* provided.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n* The form of the factorization is\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n* returns with INFO = i. Otherwise, the factored form of A is used\n* to estimate the condition number of the matrix A. If the\n* reciprocal of the condition number is less than machine precision,\n* INFO = N+1 is returned as a warning, but the routine still goes on\n* to solve for X and compute error bounds as described below.\n*\n* 3. The system of equations is solved for X using the factored form\n* of A.\n*\n* 4. Iterative refinement is applied to improve the computed solution\n* matrix and calculate error bounds and backward error estimates\n* for it.\n*\n\n* Arguments\n* =========\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of A has been\n* supplied on entry.\n* = 'F': On entry, AF and IPIV contain the factored form\n* of A. A, AF and IPIV will not be modified.\n* = 'N': The matrix A will be copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular part\n* of the matrix A, and the strictly lower triangular part of A\n* is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of A contains the lower triangular part of\n* the matrix A, and the strictly upper triangular part of A is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L from the factorization\n* A = U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSYTRF.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block structure\n* of D, as determined by ZSYTRF.\n*\n* B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n* The N-by-NRHS 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 (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* The estimate of the reciprocal condition number of the matrix\n* A. If RCOND is less than the machine precision (in\n* particular, if RCOND = 0), the matrix is singular to working\n* precision. This condition is indicated by a return code of\n* INFO > 0.\n*\n* FERR (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >= max(1,2*N), and for best\n* performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n* NB is the optimal blocksize for ZSYTRF.\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* RWORK (workspace) DOUBLE PRECISION 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* > 0: if INFO = i, and i is\n* <= N: D(i,i) is exactly zero. The factorization\n* has been completed but the factor D is exactly\n* singular, so the solution and error bounds could\n* not be computed. RCOND = 0 is returned.\n* = N+1: D is nonsingular, but RCOND is less than machine\n* precision, meaning that the matrix is singular\n* to working precision. Nevertheless, the\n* solution and error bounds are computed because\n* there are a number of situations where the\n* computed solution can be more accurate than the\n* value of RCOND would suggest.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_b = argv[5];
- rb_lwork = argv[6];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- fact = StringValueCStr(rb_fact)[0];
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- rwork = ALLOC_N(doublereal, (n));
-
- zsysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);
-
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_x, rb_rcond, rb_ferr, rb_berr, rb_work, rb_info, rb_af, rb_ipiv);
-}
-
-void
-init_lapack_zsysvx(VALUE mLapack){
- rb_define_module_function(mLapack, "zsysvx", rb_zsysvx, -1);
-}
diff --git a/zsysvxx.c b/zsysvxx.c
deleted file mode 100644
index 0f40e3f..0000000
--- a/zsysvxx.c
+++ /dev/null
@@ -1,239 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsysvxx_(char *fact, char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, integer *ipiv, char *equed, doublereal *s, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, doublereal *berr, integer *n_err_bnds, doublereal *err_bnds_norm, doublereal *err_bnds_comp, integer *nparams, doublereal *params, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_zsysvxx(int argc, VALUE *argv, VALUE self){
- VALUE rb_fact;
- char fact;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_af;
- doublecomplex *af;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_equed;
- char equed;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_params;
- doublereal *params;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_rpvgrw;
- doublereal rpvgrw;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_err_bnds_norm;
- doublereal *err_bnds_norm;
- VALUE rb_err_bnds_comp;
- doublereal *err_bnds_comp;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_af_out__;
- doublecomplex *af_out__;
- VALUE rb_ipiv_out__;
- integer *ipiv_out__;
- VALUE rb_s_out__;
- doublereal *s_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_params_out__;
- doublereal *params_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldaf;
- integer ldb;
- integer nrhs;
- integer nparams;
- integer ldx;
- integer n_err_bnds;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params)\n or\n NumRu::Lapack.zsysvxx # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYSVXX uses the diagonal pivoting factorization to compute the\n* solution to a complex*16 system of linear equations A * X = B, where\n* A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n* matrices.\n*\n* If requested, both normwise and maximum componentwise error bounds\n* are returned. ZSYSVXX will return a solution with a tiny\n* guaranteed error (O(eps) where eps is the working machine\n* precision) unless the matrix is very ill-conditioned, in which\n* case a warning is returned. Relevant condition numbers also are\n* calculated and returned.\n*\n* ZSYSVXX accepts user-provided factorizations and equilibration\n* factors; see the definitions of the FACT and EQUED options.\n* Solving with refinement and using a factorization from a previous\n* ZSYSVXX call will also produce a solution with either O(eps)\n* errors or warnings, but we cannot make that claim for general\n* user-provided factorizations and equilibration factors if they\n* differ from what ZSYSVXX would itself produce.\n*\n* Description\n* ===========\n*\n* The following steps are performed:\n*\n* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n* the system:\n*\n* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n*\n* Whether or not the system will be equilibrated depends on the\n* scaling of the matrix A, but if equilibration is used, A is\n* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n* the matrix A (after equilibration if FACT = 'E') as\n*\n* A = U * D * U**T, if UPLO = 'U', or\n* A = L * D * L**T, if UPLO = 'L',\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* 1-by-1 and 2-by-2 diagonal blocks.\n*\n* 3. If some D(i,i)=0, so that D is exactly singular, then the\n* routine returns with INFO = i. Otherwise, the factored form of A\n* is used to estimate the condition number of the matrix A (see\n* argument RCOND). If the reciprocal of the condition number is\n* less than machine precision, the routine still goes on to solve\n* for X and compute error bounds as described below.\n*\n* 4. The system of equations is solved for X using the factored form\n* of A.\n*\n* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n* the routine will use iterative refinement to try to get a small\n* error and error bounds. Refinement calculates the residual to at\n* least twice the working precision.\n*\n* 6. If equilibration was used, the matrix X is premultiplied by\n* diag(R) so that it solves the original system before\n* equilibration.\n*\n\n* Arguments\n* =========\n*\n* Some optional parameters are bundled in the PARAMS array. These\n* settings determine how refinement is performed, but often the\n* defaults are acceptable. If the defaults are acceptable, users\n* can pass NPARAMS = 0 which prevents the source code from accessing\n* the PARAMS argument.\n*\n* FACT (input) CHARACTER*1\n* Specifies whether or not the factored form of the matrix A is\n* supplied on entry, and if not, whether the matrix A should be\n* equilibrated before it is factored.\n* = 'F': On entry, AF and IPIV contain the factored form of A.\n* If EQUED is not 'N', the matrix A has been\n* equilibrated with scaling factors given by S.\n* A, AF, and IPIV are not modified.\n* = 'N': The matrix A will be copied to AF and factored.\n* = 'E': The matrix A will be equilibrated if necessary, then\n* copied to AF and factored.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\n*\n* N (input) INTEGER\n* The number of linear equations, i.e., the order of the\n* 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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of A contains the upper triangular\n* part of the matrix A, and the strictly lower triangular\n* part of A is not referenced. If UPLO = 'L', the leading\n* 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 FACT = 'E' and EQUED = 'Y', A is overwritten by\n* diag(S)*A*diag(S).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n* If FACT = 'F', then AF is an input argument and on entry\n* contains the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n* If FACT = 'N', then AF is an output argument and on exit\n* returns the block diagonal matrix D and the multipliers\n* used to obtain the factor U or L from the factorization A =\n* U*D*U**T or A = L*D*L**T.\n*\n* LDAF (input) INTEGER\n* The leading dimension of the array AF. LDAF >= max(1,N).\n*\n* IPIV (input or output) INTEGER array, dimension (N)\n* If FACT = 'F', then IPIV is an input argument and on entry\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF. If IPIV(k) > 0,\n* then rows and columns k and IPIV(k) were interchanged and\n* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n* then rows and columns k+1 and -IPIV(k) were interchanged\n* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* If FACT = 'N', then IPIV is an output argument and on exit\n* contains details of the interchanges and the block\n* structure of D, as determined by DSYTRF.\n*\n* EQUED (input or output) CHARACTER*1\n* Specifies the form of equilibration that was done.\n* = 'N': No equilibration (always true if FACT = 'N').\n* = 'Y': Both row and column equilibration, i.e., A has been\n* replaced by diag(S) * A * diag(S).\n* EQUED is an input argument if FACT = 'F'; otherwise, it is an\n* output argument.\n*\n* S (input or output) DOUBLE PRECISION array, dimension (N)\n* The scale factors for A. If EQUED = 'Y', A is multiplied on\n* the left and right by diag(S). S is an input argument if FACT =\n* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n* = 'Y', each element of S must be positive. If S is output, each\n* element of S is a power of the radix. If S is input, each element\n* of S should be a power of the radix to ensure a reliable solution\n* and error estimates. Scaling by powers of the radix does not cause\n* rounding errors unless the result underflows or overflows.\n* Rounding errors during scaling lead to refining with a matrix that\n* is not equivalent to the input matrix, producing error estimates\n* that may not be reliable.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the N-by-NRHS right hand side matrix B.\n* On exit,\n* if EQUED = 'N', B is not modified;\n* if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n* If INFO = 0, the N-by-NRHS solution matrix X to the original\n* system of equations. Note that A and B are modified on exit if\n* EQUED .ne. 'N', and the solution to the equilibrated system is\n* inv(diag(S))*X.\n*\n* LDX (input) INTEGER\n* The leading dimension of the array X. LDX >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\n* Reciprocal scaled condition number. This is an estimate of the\n* reciprocal Skeel condition number of the matrix A after\n* equilibration (if done). If this is less than the machine\n* precision (in particular, if it is zero), the matrix is singular\n* to working precision. Note that the error may still be small even\n* if this number is very small and the matrix appears ill-\n* conditioned.\n*\n* RPVGRW (output) DOUBLE PRECISION\n* Reciprocal pivot growth. On exit, this contains the reciprocal\n* pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n* norm is used. If this is much less than 1, then the stability of\n* the LU factorization of the (equilibrated) matrix A could be poor.\n* This also means that the solution X, estimated condition numbers,\n* and error bounds could be unreliable. If factorization fails with\n* 0<INFO<=N, then this contains the reciprocal pivot growth factor\n* for the leading INFO columns of A.\n*\n* BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n* Componentwise relative backward error. This is the\n* componentwise relative backward error of each solution vector X(j)\n* (i.e., the smallest relative change in any element of A or B that\n* makes X(j) an exact solution).\n*\n* N_ERR_BNDS (input) INTEGER\n* Number of error bounds to return for each right hand side\n* and each type (normwise or componentwise). See ERR_BNDS_NORM and\n* ERR_BNDS_COMP below.\n*\n* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* normwise relative error, which is defined as follows:\n*\n* Normwise relative error in the ith solution vector:\n* max_j (abs(XTRUE(j,i) - X(j,i)))\n* ------------------------------\n* max_j abs(X(j,i))\n*\n* The array is indexed by the type of error information as described\n* below. There currently are up to three pieces of information\n* returned.\n*\n* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_NORM(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated normwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*A, where S scales each row by a power of the\n* radix so all absolute row sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n* For each right-hand side, this array contains information about\n* various error bounds and condition numbers corresponding to the\n* componentwise relative error, which is defined as follows:\n*\n* Componentwise relative error in the ith solution vector:\n* abs(XTRUE(j,i) - X(j,i))\n* max_j ----------------------\n* abs(X(j,i))\n*\n* The array is indexed by the right-hand side i (on which the\n* componentwise relative error depends), and the type of error\n* information as described below. There currently are up to three\n* pieces of information returned for each right-hand side. If\n* componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n* the first (:,N_ERR_BNDS) entries are returned.\n*\n* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n* right-hand side.\n*\n* The second index in ERR_BNDS_COMP(:,err) contains the following\n* three fields:\n* err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n* reciprocal condition number is less than the threshold\n* sqrt(n) * dlamch('Epsilon').\n*\n* err = 2 \"Guaranteed\" error bound: The estimated forward error,\n* almost certainly within a factor of 10 of the true error\n* so long as the next entry is greater than the threshold\n* sqrt(n) * dlamch('Epsilon'). This error bound should only\n* be trusted if the previous boolean is true.\n*\n* err = 3 Reciprocal condition number: Estimated componentwise\n* reciprocal condition number. Compared with the threshold\n* sqrt(n) * dlamch('Epsilon') to determine if the error\n* estimate is \"guaranteed\". These reciprocal condition\n* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n* appropriately scaled matrix Z.\n* Let Z = S*(A*diag(x)), where x is the solution for the\n* current right-hand side and S scales each row of\n* A*diag(x) by a power of the radix so all absolute row\n* sums of Z are approximately 1.\n*\n* See Lapack Working Note 165 for further details and extra\n* cautions.\n*\n* NPARAMS (input) INTEGER\n* Specifies the number of parameters set in PARAMS. If .LE. 0, the\n* PARAMS array is never referenced and default values are used.\n*\n* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n* Specifies algorithm parameters. If an entry is .LT. 0.0, then\n* that entry will be filled with default value used for that\n* parameter. Only positions up to NPARAMS are accessed; defaults\n* are used for higher-numbered parameters.\n*\n* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n* refinement or not.\n* Default: 1.0D+0\n* = 0.0 : No refinement is performed, and no error bounds are\n* computed.\n* = 1.0 : Use the extra-precise refinement algorithm.\n* (other values are reserved for future use)\n*\n* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n* computations allowed for refinement.\n* Default: 10\n* Aggressive: Set to 100 to permit convergence using approximate\n* factorizations or factorizations other than LU. If\n* the factorization uses a technique other than\n* Gaussian elimination, the guarantees in\n* err_bnds_norm and err_bnds_comp may no longer be\n* trustworthy.\n*\n* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n* will attempt to find a solution with small componentwise\n* relative error in the double-precision algorithm. Positive\n* is true, 0.0 is false.\n* Default: 1.0 (attempt componentwise convergence)\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: Successful exit. The solution to every right-hand side is\n* guaranteed.\n* < 0: If INFO = -i, the i-th argument had an illegal value\n* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n* has been completed, but the factor U is exactly singular, so\n* the solution and error bounds could not be computed. RCOND = 0\n* is returned.\n* = N+J: The solution corresponding to the Jth right-hand side is\n* not guaranteed. The solutions corresponding to other right-\n* hand sides K with K > J may not be guaranteed as well, but\n* only the first such right-hand side is reported. If a small\n* componentwise error is not requested (PARAMS(3) = 0.0) then\n* the Jth right-hand side is the first with a normwise error\n* bound that is not guaranteed (the smallest J such\n* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n* the Jth right-hand side is the first with either a normwise or\n* componentwise error bound that is not guaranteed (the smallest\n* J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n* ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n* about all of the right-hand sides check ERR_BNDS_NORM or\n* ERR_BNDS_COMP.\n*\n\n* ==================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_fact = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
- rb_af = argv[3];
- rb_ipiv = argv[4];
- rb_equed = argv[5];
- rb_s = argv[6];
- rb_b = argv[7];
- rb_params = argv[8];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (8th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- fact = StringValueCStr(rb_fact)[0];
- equed = StringValueCStr(rb_equed)[0];
- n_err_bnds = 3;
- if (!NA_IsNArray(rb_params))
- rb_raise(rb_eArgError, "params (9th argument) must be NArray");
- if (NA_RANK(rb_params) != 1)
- rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
- nparams = NA_SHAPE0(rb_params);
- if (NA_TYPE(rb_params) != NA_DFLOAT)
- rb_params = na_change_type(rb_params, NA_DFLOAT);
- params = NA_PTR_TYPE(rb_params, doublereal*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (7th argument) must be NArray");
- if (NA_RANK(rb_s) != 1)
- rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of ipiv");
- if (NA_TYPE(rb_s) != NA_DFLOAT)
- rb_s = na_change_type(rb_s, NA_DFLOAT);
- s = NA_PTR_TYPE(rb_s, doublereal*);
- if (!NA_IsNArray(rb_af))
- rb_raise(rb_eArgError, "af (4th argument) must be NArray");
- if (NA_RANK(rb_af) != 2)
- rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_af) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 0 of ipiv");
- ldaf = NA_SHAPE0(rb_af);
- if (NA_TYPE(rb_af) != NA_DCOMPLEX)
- rb_af = na_change_type(rb_af, NA_DCOMPLEX);
- af = NA_PTR_TYPE(rb_af, doublecomplex*);
- ldx = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldx;
- shape[1] = nrhs;
- rb_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_norm = NA_PTR_TYPE(rb_err_bnds_norm, doublereal*);
- {
- int shape[2];
- shape[0] = nrhs;
- shape[1] = n_err_bnds;
- rb_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
- }
- err_bnds_comp = NA_PTR_TYPE(rb_err_bnds_comp, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldaf;
- shape[1] = n;
- rb_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- af_out__ = NA_PTR_TYPE(rb_af_out__, doublecomplex*);
- MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rb_af));
- rb_af = rb_af_out__;
- af = af_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv_out__ = NA_PTR_TYPE(rb_ipiv_out__, integer*);
- MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rb_ipiv));
- rb_ipiv = rb_ipiv_out__;
- ipiv = ipiv_out__;
- {
- int shape[1];
- shape[0] = n;
- rb_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s_out__ = NA_PTR_TYPE(rb_s_out__, doublereal*);
- MEMCPY(s_out__, s, doublereal, NA_TOTAL(rb_s));
- rb_s = rb_s_out__;
- s = s_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[1];
- shape[0] = nparams;
- rb_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- params_out__ = NA_PTR_TYPE(rb_params_out__, doublereal*);
- MEMCPY(params_out__, params, doublereal, NA_TOTAL(rb_params));
- rb_params = rb_params_out__;
- params = params_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- zsysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_rpvgrw = rb_float_new((double)rpvgrw);
- rb_info = INT2NUM(info);
- rb_equed = rb_str_new(&equed,1);
- return rb_ary_new3(14, rb_x, rb_rcond, rb_rpvgrw, rb_berr, rb_err_bnds_norm, rb_err_bnds_comp, rb_info, rb_a, rb_af, rb_ipiv, rb_equed, rb_s, rb_b, rb_params);
-}
-
-void
-init_lapack_zsysvxx(VALUE mLapack){
- rb_define_module_function(mLapack, "zsysvxx", rb_zsysvxx, -1);
-}
diff --git a/zsyswapr.c b/zsyswapr.c
deleted file mode 100644
index 7376f23..0000000
--- a/zsyswapr.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsyswapr_(char *uplo, integer *n, doublecomplex *a, integer *i1, integer *i2);
-
-static VALUE
-rb_zsyswapr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_i1;
- integer i1;
- VALUE rb_i2;
- integer i2;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a = NumRu::Lapack.zsyswapr( uplo, a, i1, i2)\n or\n NumRu::Lapack.zsyswapr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYSWAPR( UPLO, N, A, I1, I2)\n\n* Purpose\n* =======\n*\n* ZSYSWAPR applies an elementary permutation on the rows and the columns of\n* a symmetric matrix.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* I1 (input) INTEGER\n* Index of the first row to swap\n*\n* I2 (input) INTEGER\n* Index of the second row to swap\n*\n\n* =====================================================================\n*\n* ..\n* .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n DOUBLE COMPLEX TMP\n*\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL ZSWAP\n* ..\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_i1 = argv[2];
- rb_i2 = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- i1 = NUM2INT(rb_i1);
- i2 = NUM2INT(rb_i2);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zsyswapr_(&uplo, &n, a, &i1, &i2);
-
- return rb_a;
-}
-
-void
-init_lapack_zsyswapr(VALUE mLapack){
- rb_define_module_function(mLapack, "zsyswapr", rb_zsyswapr, -1);
-}
diff --git a/zsytf2.c b/zsytf2.c
deleted file mode 100644
index 5579ad3..0000000
--- a/zsytf2.c
+++ /dev/null
@@ -1,66 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsytf2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, integer *info);
-
-static VALUE
-rb_zsytf2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, info, a = NumRu::Lapack.zsytf2( uplo, a)\n or\n NumRu::Lapack.zsytf2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTF2 computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method:\n*\n* A = U*D*U' or A = L*D*L'\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, U' is the transpose of U, and D is symmetric and\n* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the unblocked version of the algorithm, calling Level 2 BLAS.\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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -k, the k-th argument had an illegal value\n* > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* 09-29-06 - patch from\n* Bobby Cheng, MathWorks\n*\n* Replace l.209 and l.377\n* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n* by\n* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n* Company\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zsytf2_(&uplo, &n, a, &lda, ipiv, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ipiv, rb_info, rb_a);
-}
-
-void
-init_lapack_zsytf2(VALUE mLapack){
- rb_define_module_function(mLapack, "zsytf2", rb_zsytf2, -1);
-}
diff --git a/zsytrf.c b/zsytrf.c
deleted file mode 100644
index 3bbb1ac..0000000
--- a/zsytrf.c
+++ /dev/null
@@ -1,78 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsytrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zsytrf(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ipiv, work, info, a = NumRu::Lapack.zsytrf( uplo, a, lwork)\n or\n NumRu::Lapack.zsytrf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRF computes the factorization of a complex symmetric matrix A\n* using the Bunch-Kaufman diagonal pivoting method. The form of the\n* factorization is\n*\n* A = U*D*U**T or A = L*D*L**T\n*\n* where U (or L) is a product of permutation and unit upper (lower)\n* triangular matrices, and D is symmetric and block diagonal with\n* with 1-by-1 and 2-by-2 diagonal blocks.\n*\n* This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A is stored;\n* = 'L': Lower triangle of A is stored.\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, the block diagonal matrix D and the multipliers used\n* to obtain the factor U or L (see below for further details).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (output) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D.\n* If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n* interchanged and D(k,k) is a 1-by-1 diagonal block.\n* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n* WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n* LWORK (input) INTEGER\n* The length of WORK. LWORK >=1. For best performance\n* LWORK >= N*NB, where NB is the block size returned by ILAENV.\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* > 0: if INFO = i, D(i,i) is exactly zero. The factorization\n* has been completed, but the block diagonal matrix D is\n* exactly singular, and division by zero will occur if it\n* is used to solve a system of equations.\n*\n\n* Further Details\n* ===============\n*\n* If UPLO = 'U', then A = U*D*U', where\n* U = P(n)*U(n)* ... *P(k)U(k)* ...,\n* i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I v 0 ) k-s\n* U(k) = ( 0 I 0 ) s\n* ( 0 0 I ) n-k\n* k-s s n-k\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n* and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n* If UPLO = 'L', then A = L*D*L', where\n* L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n* that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n* ( I 0 0 ) k-1\n* L(k) = ( 0 I 0 ) s\n* ( 0 v I ) n-k-s+1\n* k-1 s n-k-s+1\n*\n* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLASYF, ZSYTF2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_lwork = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = n;
- rb_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zsytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_ipiv, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zsytrf(VALUE mLapack){
- rb_define_module_function(mLapack, "zsytrf", rb_zsytrf, -1);
-}
diff --git a/zsytri.c b/zsytri.c
deleted file mode 100644
index 9275f65..0000000
--- a/zsytri.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsytri_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zsytri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zsytri( uplo, a, ipiv)\n or\n NumRu::Lapack.zsytri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRI computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* ZSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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 block diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (2*n));
-
- zsytri_(&uplo, &n, a, &lda, ipiv, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zsytri(VALUE mLapack){
- rb_define_module_function(mLapack, "zsytri", rb_zsytri, -1);
-}
diff --git a/zsytri2.c b/zsytri2.c
deleted file mode 100644
index ad167ec..0000000
--- a/zsytri2.c
+++ /dev/null
@@ -1,81 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsytri2_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zsytri2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- integer c__1;
- integer nb;
- integer c__m1;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer lwork;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zsytri2( uplo, a, ipiv)\n or\n NumRu::Lapack.zsytri2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* ZSYTRF. ZSYTRI2 sets the LEADING DIMENSION of the workspace\n* before calling ZSYTRI2X that actually computes the inverse.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n* On entry, the NB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NB structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) DOUBLE COMPLEX array, dimension (N+NB+1)*(NB+3)\n*\n* LWORK (input) INTEGER\n* The dimension of the array WORK.\n* WORK is size >= (N+NB+1)*(NB+3)\n* If LDWORK = -1, then a workspace query is assumed; the routine\n* calculates:\n* - the optimal size of the WORK array, returns\n* this value as the first entry of the WORK array,\n* - and no error message related to LDWORK 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* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL ZSYTRI2X\n* ..\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- c__1 = 1;
- c__m1 = -1;
- uplo = StringValueCStr(rb_uplo)[0];
- nb = ilaenv_(&c__1, "ZSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
- lwork = (n+nb+1)*(nb+3);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (lwork));
-
- zsytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zsytri2(VALUE mLapack){
- rb_define_module_function(mLapack, "zsytri2", rb_zsytri2, -1);
-}
diff --git a/zsytri2x.c b/zsytri2x.c
deleted file mode 100644
index 497c096..0000000
--- a/zsytri2x.c
+++ /dev/null
@@ -1,77 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsytri2x_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *work, integer *nb, integer *info);
-
-static VALUE
-rb_zsytri2x(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_nb;
- integer nb;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zsytri2x( uplo, a, ipiv, nb)\n or\n NumRu::Lapack.zsytri2x # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRI2X computes the inverse of a complex symmetric indefinite matrix\n* A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n* ZSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n* On entry, the NNB diagonal matrix D and the multipliers\n* used to obtain the factor U or L as computed by ZSYTRF.\n*\n* On exit, if INFO = 0, the (symmetric) inverse of the original\n* matrix. If UPLO = 'U', the upper triangular part of the\n* inverse is formed and the part of A below the diagonal is not\n* referenced; if UPLO = 'L' the lower triangular part of the\n* inverse is formed and the part of A above the diagonal is\n* not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the NNB structure of D\n* as determined by ZSYTRF.\n*\n* WORK (workspace) DOUBLE COMPLEX array, dimension (N+NNB+1,NNB+3)\n*\n* NB (input) INTEGER\n* Block size\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, D(i,i) = 0; the matrix is singular and its\n* inverse could not be computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_nb = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- nb = NUM2INT(rb_nb);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n+nb+1)*(nb+3));
-
- zsytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zsytri2x(VALUE mLapack){
- rb_define_module_function(mLapack, "zsytri2x", rb_zsytri2x, -1);
-}
diff --git a/zsytrs.c b/zsytrs.c
deleted file mode 100644
index be0c61b..0000000
--- a/zsytrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsytrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_zsytrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zsytrs( uplo, a, ipiv, b)\n or\n NumRu::Lapack.zsytrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRS solves a system of linear equations A*X = B with a complex\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSYTRF.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- zsytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zsytrs(VALUE mLapack){
- rb_define_module_function(mLapack, "zsytrs", rb_zsytrs, -1);
-}
diff --git a/zsytrs2.c b/zsytrs2.c
deleted file mode 100644
index 98755fb..0000000
--- a/zsytrs2.c
+++ /dev/null
@@ -1,87 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zsytrs2_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, real *work, integer *info);
-
-static VALUE
-rb_zsytrs2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ipiv;
- integer *ipiv;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- real *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.zsytrs2( uplo, a, ipiv, b)\n or\n NumRu::Lapack.zsytrs2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZSYTRS2 solves a system of linear equations A*X = B with a real\n* symmetric matrix A using the factorization A = U*D*U**T or\n* A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the details of the factorization are stored\n* as an upper or lower triangular matrix.\n* = 'U': Upper triangular, form is A = U*D*U**T;\n* = 'L': Lower triangular, form is A = L*D*L**T.\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* A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n* The block diagonal matrix D and the multipliers used to\n* obtain the factor U or L as computed by ZSYTRF.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* IPIV (input) INTEGER array, dimension (N)\n* Details of the interchanges and the block structure of D\n* as determined by ZSYTRF.\n*\n* B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* WORK (workspace) REAL 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_ipiv = argv[2];
- rb_b = argv[3];
-
- if (!NA_IsNArray(rb_ipiv))
- rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
- if (NA_RANK(rb_ipiv) != 1)
- rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_ipiv);
- if (NA_TYPE(rb_ipiv) != NA_LINT)
- rb_ipiv = na_change_type(rb_ipiv, NA_LINT);
- ipiv = NA_PTR_TYPE(rb_ipiv, integer*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- work = ALLOC_N(real, (n));
-
- zsytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_zsytrs2(VALUE mLapack){
- rb_define_module_function(mLapack, "zsytrs2", rb_zsytrs2, -1);
-}
diff --git a/ztbcon.c b/ztbcon.c
deleted file mode 100644
index 827d372..0000000
--- a/ztbcon.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztbcon_(char *norm, char *uplo, char *diag, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztbcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.ztbcon( norm, uplo, diag, kd, ab)\n or\n NumRu::Lapack.ztbcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTBCON estimates the reciprocal of the condition number of a\n* triangular band 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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 0.\n*\n* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- ztbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_ztbcon(VALUE mLapack){
- rb_define_module_function(mLapack, "ztbcon", rb_ztbcon, -1);
-}
diff --git a/ztbrfs.c b/ztbrfs.c
deleted file mode 100644
index df6551a..0000000
--- a/ztbrfs.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztbrfs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztbrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.ztbrfs( uplo, trans, diag, kd, ab, b, x)\n or\n NumRu::Lapack.ztbrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTBRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular band\n* coefficient matrix.\n*\n* The solution matrix X must be computed by ZTBTRS or some other\n* means before entering this routine. ZTBRFS 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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of the array. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
- rb_x = argv[6];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (7th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- ztbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_ztbrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ztbrfs", rb_ztbrfs, -1);
-}
diff --git a/ztbtrs.c b/ztbtrs.c
deleted file mode 100644
index 069c663..0000000
--- a/ztbtrs.c
+++ /dev/null
@@ -1,84 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztbtrs_(char *uplo, char *trans, char *diag, integer *n, integer *kd, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ztbtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_kd;
- integer kd;
- VALUE rb_ab;
- doublecomplex *ab;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldab;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ztbtrs( uplo, trans, diag, kd, ab, b)\n or\n NumRu::Lapack.ztbtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZTBTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular band matrix of order N, and B is an\n* N-by-NRHS matrix. A check is made to verify that A is nonsingular.\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)\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* KD (input) INTEGER\n* The number of superdiagonals or subdiagonals of the\n* triangular band matrix A. KD >= 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* AB (input) COMPLEX*16 array, dimension (LDAB,N)\n* The upper or lower triangular band matrix A, stored in the\n* first kd+1 rows of AB. The j-th column of A is stored\n* in the j-th column of the array AB as follows:\n* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n* If DIAG = 'U', the diagonal elements of A are not referenced\n* and are assumed to be 1.\n*\n* LDAB (input) INTEGER\n* The leading dimension of the array AB. LDAB >= KD+1.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_kd = argv[3];
- rb_ab = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_ab))
- rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
- if (NA_RANK(rb_ab) != 2)
- rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_ab);
- ldab = NA_SHAPE0(rb_ab);
- if (NA_TYPE(rb_ab) != NA_DCOMPLEX)
- rb_ab = na_change_type(rb_ab, NA_DCOMPLEX);
- ab = NA_PTR_TYPE(rb_ab, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- kd = NUM2INT(rb_kd);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ztbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ztbtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ztbtrs", rb_ztbtrs, -1);
-}
diff --git a/ztfsm.c b/ztfsm.c
deleted file mode 100644
index 03aa03d..0000000
--- a/ztfsm.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztfsm_(char *transr, char *side, char *uplo, char *trans, char *diag, integer *m, integer *n, doublecomplex *alpha, doublecomplex *a, doublecomplex *b, integer *ldb);
-
-static VALUE
-rb_ztfsm(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_m;
- integer m;
- VALUE rb_alpha;
- doublecomplex alpha;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldb;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n b = NumRu::Lapack.ztfsm( transr, side, uplo, trans, diag, m, alpha, a, b)\n or\n NumRu::Lapack.ztfsm # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n* Purpose\n* =======\n*\n* Level 3 BLAS like routine for A in RFP Format.\n*\n* ZTFSM solves the matrix equation\n*\n* op( A )*X = alpha*B or X*op( A ) = alpha*B\n*\n* where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n* non-unit, upper or lower triangular matrix and op( A ) is one of\n*\n* op( A ) = A or op( A ) = conjg( A' ).\n*\n* A is in Rectangular Full Packed (RFP) Format.\n*\n* The matrix X is overwritten on B.\n*\n\n* Arguments\n* ==========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal Form of RFP A is stored;\n* = 'C': The Conjugate-transpose Form of RFP A is stored.\n*\n* SIDE (input) CHARACTER*1\n* On entry, SIDE specifies whether op( A ) appears on the left\n* or right of X as follows:\n*\n* SIDE = 'L' or 'l' op( A )*X = alpha*B.\n*\n* SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n*\n* Unchanged on exit.\n*\n* UPLO (input) CHARACTER*1\n* On entry, UPLO specifies whether the RFP matrix A came from\n* an upper or lower triangular matrix as follows:\n* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n*\n* Unchanged on exit.\n*\n* TRANS (input) CHARACTER*1\n* On entry, TRANS specifies the form of op( A ) to be used\n* in the matrix multiplication as follows:\n*\n* TRANS = 'N' or 'n' op( A ) = A.\n*\n* TRANS = 'C' or 'c' op( A ) = conjg( A' ).\n*\n* Unchanged on exit.\n*\n* DIAG (input) CHARACTER*1\n* On entry, DIAG specifies whether or not RFP A is unit\n* triangular as follows:\n*\n* DIAG = 'U' or 'u' A is assumed to be unit triangular.\n*\n* DIAG = 'N' or 'n' A is not assumed to be unit\n* triangular.\n*\n* Unchanged on exit.\n*\n* M (input) INTEGER\n* On entry, M specifies the number of rows of B. M must be at\n* least zero.\n* Unchanged on exit.\n*\n* N (input) INTEGER\n* On entry, N specifies the number of columns of B. N must be\n* at least zero.\n* Unchanged on exit.\n*\n* ALPHA (input) COMPLEX*16\n* On entry, ALPHA specifies the scalar alpha. When alpha is\n* zero then A is not referenced and B need not be set before\n* entry.\n* Unchanged on exit.\n*\n* A (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n* RFP Format is described by TRANSR, UPLO and N as follows:\n* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n* defined when TRANSR = 'N'. The contents of RFP A are defined\n* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n* elements of upper packed A either in normal or\n* conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n* the NT elements of lower packed A either in normal or\n* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and is N when is odd.\n* See the Note below for more details. Unchanged on exit.\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* Before entry, the leading m by n part of the array B must\n* contain the right-hand side matrix B, and on exit is\n* overwritten by the solution matrix X.\n*\n* LDB (input) INTEGER\n* On entry, LDB specifies the first dimension of B as declared\n* in the calling (sub) program. LDB must be at least\n* max( 1, m ).\n* Unchanged on exit.\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_transr = argv[0];
- rb_side = argv[1];
- rb_uplo = argv[2];
- rb_trans = argv[3];
- rb_diag = argv[4];
- rb_m = argv[5];
- rb_alpha = argv[6];
- rb_a = argv[7];
- rb_b = argv[8];
-
- transr = StringValueCStr(rb_transr)[0];
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (9th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- m = NUM2INT(rb_m);
- uplo = StringValueCStr(rb_uplo)[0];
- alpha.r = NUM2DBL(rb_funcall(rb_alpha, rb_intern("real"), 0));
- alpha.i = NUM2DBL(rb_funcall(rb_alpha, rb_intern("imag"), 0));
- trans = StringValueCStr(rb_trans)[0];
- diag = StringValueCStr(rb_diag)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (8th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ztfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);
-
- return rb_b;
-}
-
-void
-init_lapack_ztfsm(VALUE mLapack){
- rb_define_module_function(mLapack, "ztfsm", rb_ztfsm, -1);
-}
diff --git a/ztftri.c b/ztftri.c
deleted file mode 100644
index 5645c25..0000000
--- a/ztftri.c
+++ /dev/null
@@ -1,67 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztftri_(char *transr, char *uplo, char *diag, integer *n, doublecomplex *a, integer *info);
-
-static VALUE
-rb_ztftri(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ztftri( transr, uplo, diag, n, a)\n or\n NumRu::Lapack.ztftri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n* Purpose\n* =======\n*\n* ZTFTRI computes the inverse of a triangular matrix A stored in RFP\n* format.\n*\n* This is a Level 3 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': The Normal TRANSR of RFP A is stored;\n* = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\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* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n* On entry, the triangular matrix A in RFP format. RFP format\n* is described by TRANSR, UPLO, and N as follows: If TRANSR =\n* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n* the Conjugate-transpose of RFP A as defined when\n* TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n* follows: If UPLO = 'U' the RFP A contains the nt elements of\n* upper packed A; If UPLO = 'L' the RFP A contains the nt\n* elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n* even and N is odd. See the Note below for more details.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same 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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_a = argv[4];
-
- transr = StringValueCStr(rb_transr)[0];
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = NUM2INT(rb_n);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 1)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_a) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ztftri_(&transr, &uplo, &diag, &n, a, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ztftri(VALUE mLapack){
- rb_define_module_function(mLapack, "ztftri", rb_ztftri, -1);
-}
diff --git a/ztfttp.c b/ztfttp.c
deleted file mode 100644
index 21b7abb..0000000
--- a/ztfttp.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztfttp_(char *transr, char *uplo, integer *n, doublecomplex *arf, doublecomplex *ap, integer *info);
-
-static VALUE
-rb_ztfttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_arf;
- doublecomplex *arf;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.ztfttp( transr, uplo, n, arf)\n or\n NumRu::Lapack.ztfttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZTFTTP copies a triangular matrix A from rectangular full packed\n* format (TF) to standard packed format (TP).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_arf = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_arf) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_arf) != NA_DCOMPLEX)
- rb_arf = na_change_type(rb_arf, NA_DCOMPLEX);
- arf = NA_PTR_TYPE(rb_arf, doublecomplex*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_ap = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
-
- ztfttp_(&transr, &uplo, &n, arf, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_ztfttp(VALUE mLapack){
- rb_define_module_function(mLapack, "ztfttp", rb_ztfttp, -1);
-}
diff --git a/ztfttr.c b/ztfttr.c
deleted file mode 100644
index e50aea3..0000000
--- a/ztfttr.c
+++ /dev/null
@@ -1,61 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztfttr_(char *transr, char *uplo, integer *n, doublecomplex *arf, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ztfttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_arf;
- doublecomplex *arf;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
-
- integer ldarf;
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.ztfttr( transr, uplo, arf)\n or\n NumRu::Lapack.ztfttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTFTTR copies a triangular matrix A from rectangular full packed\n* format (TF) to standard full format (TR).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF is in Normal format;\n* = 'C': ARF is in Conjugate-transpose format;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\n*\n* A (output) COMPLEX*16 array, dimension ( LDA, N ) \n* On exit, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\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 = -i, the i-th argument had an illegal value\n*\n\n* Further Details\n* ===============\n*\n* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_arf = argv[2];
-
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_arf))
- rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
- if (NA_RANK(rb_arf) != 1)
- rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
- ldarf = NA_SHAPE0(rb_arf);
- if (NA_TYPE(rb_arf) != NA_DCOMPLEX)
- rb_arf = na_change_type(rb_arf, NA_DCOMPLEX);
- arf = NA_PTR_TYPE(rb_arf, doublecomplex*);
- n = ((int)sqrtf(8*ldarf+1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
-
- ztfttr_(&transr, &uplo, &n, arf, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_ztfttr(VALUE mLapack){
- rb_define_module_function(mLapack, "ztfttr", rb_ztfttr, -1);
-}
diff --git a/ztgevc.c b/ztgevc.c
deleted file mode 100644
index 04ed7ae..0000000
--- a/ztgevc.c
+++ /dev/null
@@ -1,137 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgevc_(char *side, char *howmny, logical *select, integer *n, doublecomplex *s, integer *lds, doublecomplex *p, integer *ldp, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztgevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_s;
- doublecomplex *s;
- VALUE rb_p;
- doublecomplex *p;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_vl_out__;
- doublecomplex *vl_out__;
- VALUE rb_vr_out__;
- doublecomplex *vr_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer lds;
- integer ldp;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, vl, vr = NumRu::Lapack.ztgevc( side, howmny, select, s, p, vl, vr)\n or\n NumRu::Lapack.ztgevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTGEVC computes some or all of the right and/or left eigenvectors of\n* a pair of complex matrices (S,P), where S and P are upper triangular.\n* Matrix pairs of this type are produced by the generalized Schur\n* factorization of a complex matrix pair (A,B):\n* \n* A = Q*S*Z**H, B = Q*P*Z**H\n* \n* as computed by ZGGHRD + ZHGEQZ.\n* \n* The right eigenvector x and the left eigenvector y of (S,P)\n* corresponding to an eigenvalue w are defined by:\n* \n* S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n* \n* where y**H denotes the conjugate tranpose of y.\n* The eigenvalues are not input to this routine, but are computed\n* directly from the diagonal elements of S and P.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n* where Z and Q are input matrices.\n* If Q and Z are the unitary factors from the generalized Schur\n* factorization of a matrix pair (A,B), then Z*X and Q*Y\n* are the matrices of right and left eigenvectors of (A,B).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed by the matrices in VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* specified by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY='S', SELECT specifies the eigenvectors to be\n* computed. The eigenvector corresponding to the j-th\n* eigenvalue is computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrices S and P. N >= 0.\n*\n* S (input) COMPLEX*16 array, dimension (LDS,N)\n* The upper triangular matrix S from a generalized Schur\n* factorization, as computed by ZHGEQZ.\n*\n* LDS (input) INTEGER\n* The leading dimension of array S. LDS >= max(1,N).\n*\n* P (input) COMPLEX*16 array, dimension (LDP,N)\n* The upper triangular matrix P from a generalized Schur\n* factorization, as computed by ZHGEQZ. P must have real\n* diagonal elements.\n*\n* LDP (input) INTEGER\n* The leading dimension of array P. LDP >= max(1,N).\n*\n* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q\n* of left Schur vectors returned by ZHGEQZ).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VL, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n*\n* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Z\n* of right Schur vectors returned by ZHGEQZ).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n* if HOWMNY = 'B', the matrix Z*X;\n* if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n* SELECT, stored consecutively in the columns of\n* VR, in the same order as their eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B', LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one column.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (2*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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_s = argv[3];
- rb_p = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_DCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_p))
- rb_raise(rb_eArgError, "p (5th argument) must be NArray");
- if (NA_RANK(rb_p) != 2)
- rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_p);
- ldp = NA_SHAPE0(rb_p);
- if (NA_TYPE(rb_p) != NA_DCOMPLEX)
- rb_p = na_change_type(rb_p, NA_DCOMPLEX);
- p = NA_PTR_TYPE(rb_p, doublecomplex*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_DCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- if (!NA_IsNArray(rb_s))
- rb_raise(rb_eArgError, "s (4th argument) must be NArray");
- if (NA_RANK(rb_s) != 2)
- rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_s) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 1 of p");
- lds = NA_SHAPE0(rb_s);
- if (NA_TYPE(rb_s) != NA_DCOMPLEX)
- rb_s = na_change_type(rb_s, NA_DCOMPLEX);
- s = NA_PTR_TYPE(rb_s, doublecomplex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of p");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublecomplex*);
- MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, doublecomplex*);
- MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (2*n));
-
- ztgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_m, rb_info, rb_vl, rb_vr);
-}
-
-void
-init_lapack_ztgevc(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgevc", rb_ztgevc, -1);
-}
diff --git a/ztgex2.c b/ztgex2.c
deleted file mode 100644
index 4a57165..0000000
--- a/ztgex2.c
+++ /dev/null
@@ -1,152 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgex2_(logical *wantq, logical *wantz, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z, integer *ldz, integer *j1, integer *info);
-
-static VALUE
-rb_ztgex2(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ldz;
- integer ldz;
- VALUE rb_j1;
- integer j1;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z = NumRu::Lapack.ztgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1)\n or\n NumRu::Lapack.ztgex2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n* Purpose\n* =======\n*\n* ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n* in an upper triangular matrix pair (A, B) by an unitary equivalence\n* transformation.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 arrays, dimensions (LDA,N)\n* On entry, the matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 arrays, dimensions (LDB,N)\n* On entry, the matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n* the updated matrix Q.\n* Not referenced if WANTQ = .FALSE..\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n* the updated matrix Z.\n* Not referenced if WANTZ = .FALSE..\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* J1 (input) INTEGER\n* The index to the first block (A11, B11).\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. \n*\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* In the current code both weak and strong stability tests are\n* performed. The user can omit the strong stability test by changing\n* the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n* details.\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n* Department of Computing Science, Umea University, S-901 87 Umea,\n* Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n* Numerical Algorithms, 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_ldq = argv[5];
- rb_z = argv[6];
- rb_ldz = argv[7];
- rb_j1 = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- wantz = (rb_wantz == Qtrue);
- ldz = NUM2INT(rb_ldz);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- j1 = NUM2INT(rb_j1);
- wantq = (rb_wantq == Qtrue);
- ldq = NUM2INT(rb_ldq);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != (wantq ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", wantq ? n : 0);
- if (NA_SHAPE0(rb_q) != (wantq ? ldq : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", wantq ? ldq : 0);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != (wantq ? n : 0))
- rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantq ? n : 0);
- if (NA_SHAPE0(rb_z) != (wantq ? ldz : 0))
- rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantq ? ldz : 0);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = wantq ? ldq : 0;
- shape[1] = wantq ? n : 0;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = wantq ? ldz : 0;
- shape[1] = wantq ? n : 0;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- ztgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_ztgex2(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgex2", rb_ztgex2, -1);
-}
diff --git a/ztgexc.c b/ztgexc.c
deleted file mode 100644
index 763b763..0000000
--- a/ztgexc.c
+++ /dev/null
@@ -1,153 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgexc_(logical *wantq, logical *wantz, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *q, integer *ldq, doublecomplex *z, integer *ldz, integer *ifst, integer *ilst, integer *info);
-
-static VALUE
-rb_ztgexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_ldq;
- integer ldq;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a, b, q, z, ilst = NumRu::Lapack.ztgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst)\n or\n NumRu::Lapack.ztgexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* ZTGEXC reorders the generalized Schur decomposition of a complex\n* matrix pair (A,B), using an unitary equivalence transformation\n* (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n* row index IFST is moved to row ILST.\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n* Optionally, the matrices Q and Z of generalized Schur vectors are\n* updated.\n*\n* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n\n* Arguments\n* =========\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the upper triangular matrix A in the pair (A, B).\n* On exit, the updated matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the upper triangular matrix B in the pair (A, B).\n* On exit, the updated matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if WANTQ = .TRUE., the unitary matrix Q.\n* On exit, the updated matrix Q.\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1;\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., the unitary matrix Z.\n* On exit, the updated matrix Z.\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1;\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* IFST (input) INTEGER\n* ILST (input/output) INTEGER\n* Specify the reordering of the diagonal blocks of (A, B).\n* The block with row index IFST is moved to row ILST, by a\n* sequence of swapping between adjacent blocks.\n*\n* INFO (output) INTEGER\n* =0: Successful exit.\n* <0: if INFO = -i, the i-th argument had an illegal value.\n* =1: The transformed matrix pair (A, B) would be too far\n* from generalized Schur form; the problem is ill-\n* conditioned. (A, B) may have been partially reordered,\n* and ILST points to the first row of the current\n* position of the block being moved.\n*\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; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n INTEGER HERE\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZTGEX2\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_wantq = argv[0];
- rb_wantz = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_q = argv[4];
- rb_ldq = argv[5];
- rb_z = argv[6];
- rb_ifst = argv[7];
- rb_ilst = argv[8];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- ldq = NUM2INT(rb_ldq);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (7th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- if (NA_SHAPE0(rb_q) != ldz)
- rb_raise(rb_eRuntimeError, "shape 0 of q must be the same as shape 0 of z");
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- ztgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, &info);
-
- rb_info = INT2NUM(info);
- rb_ilst = INT2NUM(ilst);
- return rb_ary_new3(6, rb_info, rb_a, rb_b, rb_q, rb_z, rb_ilst);
-}
-
-void
-init_lapack_ztgexc(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgexc", rb_ztgexc, -1);
-}
diff --git a/ztgsen.c b/ztgsen.c
deleted file mode 100644
index 416f11c..0000000
--- a/ztgsen.c
+++ /dev/null
@@ -1,213 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgsen_(integer *ijob, logical *wantq, logical *wantz, logical *select, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *alpha, doublecomplex *beta, doublecomplex *q, integer *ldq, doublecomplex *z, integer *ldz, integer *m, doublereal *pl, doublereal *pr, doublereal *dif, doublecomplex *work, integer *lwork, integer *iwork, integer *liwork, integer *info);
-
-static VALUE
-rb_ztgsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_wantq;
- logical wantq;
- VALUE rb_wantz;
- logical wantz;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_z;
- doublecomplex *z;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_liwork;
- integer liwork;
- VALUE rb_alpha;
- doublecomplex *alpha;
- VALUE rb_beta;
- doublecomplex *beta;
- VALUE rb_m;
- integer m;
- VALUE rb_pl;
- doublereal pl;
- VALUE rb_pr;
- doublereal pr;
- VALUE rb_dif;
- doublereal *dif;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_iwork;
- integer *iwork;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- VALUE rb_z_out__;
- doublecomplex *z_out__;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldq;
- integer ldz;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ztgsen( ijob, wantq, wantz, select, a, b, q, z, lwork, liwork)\n or\n NumRu::Lapack.ztgsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSEN reorders the generalized Schur decomposition of a complex\n* matrix pair (A, B) (in terms of an unitary equivalence trans-\n* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n* appears in the leading diagonal blocks of the pair (A,B). The leading\n* columns of Q and Z form unitary bases of the corresponding left and\n* right eigenspaces (deflating subspaces). (A, B) must be in\n* generalized Schur canonical form, that is, A and B are both upper\n* triangular.\n*\n* ZTGSEN also computes the generalized eigenvalues\n*\n* w(j)= ALPHA(j) / BETA(j)\n*\n* of the reordered matrix pair (A, B).\n*\n* Optionally, the routine computes estimates of reciprocal condition\n* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n* between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n* the selected cluster and the eigenvalues outside the cluster, resp.,\n* and norms of \"projections\" onto left and right eigenspaces w.r.t.\n* the selected cluster in the (1,1)-block.\n*\n*\n\n* Arguments\n* =========\n*\n* IJOB (input) integer\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (PL and PR) or the deflating subspaces\n* (Difu and Difl):\n* =0: Only reorder w.r.t. SELECT. No extras.\n* =1: Reciprocal of norms of \"projections\" onto left and right\n* eigenspaces w.r.t. the selected cluster (PL and PR).\n* =2: Upper bounds on Difu and Difl. F-norm-based estimate\n* (DIF(1:2)).\n* =3: Estimate of Difu and Difl. 1-norm-based estimate\n* (DIF(1:2)).\n* About 5 times as expensive as IJOB = 2.\n* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n* version to get it all.\n* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n* WANTQ (input) LOGICAL\n* .TRUE. : update the left transformation matrix Q;\n* .FALSE.: do not update Q.\n*\n* WANTZ (input) LOGICAL\n* .TRUE. : update the right transformation matrix Z;\n* .FALSE.: do not update Z.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select an eigenvalue w(j), SELECT(j) must be set to\n* .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrices A and B. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension(LDA,N)\n* On entry, the upper triangular matrix A, in generalized\n* Schur canonical form.\n* On exit, A is overwritten by the reordered matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension(LDB,N)\n* On entry, the upper triangular matrix B, in generalized\n* Schur canonical form.\n* On exit, B is overwritten by the reordered matrix B.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* ALPHA (output) COMPLEX*16 array, dimension (N)\n* BETA (output) COMPLEX*16 array, dimension (N)\n* The diagonal elements of A and B, respectively,\n* when the pair (A,B) has been reduced to generalized Schur\n* form. ALPHA(i)/BETA(i) i=1,...,N are the generalized\n* eigenvalues.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n* On exit, Q has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Q form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTQ = .FALSE., Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= 1.\n* If WANTQ = .TRUE., LDQ >= N.\n*\n* Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n* On exit, Z has been postmultiplied by the left unitary\n* transformation matrix which reorder (A, B); The leading M\n* columns of Z form orthonormal bases for the specified pair of\n* left eigenspaces (deflating subspaces).\n* If WANTZ = .FALSE., Z is not referenced.\n*\n* LDZ (input) INTEGER\n* The leading dimension of the array Z. LDZ >= 1.\n* If WANTZ = .TRUE., LDZ >= N.\n*\n* M (output) INTEGER\n* The dimension of the specified pair of left and right\n* eigenspaces, (deflating subspaces) 0 <= M <= N.\n*\n* PL (output) DOUBLE PRECISION\n* PR (output) DOUBLE PRECISION\n* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n* reciprocal of the norm of \"projections\" onto left and right\n* eigenspace with respect to the selected cluster.\n* 0 < PL, PR <= 1.\n* If M = 0 or M = N, PL = PR = 1.\n* If IJOB = 0, 2 or 3 PL, PR are not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (2).\n* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n* estimates of Difu and Difl, computed using reversed\n* communication with ZLACN2.\n* If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n* If IJOB = 0 or 1, DIF is not referenced.\n*\n* WORK (workspace/output) COMPLEX*16 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, 2 or 4, LWORK >= 2*M*(N-M)\n* If IJOB = 3 or 5, LWORK >= 4*M*(N-M)\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/output) INTEGER array, dimension (MAX(1,LIWORK))\n* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n* LIWORK (input) INTEGER\n* The dimension of the array IWORK. LIWORK >= 1.\n* If IJOB = 1, 2 or 4, LIWORK >= N+2;\n* If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n*\n* If LIWORK = -1, then a workspace query is assumed; the\n* routine only calculates the optimal size of the IWORK array,\n* returns this value as the first entry of the IWORK array, and\n* no error message related to LIWORK 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* =1: Reordering of (A, B) failed because the transformed\n* matrix pair (A, B) would be too far from generalized\n* Schur form; the problem is very ill-conditioned.\n* (A, B) may have been partially reordered.\n* If requested, 0 is returned in DIF(*), PL and PR.\n*\n*\n\n* Further Details\n* ===============\n*\n* ZTGSEN first collects the selected eigenvalues by computing unitary\n* U and W that move them to the top left corner of (A, B). In other\n* words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n*\n* U'*(A, B)*W = (A11 A12) (B11 B12) n1\n* ( 0 A22),( 0 B22) n2\n* n1 n2 n1 n2\n*\n* where N = n1+n2 and U' means the conjugate transpose of U. The first\n* n1 columns of U and W span the specified pair of left and right\n* eigenspaces (deflating subspaces) of (A, B).\n*\n* If (A, B) has been obtained from the generalized real Schur\n* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n* reordered generalized Schur form of (C, D) is given by\n*\n* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n* and the first n1 columns of Q*U and Z*W span the corresponding\n* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n* Note that if the selected eigenvalue is sufficiently ill-conditioned,\n* then its value may differ significantly from its value before\n* reordering.\n*\n* The reciprocal condition numbers of the left and right eigenspaces\n* spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n* be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n* The Difu and Difl are defined as:\n*\n* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n* and\n* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n* where sigma-min(Zu) is the smallest singular value of the\n* (2*n1*n2)-by-(2*n1*n2) matrix\n*\n* Zu = [ kron(In2, A11) -kron(A22', In1) ]\n* [ kron(In2, B11) -kron(B22', In1) ].\n*\n* Here, Inx is the identity matrix of size nx and A22' is the\n* transpose of A22. kron(X, Y) is the Kronecker product between\n* the matrices X and Y.\n*\n* When DIF(2) is small, small changes in (A, B) can cause large changes\n* in the deflating subspace. An approximate (asymptotic) bound on the\n* maximum angular error in the computed deflating subspaces is\n*\n* EPS * norm((A, B)) / DIF(2),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal norm of the projectors on the left and right\n* eigenspaces associated with (A11, B11) may be returned in PL and PR.\n* They are computed as follows. First we compute L and R so that\n* P*(A, B)*Q is block diagonal, where\n*\n* P = ( I -L ) n1 Q = ( I R ) n1\n* ( 0 I ) n2 and ( 0 I ) n2\n* n1 n2 n1 n2\n*\n* and (L, R) is the solution to the generalized Sylvester equation\n*\n* A11*R - L*A22 = -A12\n* B11*R - L*B22 = -B12\n*\n* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n* An approximate (asymptotic) bound on the average absolute error of\n* the selected eigenvalues is\n*\n* EPS * norm((A, B)) / PL.\n*\n* There are also global error bounds which valid for perturbations up\n* to a certain restriction: A lower bound (x) on the smallest\n* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n* (i.e. (A + E, B + F), is\n*\n* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n* An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n* (L', R') and unperturbed (L, R) left and right deflating subspaces\n* associated with the selected cluster in the (1,1)-blocks can be\n* bounded as\n*\n* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n* See LAPACK User's Guide section 4.11 or the following references\n* for more information.\n*\n* Note that if the default method for computing the Frobenius-norm-\n* based estimate DIF is not wanted (see ZLATDF), then the parameter\n* IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF\n* (IJOB = 2 will be used)). See ZTGSYL for more details.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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, No 1,\n* 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_ijob = argv[0];
- rb_wantq = argv[1];
- rb_wantz = argv[2];
- rb_select = argv[3];
- rb_a = argv[4];
- rb_b = argv[5];
- rb_q = argv[6];
- rb_z = argv[7];
- rb_lwork = argv[8];
- rb_liwork = argv[9];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- wantz = (rb_wantz == Qtrue);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- liwork = NUM2INT(rb_liwork);
- wantq = (rb_wantq == Qtrue);
- if (!NA_IsNArray(rb_z))
- rb_raise(rb_eArgError, "z (8th argument) must be NArray");
- if (NA_RANK(rb_z) != 2)
- rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_z) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
- ldz = NA_SHAPE0(rb_z);
- if (NA_TYPE(rb_z) != NA_DCOMPLEX)
- rb_z = na_change_type(rb_z, NA_DCOMPLEX);
- z = NA_PTR_TYPE(rb_z, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (7th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (4th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublecomplex*);
- {
- int shape[1];
- shape[0] = 2;
- rb_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, doublereal*);
- {
- int shape[1];
- shape[0] = ijob==0 ? 0 : MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[1];
- shape[0] = ijob==0 ? 0 : MAX(1,liwork);
- rb_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
- }
- iwork = NA_PTR_TYPE(rb_iwork, integer*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- {
- int shape[2];
- shape[0] = ldz;
- shape[1] = n;
- rb_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- z_out__ = NA_PTR_TYPE(rb_z_out__, doublecomplex*);
- MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rb_z));
- rb_z = rb_z_out__;
- z = z_out__;
-
- ztgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alpha, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);
-
- rb_m = INT2NUM(m);
- rb_pl = rb_float_new((double)pl);
- rb_pr = rb_float_new((double)pr);
- rb_info = INT2NUM(info);
- return rb_ary_new3(13, rb_alpha, rb_beta, rb_m, rb_pl, rb_pr, rb_dif, rb_work, rb_iwork, rb_info, rb_a, rb_b, rb_q, rb_z);
-}
-
-void
-init_lapack_ztgsen(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgsen", rb_ztgsen, -1);
-}
diff --git a/ztgsja.c b/ztgsja.c
deleted file mode 100644
index e5f23e6..0000000
--- a/ztgsja.c
+++ /dev/null
@@ -1,208 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgsja_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *tola, doublereal *tolb, doublereal *alpha, doublereal *beta, doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q, integer *ldq, doublecomplex *work, integer *ncycle, integer *info);
-
-static VALUE
-rb_ztgsja(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu;
- char jobu;
- VALUE rb_jobv;
- char jobv;
- VALUE rb_jobq;
- char jobq;
- VALUE rb_k;
- integer k;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_tola;
- doublereal tola;
- VALUE rb_tolb;
- doublereal tolb;
- VALUE rb_u;
- doublecomplex *u;
- VALUE rb_v;
- doublecomplex *v;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_alpha;
- doublereal *alpha;
- VALUE rb_beta;
- doublereal *beta;
- VALUE rb_ncycle;
- integer ncycle;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
- VALUE rb_u_out__;
- doublecomplex *u_out__;
- VALUE rb_v_out__;
- doublecomplex *v_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer ldb;
- integer ldu;
- integer m;
- integer ldv;
- integer p;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ztgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q)\n or\n NumRu::Lapack.ztgsja # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSJA computes the generalized singular value decomposition (GSVD)\n* of two complex upper triangular (or trapezoidal) matrices A and B.\n*\n* On entry, it is assumed that matrices A and B have the following\n* forms, which may be obtained by the preprocessing subroutine ZGGSVP\n* from a general M-by-N matrix A and P-by-N matrix B:\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L >= 0;\n* L ( 0 0 A23 )\n* M-K-L ( 0 0 0 )\n*\n* N-K-L K L\n* A = K ( 0 A12 A13 ) if M-K-L < 0;\n* M-K ( 0 0 A23 )\n*\n* N-K-L K L\n* B = L ( 0 0 B13 )\n* P-L ( 0 0 0 )\n*\n* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n* otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n* On exit,\n*\n* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n*\n* where U, V and Q are unitary matrices, Z' denotes the conjugate\n* transpose of Z, R is a nonsingular upper triangular matrix, and D1\n* and D2 are ``diagonal'' matrices, which are of the following\n* structures:\n*\n* If M-K-L >= 0,\n*\n* K L\n* D1 = K ( I 0 )\n* L ( 0 C )\n* M-K-L ( 0 0 )\n*\n* K L\n* D2 = L ( 0 S )\n* P-L ( 0 0 )\n*\n* N-K-L K L\n* ( 0 R ) = K ( 0 R11 R12 ) K\n* L ( 0 0 R22 ) L\n*\n* where\n*\n* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n* S = diag( BETA(K+1), ... , BETA(K+L) ),\n* C**2 + S**2 = I.\n*\n* R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n* If M-K-L < 0,\n*\n* K M-K K+L-M\n* D1 = K ( I 0 0 )\n* M-K ( 0 C 0 )\n*\n* K M-K K+L-M\n* D2 = M-K ( 0 S 0 )\n* K+L-M ( 0 0 I )\n* P-L ( 0 0 0 )\n*\n* N-K-L K M-K K+L-M\n* ( 0 R ) = K ( 0 R11 R12 R13 )\n* M-K ( 0 0 R22 R23 )\n* K+L-M ( 0 0 0 R33 )\n*\n* where\n* C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n* S = diag( BETA(K+1), ... , BETA(M) ),\n* C**2 + S**2 = I.\n*\n* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n* ( 0 R22 R23 )\n* in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n* The computation of the unitary transformation matrices U, V or Q\n* is optional. These matrices may either be formed explicitly, or they\n* may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n* Arguments\n* =========\n*\n* JOBU (input) CHARACTER*1\n* = 'U': U must contain a unitary matrix U1 on entry, and\n* the product U1*U is returned;\n* = 'I': U is initialized to the unit matrix, and the\n* unitary matrix U is returned;\n* = 'N': U is not computed.\n*\n* JOBV (input) CHARACTER*1\n* = 'V': V must contain a unitary matrix V1 on entry, and\n* the product V1*V is returned;\n* = 'I': V is initialized to the unit matrix, and the\n* unitary matrix V is returned;\n* = 'N': V is not computed.\n*\n* JOBQ (input) CHARACTER*1\n* = 'Q': Q must contain a unitary matrix Q1 on entry, and\n* the product Q1*Q is returned;\n* = 'I': Q is initialized to the unit matrix, and the\n* unitary matrix Q is returned;\n* = 'N': Q is not computed.\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* P (input) INTEGER\n* The number of rows of the matrix B. P >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrices A and B. N >= 0.\n*\n* K (input) INTEGER\n* L (input) INTEGER\n* K and L specify the subblocks in the input matrices A and B:\n* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n* of A and B, whose GSVD is going to be computed by ZTGSJA.\n* See Further Details.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the M-by-N matrix A.\n* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n* matrix R or part of R. See Purpose for details.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,N)\n* On entry, the P-by-N matrix B.\n* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n* a part of R. See Purpose for details.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,P).\n*\n* TOLA (input) DOUBLE PRECISION\n* TOLB (input) DOUBLE PRECISION\n* TOLA and TOLB are the convergence criteria for the Jacobi-\n* Kogbetliantz iteration procedure. Generally, they are the\n* same as used in the preprocessing step, say\n* TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n* TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n*\n* ALPHA (output) DOUBLE PRECISION array, dimension (N)\n* BETA (output) DOUBLE PRECISION array, dimension (N)\n* On exit, ALPHA and BETA contain the generalized singular\n* value pairs of A and B;\n* ALPHA(1:K) = 1,\n* BETA(1:K) = 0,\n* and if M-K-L >= 0,\n* ALPHA(K+1:K+L) = diag(C),\n* BETA(K+1:K+L) = diag(S),\n* or if M-K-L < 0,\n* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n* Furthermore, if K+L < N,\n* ALPHA(K+L+1:N) = 0\n* BETA(K+L+1:N) = 0.\n*\n* U (input/output) COMPLEX*16 array, dimension (LDU,M)\n* On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n* the unitary matrix returned by ZGGSVP).\n* On exit,\n* if JOBU = 'I', U contains the unitary matrix U;\n* if JOBU = 'U', U contains the product U1*U.\n* If JOBU = 'N', U is not referenced.\n*\n* LDU (input) INTEGER\n* The leading dimension of the array U. LDU >= max(1,M) if\n* JOBU = 'U'; LDU >= 1 otherwise.\n*\n* V (input/output) COMPLEX*16 array, dimension (LDV,P)\n* On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n* the unitary matrix returned by ZGGSVP).\n* On exit,\n* if JOBV = 'I', V contains the unitary matrix V;\n* if JOBV = 'V', V contains the product V1*V.\n* If JOBV = 'N', V is not referenced.\n*\n* LDV (input) INTEGER\n* The leading dimension of the array V. LDV >= max(1,P) if\n* JOBV = 'V'; LDV >= 1 otherwise.\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n* the unitary matrix returned by ZGGSVP).\n* On exit,\n* if JOBQ = 'I', Q contains the unitary matrix Q;\n* if JOBQ = 'Q', Q contains the product Q1*Q.\n* If JOBQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N) if\n* JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* NCYCLE (output) INTEGER\n* The number of cycles required for convergence.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* = 1: the procedure does not converge after MAXIT cycles.\n*\n* Internal Parameters\n* ===================\n*\n* MAXIT INTEGER\n* MAXIT specifies the total loops that the iterative procedure\n* may take. If after MAXIT cycles, the routine fails to\n* converge, we return INFO = 1.\n*\n\n* Further Details\n* ===============\n*\n* ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n* matrix B13 to the form:\n*\n* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n* where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n* transpose of Z. C1 and S1 are diagonal matrices satisfying\n*\n* C1**2 + S1**2 = I,\n*\n* and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 12)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
- rb_jobu = argv[0];
- rb_jobv = argv[1];
- rb_jobq = argv[2];
- rb_k = argv[3];
- rb_l = argv[4];
- rb_a = argv[5];
- rb_b = argv[6];
- rb_tola = argv[7];
- rb_tolb = argv[8];
- rb_u = argv[9];
- rb_v = argv[10];
- rb_q = argv[11];
-
- if (!NA_IsNArray(rb_v))
- rb_raise(rb_eArgError, "v (11th argument) must be NArray");
- if (NA_RANK(rb_v) != 2)
- rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
- p = NA_SHAPE1(rb_v);
- ldv = NA_SHAPE0(rb_v);
- if (NA_TYPE(rb_v) != NA_DCOMPLEX)
- rb_v = na_change_type(rb_v, NA_DCOMPLEX);
- v = NA_PTR_TYPE(rb_v, doublecomplex*);
- k = NUM2INT(rb_k);
- jobq = StringValueCStr(rb_jobq)[0];
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- l = NUM2INT(rb_l);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (7th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- jobu = StringValueCStr(rb_jobu)[0];
- jobv = StringValueCStr(rb_jobv)[0];
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (12th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
- if (NA_SHAPE1(rb_q) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- tola = NUM2DBL(rb_tola);
- tolb = NUM2DBL(rb_tolb);
- if (!NA_IsNArray(rb_u))
- rb_raise(rb_eArgError, "u (10th argument) must be NArray");
- if (NA_RANK(rb_u) != 2)
- rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
- m = NA_SHAPE1(rb_u);
- ldu = NA_SHAPE0(rb_u);
- if (NA_TYPE(rb_u) != NA_DCOMPLEX)
- rb_u = na_change_type(rb_u, NA_DCOMPLEX);
- u = NA_PTR_TYPE(rb_u, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- alpha = NA_PTR_TYPE(rb_alpha, doublereal*);
- {
- int shape[1];
- shape[0] = n;
- rb_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- beta = NA_PTR_TYPE(rb_beta, doublereal*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = n;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
- {
- int shape[2];
- shape[0] = ldu;
- shape[1] = m;
- rb_u_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- u_out__ = NA_PTR_TYPE(rb_u_out__, doublecomplex*);
- MEMCPY(u_out__, u, doublecomplex, NA_TOTAL(rb_u));
- rb_u = rb_u_out__;
- u = u_out__;
- {
- int shape[2];
- shape[0] = ldv;
- shape[1] = p;
- rb_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- v_out__ = NA_PTR_TYPE(rb_v_out__, doublecomplex*);
- MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rb_v));
- rb_v = rb_v_out__;
- v = v_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
- work = ALLOC_N(doublecomplex, (2*n));
-
- ztgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);
-
- free(work);
- rb_ncycle = INT2NUM(ncycle);
- rb_info = INT2NUM(info);
- return rb_ary_new3(9, rb_alpha, rb_beta, rb_ncycle, rb_info, rb_a, rb_b, rb_u, rb_v, rb_q);
-}
-
-void
-init_lapack_ztgsja(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgsja", rb_ztgsja, -1);
-}
diff --git a/ztgsna.c b/ztgsna.c
deleted file mode 100644
index 1cb2eb0..0000000
--- a/ztgsna.c
+++ /dev/null
@@ -1,139 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgsna_(char *job, char *howmny, logical *select, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, doublereal *dif, integer *mm, integer *m, doublecomplex *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_ztgsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_dif;
- doublereal *dif;
- VALUE rb_m;
- integer m;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- integer *iwork;
-
- integer n;
- integer lda;
- integer ldb;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, dif, m, work, info = NumRu::Lapack.ztgsna( job, howmny, select, a, b, vl, vr, lwork)\n or\n NumRu::Lapack.ztgsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or eigenvectors of a matrix pair (A, B).\n*\n* (A, B) must be in generalized Schur canonical form, that is, A and\n* B are both upper triangular.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (DIF):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (DIF);\n* = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the corresponding j-th eigenvalue and/or eigenvector,\n* SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the square matrix pair (A, B). N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The upper triangular matrix A in the pair (A,B).\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The upper triangular matrix B in the pair (A, B).\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* VL (input) COMPLEX*16 array, dimension (LDVL,M)\n* IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VL, as returned by ZTGEVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1; and\n* If JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX*16 array, dimension (LDVR,M)\n* IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n* (A, B), corresponding to the eigenpairs specified by HOWMNY\n* and SELECT. The eigenvectors must be stored in consecutive\n* columns of VR, as returned by ZTGEVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1;\n* If JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array.\n* If JOB = 'V', S is not referenced.\n*\n* DIF (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If the eigenvalues cannot be reordered to compute DIF(j),\n* DIF(j) is set to 0; this can only occur when the true value\n* would be very small anyway.\n* For each eigenvalue/vector specified by SELECT, DIF stores\n* a Frobenius norm-based estimate of Difl.\n* If JOB = 'E', DIF is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S and DIF. MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and DIF used to store\n* the specified condition numbers; for each selected eigenvalue\n* one element is used. If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n*\n* IWORK (workspace) INTEGER array, dimension (N+2)\n* If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n* eigenvalue w = (a, b) is defined as\n*\n* S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of (A, B)\n* corresponding to w; |z| denotes the absolute value of the complex\n* number, and norm(u) denotes the 2-norm of the vector u. The pair\n* (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n* matrix pair (A, B). If both a and b equal zero, then (A,B) is\n* singular and S(I) = -1 is returned.\n*\n* An approximate error bound on the chordal distance between the i-th\n* computed generalized eigenvalue w and the corresponding exact\n* eigenvalue lambda is\n*\n* chord(w, lambda) <= EPS * norm(A, B) / S(I),\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* and left eigenvector v corresponding to the generalized eigenvalue w\n* is defined as follows. Suppose\n*\n* (A, B) = ( a * ) ( b * ) 1\n* ( 0 A22 ),( 0 B22 ) n-1\n* 1 n-1 1 n-1\n*\n* Then the reciprocal condition number DIF(I) is\n*\n* Difl[(a, b), (A22, B22)] = sigma-min( Zl )\n*\n* where sigma-min(Zl) denotes the smallest singular value of\n*\n* Zl = [ kron(a, In-1) -kron(1, A22) ]\n* [ kron(b, In-1) -kron(1, B22) ].\n*\n* Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n* transpose of X. kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* We approximate the smallest singular value of Zl with an upper\n* bound. This is done by ZLATDF.\n*\n* An approximate error bound for a computed eigenvector VL(i) or\n* VR(i) is given by\n*\n* EPS * norm(A, B) / DIF(i).\n*\n* See ref. [2-3] for more details and further references.\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* References\n* ==========\n*\n* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n* M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n* Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n* Estimation: Theory, Algorithms and Software, Report\n* UMINF - 94.04, Department of Computing Science, Umea University,\n* S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n* To appear in Numerical Algorithms, 1996.\n*\n* [3] 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.\n* To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_vl = argv[5];
- rb_vr = argv[6];
- rb_lwork = argv[7];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_DCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_DCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- job = StringValueCStr(rb_job)[0];
- lwork = NUM2INT(rb_lwork);
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = mm;
- rb_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- dif = NA_PTR_TYPE(rb_dif, doublereal*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n+2));
-
- ztgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_s, rb_dif, rb_m, rb_work, rb_info);
-}
-
-void
-init_lapack_ztgsna(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgsna", rb_ztgsna, -1);
-}
diff --git a/ztgsy2.c b/ztgsy2.c
deleted file mode 100644
index c0f9f06..0000000
--- a/ztgsy2.c
+++ /dev/null
@@ -1,157 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgsy2_(char *trans, integer *ijob, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *c, integer *ldc, doublecomplex *d, integer *ldd, doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf, doublereal *scale, doublereal *rdsum, doublereal *rdscal, integer *info);
-
-static VALUE
-rb_ztgsy2(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_f;
- doublecomplex *f;
- VALUE rb_rdsum;
- doublereal rdsum;
- VALUE rb_rdscal;
- doublereal rdscal;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- VALUE rb_f_out__;
- doublecomplex *f_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ztgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal)\n or\n NumRu::Lapack.ztgsy2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n* Purpose\n* =======\n*\n* ZTGSY2 solves the generalized Sylvester equation\n*\n* A * R - L * B = scale * C (1)\n* D * R - L * E = scale * F\n*\n* using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n* N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n* (i.e., (A,D) and (B,E) in generalized Schur form).\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 solving equation (1) corresponds to solve\n* Zx = scale * b, where Z is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Ik is the identity matrix of size k and X' is the transpose of X.\n* kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n* is solved for, 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 is used to compute an estimate of Dif[(A, D), (B, E)] =\n* = sigma_min(Z) using reverse communicaton with ZLACON.\n*\n* ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL\n* of an upper bound on the separation between to matrix pairs. Then\n* the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n* ZTGSYL.\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: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (look ahead strategy is used).\n* =2: A contribution from this subsystem to a Frobenius\n* norm-based estimate of the separation between two matrix\n* pairs is computed. (DGECON on sub-systems is used.)\n* Not referenced if TRANS = 'T'.\n*\n* M (input) INTEGER\n* On entry, M specifies the order of A and D, and the row\n* dimension of C, F, R and L.\n*\n* N (input) INTEGER\n* On entry, N specifies the order of B and E, and the column\n* dimension of C, F, R and L.\n*\n* A (input) COMPLEX*16 array, dimension (LDA, M)\n* On entry, A contains an upper triangular matrix.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1, M).\n*\n* B (input) COMPLEX*16 array, dimension (LDB, N)\n* On entry, B contains an upper triangular matrix.\n*\n* LDB (input) INTEGER\n* The leading dimension of the matrix B. LDB >= max(1, N).\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC, N)\n* On entry, C contains the right-hand-side of the first matrix\n* equation in (1).\n* On exit, if IJOB = 0, C has been overwritten by the solution\n* R.\n*\n* LDC (input) INTEGER\n* The leading dimension of the matrix C. LDC >= max(1, M).\n*\n* D (input) COMPLEX*16 array, dimension (LDD, M)\n* On entry, D contains an upper triangular matrix.\n*\n* LDD (input) INTEGER\n* The leading dimension of the matrix D. LDD >= max(1, M).\n*\n* E (input) COMPLEX*16 array, dimension (LDE, N)\n* On entry, E contains an upper triangular matrix.\n*\n* LDE (input) INTEGER\n* The leading dimension of the matrix E. LDE >= max(1, N).\n*\n* F (input/output) COMPLEX*16 array, dimension (LDF, N)\n* On entry, F contains the right-hand-side of the second matrix\n* equation in (1).\n* On exit, if IJOB = 0, F has been overwritten by the solution\n* L.\n*\n* LDF (input) INTEGER\n* The leading dimension of the matrix F. LDF >= max(1, M).\n*\n* SCALE (output) DOUBLE PRECISION\n* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n* R and L (C and F on entry) will hold the solutions to a\n* slightly perturbed system but the input matrices A, B, D and\n* E have not been changed. If SCALE = 0, R and L will hold the\n* solutions to the homogeneous system with C = F = 0.\n* Normally, SCALE = 1.\n*\n* RDSUM (input/output) DOUBLE PRECISION\n* On entry, the sum of squares of computed contributions to\n* the Dif-estimate under computation by ZTGSYL, where the\n* scaling factor RDSCAL (see below) has been factored out.\n* On exit, the corresponding sum of squares updated with the\n* contributions from the current sub-system.\n* If TRANS = 'T' RDSUM is not touched.\n* NOTE: RDSUM only makes sense when ZTGSY2 is called by\n* ZTGSYL.\n*\n* RDSCAL (input/output) DOUBLE PRECISION\n* On entry, scaling factor used to prevent overflow in RDSUM.\n* On exit, RDSCAL is updated w.r.t. the current contributions\n* in RDSUM.\n* If TRANS = 'T', RDSCAL is not touched.\n* NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n* ZTGSYL.\n*\n* INFO (output) INTEGER\n* On exit, if INFO is set to\n* =0: Successful exit\n* <0: If INFO = -i, input argument number i is illegal.\n* >0: The matrix pairs (A, D) and (B, E) have common or very\n* 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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 10)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_rdsum = argv[8];
- rb_rdscal = argv[9];
-
- rdscal = NUM2DBL(rb_rdscal);
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- rdsum = NUM2DBL(rb_rdsum);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_DCOMPLEX)
- rb_f = na_change_type(rb_f, NA_DCOMPLEX);
- f = NA_PTR_TYPE(rb_f, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, doublecomplex*);
- MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
-
- ztgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- rb_rdsum = rb_float_new((double)rdsum);
- rb_rdscal = rb_float_new((double)rdscal);
- return rb_ary_new3(6, rb_scale, rb_info, rb_c, rb_f, rb_rdsum, rb_rdscal);
-}
-
-void
-init_lapack_ztgsy2(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgsy2", rb_ztgsy2, -1);
-}
diff --git a/ztgsyl.c b/ztgsyl.c
deleted file mode 100644
index 7bd7235..0000000
--- a/ztgsyl.c
+++ /dev/null
@@ -1,165 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztgsyl_(char *trans, integer *ijob, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *c, integer *ldc, doublecomplex *d, integer *ldd, doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf, doublereal *scale, doublereal *dif, doublecomplex *work, integer *lwork, integer *iwork, integer *info);
-
-static VALUE
-rb_ztgsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_ijob;
- integer ijob;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_d;
- doublecomplex *d;
- VALUE rb_e;
- doublecomplex *e;
- VALUE rb_f;
- doublecomplex *f;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_dif;
- doublereal dif;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- VALUE rb_f_out__;
- doublecomplex *f_out__;
- integer *iwork;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
- integer ldd;
- integer lde;
- integer ldf;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, dif, work, info, c, f = NumRu::Lapack.ztgsyl( trans, ijob, a, b, c, d, e, f, lwork)\n or\n NumRu::Lapack.ztgsyl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTGSYL( 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* ZTGSYL 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 complex entries. A, B, D and E are upper\n* triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n* is an output scaling factor chosen to avoid overflow.\n*\n* In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n* is defined as\n*\n* Z = [ kron(In, A) -kron(B', Im) ] (2)\n* [ kron(In, D) -kron(E', Im) ],\n*\n* Here Ix is the identity matrix of size x and X' is the conjugate\n* transpose of X. Kron(X, Y) is the Kronecker product between the\n* matrices X and Y.\n*\n* If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n* is solved for, 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 = 'C') 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 ZLACON.\n*\n* If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of\n* Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n* reciprocal of the smallest singular value of Z.\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* = 'C': solve the \"conjugate 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 is used).\n* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n* (ZGECON on sub-systems is used).\n* Not referenced if TRANS = 'C'.\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) COMPLEX*16 array, dimension (LDA, M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1, M).\n*\n* B (input) COMPLEX*16 array, dimension (LDB, N)\n* The upper 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION\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 = 'C', DIF is not referenced.\n*\n* SCALE (output) DOUBLE PRECISION\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,\n* D and E have not been changed. If SCALE = 0, R and L will\n* hold the solutions to the homogenious system with C = F = 0.\n*\n* WORK (workspace/output) COMPLEX*16 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+2)\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 very close\n* 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 CCOPY by calls to CLASET.\n* Sven Hammarling, 1/5/02.\n*\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_trans = argv[0];
- rb_ijob = argv[1];
- rb_a = argv[2];
- rb_b = argv[3];
- rb_c = argv[4];
- rb_d = argv[5];
- rb_e = argv[6];
- rb_f = argv[7];
- rb_lwork = argv[8];
-
- ijob = NUM2INT(rb_ijob);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (4th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_d))
- rb_raise(rb_eArgError, "d (6th argument) must be NArray");
- if (NA_RANK(rb_d) != 2)
- rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_d) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
- ldd = NA_SHAPE0(rb_d);
- if (NA_TYPE(rb_d) != NA_DCOMPLEX)
- rb_d = na_change_type(rb_d, NA_DCOMPLEX);
- d = NA_PTR_TYPE(rb_d, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_e))
- rb_raise(rb_eArgError, "e (7th argument) must be NArray");
- if (NA_RANK(rb_e) != 2)
- rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_e) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of b");
- lde = NA_SHAPE0(rb_e);
- if (NA_TYPE(rb_e) != NA_DCOMPLEX)
- rb_e = na_change_type(rb_e, NA_DCOMPLEX);
- e = NA_PTR_TYPE(rb_e, doublecomplex*);
- if (!NA_IsNArray(rb_f))
- rb_raise(rb_eArgError, "f (8th argument) must be NArray");
- if (NA_RANK(rb_f) != 2)
- rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_f) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of b");
- ldf = NA_SHAPE0(rb_f);
- if (NA_TYPE(rb_f) != NA_DCOMPLEX)
- rb_f = na_change_type(rb_f, NA_DCOMPLEX);
- f = NA_PTR_TYPE(rb_f, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- {
- int shape[2];
- shape[0] = ldf;
- shape[1] = n;
- rb_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- f_out__ = NA_PTR_TYPE(rb_f_out__, doublecomplex*);
- MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rb_f));
- rb_f = rb_f_out__;
- f = f_out__;
- iwork = ALLOC_N(integer, (m+n+2));
-
- ztgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);
-
- free(iwork);
- rb_scale = rb_float_new((double)scale);
- rb_dif = rb_float_new((double)dif);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_scale, rb_dif, rb_work, rb_info, rb_c, rb_f);
-}
-
-void
-init_lapack_ztgsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "ztgsyl", rb_ztgsyl, -1);
-}
diff --git a/ztpcon.c b/ztpcon.c
deleted file mode 100644
index b6cc9ac..0000000
--- a/ztpcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztpcon_(char *norm, char *uplo, char *diag, integer *n, doublecomplex *ap, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztpcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldap;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.ztpcon( norm, uplo, diag, ap)\n or\n NumRu::Lapack.ztpcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTPCON 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) COMPLEX*16 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) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- norm = StringValueCStr(rb_norm)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- ztpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_ztpcon(VALUE mLapack){
- rb_define_module_function(mLapack, "ztpcon", rb_ztpcon, -1);
-}
diff --git a/ztprfs.c b/ztprfs.c
deleted file mode 100644
index ea61036..0000000
--- a/ztprfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztprfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztprfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer ldb;
- integer nrhs;
- integer ldx;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.ztprfs( uplo, trans, diag, ap, b, x)\n or\n NumRu::Lapack.ztprfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTPRFS 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 ZTPTRS or some other\n* means before entering this routine. ZTPRFS 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)\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) COMPLEX*16 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* B (input) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_ap = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- n = ldb;
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- ztprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_ztprfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ztprfs", rb_ztprfs, -1);
-}
diff --git a/ztptri.c b/ztptri.c
deleted file mode 100644
index 973c7c9..0000000
--- a/ztptri.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztptri_(char *uplo, char *diag, integer *n, doublecomplex *ap, integer *info);
-
-static VALUE
-rb_ztptri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_info;
- integer info;
- VALUE rb_ap_out__;
- doublecomplex *ap_out__;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, ap = NumRu::Lapack.ztptri( uplo, diag, n, ap)\n or\n NumRu::Lapack.ztptri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTRI computes the inverse of a complex 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) COMPLEX*16 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = n*(n+1)/2;
- rb_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap_out__ = NA_PTR_TYPE(rb_ap_out__, doublecomplex*);
- MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rb_ap));
- rb_ap = rb_ap_out__;
- ap = ap_out__;
-
- ztptri_(&uplo, &diag, &n, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_ap);
-}
-
-void
-init_lapack_ztptri(VALUE mLapack){
- rb_define_module_function(mLapack, "ztptri", rb_ztptri, -1);
-}
diff --git a/ztptrs.c b/ztptrs.c
deleted file mode 100644
index 6545387..0000000
--- a/ztptrs.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztptrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *ap, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ztptrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ztptrs( uplo, trans, diag, n, ap, b)\n or\n NumRu::Lapack.ztptrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N stored in packed format,\n* and B is an N-by-NRHS matrix. A check is made to verify that A is\n* nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* AP (input) COMPLEX*16 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*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the\n* solutions X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_n = argv[3];
- rb_ap = argv[4];
- rb_b = argv[5];
-
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (6th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- n = NUM2INT(rb_n);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (n*(n+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ztptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ztptrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ztptrs", rb_ztptrs, -1);
-}
diff --git a/ztpttf.c b/ztpttf.c
deleted file mode 100644
index 73e8b5e..0000000
--- a/ztpttf.c
+++ /dev/null
@@ -1,60 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztpttf_(char *transr, char *uplo, integer *n, doublecomplex *ap, doublecomplex *arf, integer *info);
-
-static VALUE
-rb_ztpttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_n;
- integer n;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_arf;
- doublecomplex *arf;
- VALUE rb_info;
- integer info;
-
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ztpttf( transr, uplo, n, ap)\n or\n NumRu::Lapack.ztpttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTTF copies a triangular matrix A from standard packed format (TP)\n* to rectangular full packed format (TF).\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal format is wanted;\n* = 'C': ARF in Conjugate-transpose format is wanted.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = 'N'. RFP holds AP as follows:\n* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = 'N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_n = argv[2];
- rb_ap = argv[3];
-
- n = NUM2INT(rb_n);
- transr = StringValueCStr(rb_transr)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (( n*(n+1)/2 )))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, doublecomplex*);
-
- ztpttf_(&transr, &uplo, &n, ap, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_ztpttf(VALUE mLapack){
- rb_define_module_function(mLapack, "ztpttf", rb_ztpttf, -1);
-}
diff --git a/ztpttr.c b/ztpttr.c
deleted file mode 100644
index f3aa1df..0000000
--- a/ztpttr.c
+++ /dev/null
@@ -1,57 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztpttr_(char *uplo, integer *n, doublecomplex *ap, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ztpttr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
-
- integer ldap;
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n a, info = NumRu::Lapack.ztpttr( uplo, ap)\n or\n NumRu::Lapack.ztpttr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTPTTR copies a triangular matrix A from standard packed format (TP)\n* to standard full format (TR).\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* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On entry, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n* A (output) COMPLEX*16 array, dimension ( LDA, N )\n* On exit, the triangular 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* 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 = -i, the i-th argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ((int)sqrtf(ldap*8-1.0f)-1)/2;
- lda = MAX(1,n);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
-
- ztpttr_(&uplo, &n, ap, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_a, rb_info);
-}
-
-void
-init_lapack_ztpttr(VALUE mLapack){
- rb_define_module_function(mLapack, "ztpttr", rb_ztpttr, -1);
-}
diff --git a/ztrcon.c b/ztrcon.c
deleted file mode 100644
index 763b3b0..0000000
--- a/ztrcon.c
+++ /dev/null
@@ -1,63 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrcon_(char *norm, char *uplo, char *diag, integer *n, doublecomplex *a, integer *lda, doublereal *rcond, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztrcon(int argc, VALUE *argv, VALUE self){
- VALUE rb_norm;
- char norm;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_rcond;
- doublereal rcond;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n rcond, info = NumRu::Lapack.ztrcon( norm, uplo, diag, a)\n or\n NumRu::Lapack.ztrcon # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRCON estimates the reciprocal of the condition number of a\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* RCOND (output) DOUBLE PRECISION\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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_norm = argv[0];
- rb_uplo = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- norm = StringValueCStr(rb_norm)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- ztrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_rcond = rb_float_new((double)rcond);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_rcond, rb_info);
-}
-
-void
-init_lapack_ztrcon(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrcon", rb_ztrcon, -1);
-}
diff --git a/ztrevc.c b/ztrevc.c
deleted file mode 100644
index 5b9ec1a..0000000
--- a/ztrevc.c
+++ /dev/null
@@ -1,135 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrevc_(char *side, char *howmny, logical *select, integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, integer *mm, integer *m, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztrevc(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- doublecomplex *t_out__;
- VALUE rb_vl_out__;
- doublecomplex *vl_out__;
- VALUE rb_vr_out__;
- doublecomplex *vr_out__;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer mm;
- integer ldvr;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n m, info, t, vl, vr = NumRu::Lapack.ztrevc( side, howmny, select, t, vl, vr)\n or\n NumRu::Lapack.ztrevc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTREVC computes some or all of the right and/or left eigenvectors of\n* a complex upper triangular matrix T.\n* Matrices of this type are produced by the Schur factorization of\n* a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.\n* \n* The right eigenvector x and the left eigenvector y of T corresponding\n* to an eigenvalue w are defined by:\n* \n* T*x = w*x, (y**H)*T = w*(y**H)\n* \n* where y**H denotes the conjugate transpose of the vector y.\n* The eigenvalues are not input to this routine, but are read directly\n* from the diagonal of T.\n* \n* This routine returns the matrices X and/or Y of right and left\n* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n* input matrix. If Q is the unitary factor that reduces a matrix A to\n* Schur form T, then Q*X and Q*Y are the matrices of right and left\n* eigenvectors of A.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'R': compute right eigenvectors only;\n* = 'L': compute left eigenvectors only;\n* = 'B': compute both right and left eigenvectors.\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute all right and/or left eigenvectors;\n* = 'B': compute all right and/or left eigenvectors,\n* backtransformed using the matrices supplied in\n* VR and/or VL;\n* = 'S': compute selected right and/or left eigenvectors,\n* as indicated by the logical array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n* computed.\n* The eigenvector corresponding to the j-th eigenvalue is\n* computed if SELECT(j) = .TRUE..\n* Not referenced if HOWMNY = 'A' or 'B'.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT,N)\n* The upper triangular matrix T. T is modified, but restored\n* on exit.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by ZHSEQR).\n* On exit, if SIDE = 'L' or 'B', VL contains:\n* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*Y;\n* if HOWMNY = 'S', the left eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VL, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'R'.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL. LDVL >= 1, and if\n* SIDE = 'L' or 'B', LDVL >= N.\n*\n* VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n* contain an N-by-N matrix Q (usually the unitary matrix Q of\n* Schur vectors returned by ZHSEQR).\n* On exit, if SIDE = 'R' or 'B', VR contains:\n* if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n* if HOWMNY = 'B', the matrix Q*X;\n* if HOWMNY = 'S', the right eigenvectors of T specified by\n* SELECT, stored consecutively in the columns\n* of VR, in the same order as their\n* eigenvalues.\n* Not referenced if SIDE = 'L'.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR. LDVR >= 1, and if\n* SIDE = 'R' or 'B'; LDVR >= N.\n*\n* MM (input) INTEGER\n* The number of columns in the arrays VL and/or VR. MM >= M.\n*\n* M (output) INTEGER\n* The number of columns in the arrays VL and/or VR actually\n* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n* is set to N. Each selected eigenvector occupies one\n* column.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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* Further Details\n* ===============\n*\n* The algorithm used in this program is basically backward (forward)\n* substitution, with scaling to make the the code robust against\n* possible overflow.\n*\n* Each eigenvector is normalized so that the element of largest\n* magnitude has magnitude 1; here the magnitude of a complex number\n* (x,y) is taken to be |x| + |y|.\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
-
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- mm = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_DCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != mm)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_DCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- n = NA_SHAPE0(rb_select);
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DCOMPLEX)
- rb_t = na_change_type(rb_t, NA_DCOMPLEX);
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- howmny = StringValueCStr(rb_howmny)[0];
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublecomplex*);
- MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldvl;
- shape[1] = mm;
- rb_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vl_out__ = NA_PTR_TYPE(rb_vl_out__, doublecomplex*);
- MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rb_vl));
- rb_vl = rb_vl_out__;
- vl = vl_out__;
- {
- int shape[2];
- shape[0] = ldvr;
- shape[1] = mm;
- rb_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- vr_out__ = NA_PTR_TYPE(rb_vr_out__, doublecomplex*);
- MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rb_vr));
- rb_vr = rb_vr_out__;
- vr = vr_out__;
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- ztrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(5, rb_m, rb_info, rb_t, rb_vl, rb_vr);
-}
-
-void
-init_lapack_ztrevc(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrevc", rb_ztrevc, -1);
-}
diff --git a/ztrexc.c b/ztrexc.c
deleted file mode 100644
index 728488c..0000000
--- a/ztrexc.c
+++ /dev/null
@@ -1,92 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrexc_(char *compq, integer *n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq, integer *ifst, integer *ilst, integer *info);
-
-static VALUE
-rb_ztrexc(int argc, VALUE *argv, VALUE self){
- VALUE rb_compq;
- char compq;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_ifst;
- integer ifst;
- VALUE rb_ilst;
- integer ilst;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- doublecomplex *t_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
-
- integer ldt;
- integer n;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, t, q = NumRu::Lapack.ztrexc( compq, t, q, ifst, ilst)\n or\n NumRu::Lapack.ztrexc # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n* Purpose\n* =======\n*\n* ZTREXC reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n* is moved to row ILST.\n*\n* The Schur form T is reordered by a unitary similarity transformation\n* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n* postmultplying it with Z.\n*\n\n* Arguments\n* =========\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, the reordered upper triangular matrix.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix Z which reorders T.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* IFST (input) INTEGER\n* ILST (input) INTEGER\n* Specify the reordering of the diagonal elements of T:\n* The element with row index IFST is moved to row ILST by a\n* sequence of transpositions between adjacent elements.\n* 1 <= IFST <= N; 1 <= ILST <= 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* .. Local Scalars ..\n LOGICAL WANTQ\n INTEGER K, M1, M2, M3\n DOUBLE PRECISION CS\n COMPLEX*16 SN, T11, T22, TEMP\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLARTG, ZROT\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_compq = argv[0];
- rb_t = argv[1];
- rb_q = argv[2];
- rb_ifst = argv[3];
- rb_ilst = argv[4];
-
- compq = StringValueCStr(rb_compq)[0];
- ilst = NUM2INT(rb_ilst);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (3th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (2th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DCOMPLEX)
- rb_t = na_change_type(rb_t, NA_DCOMPLEX);
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- ifst = NUM2INT(rb_ifst);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublecomplex*);
- MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
-
- ztrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_ztrexc(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrexc", rb_ztrexc, -1);
-}
diff --git a/ztrrfs.c b/ztrrfs.c
deleted file mode 100644
index 372c306..0000000
--- a/ztrrfs.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, doublecomplex *work, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztrrfs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_x;
- doublecomplex *x;
- VALUE rb_ferr;
- doublereal *ferr;
- VALUE rb_berr;
- doublereal *berr;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
- integer ldx;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ferr, berr, info = NumRu::Lapack.ztrrfs( uplo, trans, diag, a, b, x)\n or\n NumRu::Lapack.ztrrfs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRRFS provides error bounds and backward error estimates for the\n* solution to a system of linear equations with a triangular\n* coefficient matrix.\n*\n* The solution matrix X must be computed by ZTRTRS or some other\n* means before entering this routine. ZTRRFS 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)\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* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input) COMPLEX*16 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) COMPLEX*16 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) COMPLEX*16 array, dimension (2*N)\n*\n* RWORK (workspace) DOUBLE PRECISION 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_x = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_x))
- rb_raise(rb_eArgError, "x (6th argument) must be NArray");
- if (NA_RANK(rb_x) != 2)
- rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_x);
- ldx = NA_SHAPE0(rb_x);
- if (NA_TYPE(rb_x) != NA_DCOMPLEX)
- rb_x = na_change_type(rb_x, NA_DCOMPLEX);
- x = NA_PTR_TYPE(rb_x, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_b) != nrhs)
- rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = nrhs;
- rb_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- ferr = NA_PTR_TYPE(rb_ferr, doublereal*);
- {
- int shape[1];
- shape[0] = nrhs;
- rb_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- berr = NA_PTR_TYPE(rb_berr, doublereal*);
- work = ALLOC_N(doublecomplex, (2*n));
- rwork = ALLOC_N(doublereal, (n));
-
- ztrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);
-
- free(work);
- free(rwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_ferr, rb_berr, rb_info);
-}
-
-void
-init_lapack_ztrrfs(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrrfs", rb_ztrrfs, -1);
-}
diff --git a/ztrsen.c b/ztrsen.c
deleted file mode 100644
index 6807401..0000000
--- a/ztrsen.c
+++ /dev/null
@@ -1,129 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrsen_(char *job, char *compq, logical *select, integer *n, doublecomplex *t, integer *ldt, doublecomplex *q, integer *ldq, doublecomplex *w, integer *m, doublereal *s, doublereal *sep, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ztrsen(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_compq;
- char compq;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_w;
- doublecomplex *w;
- VALUE rb_m;
- integer m;
- VALUE rb_s;
- doublereal s;
- VALUE rb_sep;
- doublereal sep;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_t_out__;
- doublecomplex *t_out__;
- VALUE rb_q_out__;
- doublecomplex *q_out__;
-
- integer n;
- integer ldt;
- integer ldq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n w, m, s, sep, work, info, t, q = NumRu::Lapack.ztrsen( job, compq, select, t, q, lwork)\n or\n NumRu::Lapack.ztrsen # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRSEN reorders the Schur factorization of a complex matrix\n* A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n* the leading positions on the diagonal of the upper triangular matrix\n* T, and the leading columns of Q form an orthonormal basis of the\n* corresponding right invariant subspace.\n*\n* Optionally the routine computes the reciprocal condition numbers of\n* the cluster of eigenvalues and/or the invariant subspace.\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for the\n* cluster of eigenvalues (S) or the invariant subspace (SEP):\n* = 'N': none;\n* = 'E': for eigenvalues only (S);\n* = 'V': for invariant subspace only (SEP);\n* = 'B': for both eigenvalues and invariant subspace (S and\n* SEP).\n*\n* COMPQ (input) CHARACTER*1\n* = 'V': update the matrix Q of Schur vectors;\n* = 'N': do not update Q.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* SELECT specifies the eigenvalues in the selected cluster. To\n* select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input/output) COMPLEX*16 array, dimension (LDT,N)\n* On entry, the upper triangular matrix T.\n* On exit, T is overwritten by the reordered matrix T, with the\n* selected eigenvalues as the leading diagonal elements.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n* On exit, if COMPQ = 'V', Q has been postmultiplied by the\n* unitary transformation matrix which reorders T; the leading M\n* columns of Q form an orthonormal basis for the specified\n* invariant subspace.\n* If COMPQ = 'N', Q is not referenced.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q.\n* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n* W (output) COMPLEX*16 array, dimension (N)\n* The reordered eigenvalues of T, in the same order as they\n* appear on the diagonal of T.\n*\n* M (output) INTEGER\n* The dimension of the specified invariant subspace.\n* 0 <= M <= N.\n*\n* S (output) DOUBLE PRECISION\n* If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n* condition number for the selected cluster of eigenvalues.\n* S cannot underestimate the true reciprocal condition number\n* by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n* If JOB = 'N' or 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION\n* If JOB = 'V' or 'B', SEP is the estimated reciprocal\n* condition number of the specified invariant subspace. If\n* M = 0 or N, SEP = norm(T).\n* If JOB = 'N' or 'E', SEP is not referenced.\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If JOB = 'N', LWORK >= 1;\n* if JOB = 'E', LWORK = max(1,M*(N-M));\n* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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* ZTRSEN first collects the selected eigenvalues by computing a unitary\n* transformation Z to move them to the top left corner of T. In other\n* words, the selected eigenvalues are the eigenvalues of T11 in:\n*\n* Z'*T*Z = ( T11 T12 ) n1\n* ( 0 T22 ) n2\n* n1 n2\n*\n* where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n* n1 columns of Z span the specified invariant subspace of T.\n*\n* If T has been obtained from the Schur factorization of a matrix\n* A = Q*T*Q', then the reordered Schur factorization of A is given by\n* A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n* corresponding invariant subspace of A.\n*\n* The reciprocal condition number of the average of the eigenvalues of\n* T11 may be returned in S. S lies between 0 (very badly conditioned)\n* and 1 (very well conditioned). It is computed as follows. First we\n* compute R so that\n*\n* P = ( I R ) n1\n* ( 0 0 ) n2\n* n1 n2\n*\n* is the projector on the invariant subspace associated with T11.\n* R is the solution of the Sylvester equation:\n*\n* T11*R - R*T22 = T12.\n*\n* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n* the two-norm of M. Then S is computed as the lower bound\n*\n* (1 + F-norm(R)**2)**(-1/2)\n*\n* on the reciprocal of 2-norm(P), the true reciprocal condition number.\n* S cannot underestimate 1 / 2-norm(P) by more than a factor of\n* sqrt(N).\n*\n* An approximate error bound for the computed average of the\n* eigenvalues of T11 is\n*\n* EPS * norm(T) / S\n*\n* where EPS is the machine precision.\n*\n* The reciprocal condition number of the right invariant subspace\n* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n* SEP is defined as the separation of T11 and T22:\n*\n* sep( T11, T22 ) = sigma-min( C )\n*\n* where sigma-min(C) is the smallest singular value of the\n* n1*n2-by-n1*n2 matrix\n*\n* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n* I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n* product. We estimate sigma-min(C) by the reciprocal of an estimate of\n* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n* When SEP is small, small changes in T can cause large changes in\n* the invariant subspace. An approximate bound on the maximum angular\n* error in the computed right invariant subspace is\n*\n* EPS * norm(T) / SEP\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_job = argv[0];
- rb_compq = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_q = argv[4];
- rb_lwork = argv[5];
-
- compq = StringValueCStr(rb_compq)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_q))
- rb_raise(rb_eArgError, "q (5th argument) must be NArray");
- if (NA_RANK(rb_q) != 2)
- rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_q);
- ldq = NA_SHAPE0(rb_q);
- if (NA_TYPE(rb_q) != NA_DCOMPLEX)
- rb_q = na_change_type(rb_q, NA_DCOMPLEX);
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- job = StringValueCStr(rb_job)[0];
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of q");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_t) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DCOMPLEX)
- rb_t = na_change_type(rb_t, NA_DCOMPLEX);
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- {
- int shape[1];
- shape[0] = n;
- rb_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- w = NA_PTR_TYPE(rb_w, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldt;
- shape[1] = n;
- rb_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- t_out__ = NA_PTR_TYPE(rb_t_out__, doublecomplex*);
- MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rb_t));
- rb_t = rb_t_out__;
- t = t_out__;
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q_out__ = NA_PTR_TYPE(rb_q_out__, doublecomplex*);
- MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rb_q));
- rb_q = rb_q_out__;
- q = q_out__;
-
- ztrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, w, &m, &s, &sep, work, &lwork, &info);
-
- rb_m = INT2NUM(m);
- rb_s = rb_float_new((double)s);
- rb_sep = rb_float_new((double)sep);
- rb_info = INT2NUM(info);
- return rb_ary_new3(8, rb_w, rb_m, rb_s, rb_sep, rb_work, rb_info, rb_t, rb_q);
-}
-
-void
-init_lapack_ztrsen(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrsen", rb_ztrsen, -1);
-}
diff --git a/ztrsna.c b/ztrsna.c
deleted file mode 100644
index bb05b4e..0000000
--- a/ztrsna.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrsna_(char *job, char *howmny, logical *select, integer *n, doublecomplex *t, integer *ldt, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, doublereal *s, doublereal *sep, integer *mm, integer *m, doublecomplex *work, integer *ldwork, doublereal *rwork, integer *info);
-
-static VALUE
-rb_ztrsna(int argc, VALUE *argv, VALUE self){
- VALUE rb_job;
- char job;
- VALUE rb_howmny;
- char howmny;
- VALUE rb_select;
- logical *select;
- VALUE rb_t;
- doublecomplex *t;
- VALUE rb_vl;
- doublecomplex *vl;
- VALUE rb_vr;
- doublecomplex *vr;
- VALUE rb_ldwork;
- integer ldwork;
- VALUE rb_s;
- doublereal *s;
- VALUE rb_sep;
- doublereal *sep;
- VALUE rb_m;
- integer m;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
-
- integer n;
- integer ldt;
- integer ldvl;
- integer ldvr;
- integer mm;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n s, sep, m, info = NumRu::Lapack.ztrsna( job, howmny, select, t, vl, vr, ldwork)\n or\n NumRu::Lapack.ztrsna # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTRSNA estimates reciprocal condition numbers for specified\n* eigenvalues and/or right eigenvectors of a complex upper triangular\n* matrix T (or of any matrix Q*T*Q**H with Q unitary).\n*\n\n* Arguments\n* =========\n*\n* JOB (input) CHARACTER*1\n* Specifies whether condition numbers are required for\n* eigenvalues (S) or eigenvectors (SEP):\n* = 'E': for eigenvalues only (S);\n* = 'V': for eigenvectors only (SEP);\n* = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n* HOWMNY (input) CHARACTER*1\n* = 'A': compute condition numbers for all eigenpairs;\n* = 'S': compute condition numbers for selected eigenpairs\n* specified by the array SELECT.\n*\n* SELECT (input) LOGICAL array, dimension (N)\n* If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n* condition numbers are required. To select condition numbers\n* for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n* If HOWMNY = 'A', SELECT is not referenced.\n*\n* N (input) INTEGER\n* The order of the matrix T. N >= 0.\n*\n* T (input) COMPLEX*16 array, dimension (LDT,N)\n* The upper triangular matrix T.\n*\n* LDT (input) INTEGER\n* The leading dimension of the array T. LDT >= max(1,N).\n*\n* VL (input) COMPLEX*16 array, dimension (LDVL,M)\n* If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VL, as returned by\n* ZHSEIN or ZTREVC.\n* If JOB = 'V', VL is not referenced.\n*\n* LDVL (input) INTEGER\n* The leading dimension of the array VL.\n* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n* VR (input) COMPLEX*16 array, dimension (LDVR,M)\n* If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n* (or of any Q*T*Q**H with Q unitary), corresponding to the\n* eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n* must be stored in consecutive columns of VR, as returned by\n* ZHSEIN or ZTREVC.\n* If JOB = 'V', VR is not referenced.\n*\n* LDVR (input) INTEGER\n* The leading dimension of the array VR.\n* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n* S (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'E' or 'B', the reciprocal condition numbers of the\n* selected eigenvalues, stored in consecutive elements of the\n* array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n* all correspond to the same eigenpair (but not in general the\n* j-th eigenpair, unless all eigenpairs are selected).\n* If JOB = 'V', S is not referenced.\n*\n* SEP (output) DOUBLE PRECISION array, dimension (MM)\n* If JOB = 'V' or 'B', the estimated reciprocal condition\n* numbers of the selected eigenvectors, stored in consecutive\n* elements of the array.\n* If JOB = 'E', SEP is not referenced.\n*\n* MM (input) INTEGER\n* The number of elements in the arrays S (if JOB = 'E' or 'B')\n* and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n* M (output) INTEGER\n* The number of elements of the arrays S and/or SEP actually\n* used to store the estimated condition numbers.\n* If HOWMNY = 'A', M is set to N.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+6)\n* If JOB = 'E', WORK is not referenced.\n*\n* LDWORK (input) INTEGER\n* The leading dimension of the array WORK.\n* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n* RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n* If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n* defined as\n*\n* S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n* where u and v are the right and left eigenvectors of T corresponding\n* to lambda; v' denotes the conjugate transpose of v, and norm(u)\n* denotes the Euclidean norm. These reciprocal condition numbers always\n* lie between zero (very badly conditioned) and one (very well\n* conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n* An approximate error bound for a computed eigenvalue W(i) is given by\n*\n* EPS * norm(T) / S(i)\n*\n* where EPS is the machine precision.\n*\n* The reciprocal of the condition number of the right eigenvector u\n* corresponding to lambda is defined as follows. Suppose\n*\n* T = ( lambda c )\n* ( 0 T22 )\n*\n* Then the reciprocal condition number is\n*\n* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n* where sigma-min denotes the smallest singular value. We approximate\n* the smallest singular value by the reciprocal of an estimate of the\n* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n* defined to be abs(T(1,1)).\n*\n* An approximate error bound for a computed right eigenvector VR(i)\n* is given by\n*\n* EPS * norm(T) / SEP(i)\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_job = argv[0];
- rb_howmny = argv[1];
- rb_select = argv[2];
- rb_t = argv[3];
- rb_vl = argv[4];
- rb_vr = argv[5];
- rb_ldwork = argv[6];
-
- howmny = StringValueCStr(rb_howmny)[0];
- if (!NA_IsNArray(rb_t))
- rb_raise(rb_eArgError, "t (4th argument) must be NArray");
- if (NA_RANK(rb_t) != 2)
- rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_t);
- ldt = NA_SHAPE0(rb_t);
- if (NA_TYPE(rb_t) != NA_DCOMPLEX)
- rb_t = na_change_type(rb_t, NA_DCOMPLEX);
- t = NA_PTR_TYPE(rb_t, doublecomplex*);
- if (!NA_IsNArray(rb_vl))
- rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
- if (NA_RANK(rb_vl) != 2)
- rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_vl);
- ldvl = NA_SHAPE0(rb_vl);
- if (NA_TYPE(rb_vl) != NA_DCOMPLEX)
- rb_vl = na_change_type(rb_vl, NA_DCOMPLEX);
- vl = NA_PTR_TYPE(rb_vl, doublecomplex*);
- if (!NA_IsNArray(rb_vr))
- rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
- if (NA_RANK(rb_vr) != 2)
- rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_vr) != m)
- rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
- ldvr = NA_SHAPE0(rb_vr);
- if (NA_TYPE(rb_vr) != NA_DCOMPLEX)
- rb_vr = na_change_type(rb_vr, NA_DCOMPLEX);
- vr = NA_PTR_TYPE(rb_vr, doublecomplex*);
- if (!NA_IsNArray(rb_select))
- rb_raise(rb_eArgError, "select (3th argument) must be NArray");
- if (NA_RANK(rb_select) != 1)
- rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_select) != n)
- rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of t");
- if (NA_TYPE(rb_select) != NA_LINT)
- rb_select = na_change_type(rb_select, NA_LINT);
- select = NA_PTR_TYPE(rb_select, logical*);
- job = StringValueCStr(rb_job)[0];
- ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
- mm = m;
- {
- int shape[1];
- shape[0] = mm;
- rb_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- s = NA_PTR_TYPE(rb_s, doublereal*);
- {
- int shape[1];
- shape[0] = mm;
- rb_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- sep = NA_PTR_TYPE(rb_sep, doublereal*);
- work = ALLOC_N(doublecomplex, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
- rwork = ALLOC_N(doublereal, (lsame_(&job,"E") ? 0 : n));
-
- ztrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, rwork, &info);
-
- free(work);
- free(rwork);
- rb_m = INT2NUM(m);
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_s, rb_sep, rb_m, rb_info);
-}
-
-void
-init_lapack_ztrsna(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrsna", rb_ztrsna, -1);
-}
diff --git a/ztrsyl.c b/ztrsyl.c
deleted file mode 100644
index 9364ba2..0000000
--- a/ztrsyl.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *c, integer *ldc, doublereal *scale, integer *info);
-
-static VALUE
-rb_ztrsyl(int argc, VALUE *argv, VALUE self){
- VALUE rb_trana;
- char trana;
- VALUE rb_tranb;
- char tranb;
- VALUE rb_isgn;
- integer isgn;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_scale;
- doublereal scale;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer m;
- integer ldb;
- integer n;
- integer ldc;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n scale, info, c = NumRu::Lapack.ztrsyl( trana, tranb, isgn, a, b, c)\n or\n NumRu::Lapack.ztrsyl # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n* Purpose\n* =======\n*\n* ZTRSYL solves the complex Sylvester matrix equation:\n*\n* op(A)*X + X*op(B) = scale*C or\n* op(A)*X - X*op(B) = scale*C,\n*\n* where op(A) = A or A**H, and A and B are both upper triangular. A is\n* M-by-M and B is N-by-N; the right hand side C and the solution X are\n* M-by-N; and scale is an output scale factor, set <= 1 to avoid\n* overflow in X.\n*\n\n* Arguments\n* =========\n*\n* TRANA (input) CHARACTER*1\n* Specifies the option op(A):\n* = 'N': op(A) = A (No transpose)\n* = 'C': op(A) = A**H (Conjugate transpose)\n*\n* TRANB (input) CHARACTER*1\n* Specifies the option op(B):\n* = 'N': op(B) = B (No transpose)\n* = 'C': op(B) = B**H (Conjugate transpose)\n*\n* ISGN (input) INTEGER\n* Specifies the sign in the equation:\n* = +1: solve op(A)*X + X*op(B) = scale*C\n* = -1: solve op(A)*X - X*op(B) = scale*C\n*\n* M (input) INTEGER\n* The order of the matrix A, and the number of rows in the\n* matrices X and C. M >= 0.\n*\n* N (input) INTEGER\n* The order of the matrix B, and the number of columns in the\n* matrices X and C. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,M)\n* The upper triangular matrix A.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* B (input) COMPLEX*16 array, dimension (LDB,N)\n* The upper 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) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N right hand side matrix C.\n* On exit, C is overwritten by the solution matrix X.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M)\n*\n* SCALE (output) DOUBLE PRECISION\n* The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* = 1: A and B have common or very close eigenvalues; perturbed\n* values were used to solve the equation (but the matrices\n* A and B are unchanged).\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_trana = argv[0];
- rb_tranb = argv[1];
- rb_isgn = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- trana = StringValueCStr(rb_trana)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_c) != n)
- rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- tranb = StringValueCStr(rb_tranb)[0];
- isgn = NUM2INT(rb_isgn);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- ztrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);
-
- rb_scale = rb_float_new((double)scale);
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_scale, rb_info, rb_c);
-}
-
-void
-init_lapack_ztrsyl(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrsyl", rb_ztrsyl, -1);
-}
diff --git a/ztrti2.c b/ztrti2.c
deleted file mode 100644
index 6274c4d..0000000
--- a/ztrti2.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrti2_(char *uplo, char *diag, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ztrti2(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ztrti2( uplo, diag, a)\n or\n NumRu::Lapack.ztrti2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTI2 computes the inverse of a complex upper or lower triangular\n* matrix.\n*\n* This is the Level 2 BLAS version of the algorithm.\n*\n\n* Arguments\n* =========\n*\n* UPLO (input) CHARACTER*1\n* Specifies whether the matrix A is upper or lower triangular.\n* = 'U': Upper triangular\n* = 'L': Lower triangular\n*\n* DIAG (input) CHARACTER*1\n* Specifies whether or not the matrix A is unit triangular.\n* = 'N': Non-unit triangular\n* = 'U': Unit 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 triangular matrix A. If UPLO = 'U', the\n* leading n by n upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n*\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ztrti2_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ztrti2(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrti2", rb_ztrti2, -1);
-}
diff --git a/ztrtri.c b/ztrtri.c
deleted file mode 100644
index be0ce72..0000000
--- a/ztrtri.c
+++ /dev/null
@@ -1,62 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrtri_(char *uplo, char *diag, integer *n, doublecomplex *a, integer *lda, integer *info);
-
-static VALUE
-rb_ztrtri(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.ztrtri( uplo, diag, a)\n or\n NumRu::Lapack.ztrtri # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTRI computes the inverse of a complex upper or lower triangular\n* matrix A.\n*\n* This is the Level 3 BLAS version of the algorithm.\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* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced. If DIAG = 'U', the\n* diagonal elements of A are also not referenced and are\n* assumed to be 1.\n* On exit, the (triangular) inverse of the original matrix, in\n* the same storage format.\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 = -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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_diag = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ztrtri_(&uplo, &diag, &n, a, &lda, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_ztrtri(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrtri", rb_ztrtri, -1);
-}
diff --git a/ztrtrs.c b/ztrtrs.c
deleted file mode 100644
index a62aa24..0000000
--- a/ztrtrs.c
+++ /dev/null
@@ -1,80 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info);
-
-static VALUE
-rb_ztrtrs(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_diag;
- char diag;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_b;
- doublecomplex *b;
- VALUE rb_info;
- integer info;
- VALUE rb_b_out__;
- doublecomplex *b_out__;
-
- integer lda;
- integer n;
- integer ldb;
- integer nrhs;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, b = NumRu::Lapack.ztrtrs( uplo, trans, diag, a, b)\n or\n NumRu::Lapack.ztrtrs # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTRS solves a triangular system of the form\n*\n* A * X = B, A**T * X = B, or A**H * X = B,\n*\n* where A is a triangular matrix of order N, and B is an N-by-NRHS\n* matrix. A check is made to verify that A is nonsingular.\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)\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 matrix B. NRHS >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* The triangular matrix A. If UPLO = 'U', the leading N-by-N\n* upper triangular part of the array A contains the upper\n* triangular matrix, and the strictly lower triangular part of\n* A is not referenced. If UPLO = 'L', the leading N-by-N lower\n* triangular part of the array A contains the lower triangular\n* matrix, and the strictly upper triangular part of A is not\n* referenced. If DIAG = 'U', the diagonal elements of A are\n* also not referenced and are assumed to be 1.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n* On entry, the right hand side matrix B.\n* On exit, if INFO = 0, the solution matrix X.\n*\n* LDB (input) INTEGER\n* The leading dimension of the array B. LDB >= max(1,N).\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument had an illegal value\n* > 0: if INFO = i, the i-th diagonal element of A is zero,\n* indicating that the matrix is singular and the solutions\n* X have not been computed.\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_uplo = argv[0];
- rb_trans = argv[1];
- rb_diag = argv[2];
- rb_a = argv[3];
- rb_b = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_b))
- rb_raise(rb_eArgError, "b (5th argument) must be NArray");
- if (NA_RANK(rb_b) != 2)
- rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
- nrhs = NA_SHAPE1(rb_b);
- ldb = NA_SHAPE0(rb_b);
- if (NA_TYPE(rb_b) != NA_DCOMPLEX)
- rb_b = na_change_type(rb_b, NA_DCOMPLEX);
- b = NA_PTR_TYPE(rb_b, doublecomplex*);
- diag = StringValueCStr(rb_diag)[0];
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[2];
- shape[0] = ldb;
- shape[1] = nrhs;
- rb_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- b_out__ = NA_PTR_TYPE(rb_b_out__, doublecomplex*);
- MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rb_b));
- rb_b = rb_b_out__;
- b = b_out__;
-
- ztrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_b);
-}
-
-void
-init_lapack_ztrtrs(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrtrs", rb_ztrtrs, -1);
-}
diff --git a/ztrttf.c b/ztrttf.c
deleted file mode 100644
index e0dcb96..0000000
--- a/ztrttf.c
+++ /dev/null
@@ -1,58 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrttf_(char *transr, char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *arf, integer *info);
-
-static VALUE
-rb_ztrttf(int argc, VALUE *argv, VALUE self){
- VALUE rb_transr;
- char transr;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_arf;
- doublecomplex *arf;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n arf, info = NumRu::Lapack.ztrttf( transr, uplo, a)\n or\n NumRu::Lapack.ztrttf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTTF copies a triangular matrix A from standard full format (TR)\n* to rectangular full packed format (TF) .\n*\n\n* Arguments\n* =========\n*\n* TRANSR (input) CHARACTER*1\n* = 'N': ARF in Normal mode is wanted;\n* = 'C': ARF in Conjugate Transpose mode is wanted;\n*\n* UPLO (input) CHARACTER*1\n* = 'U': A is upper triangular;\n* = 'L': A is lower triangular.\n*\n* N (input) INTEGER\n* The order of the matrix A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension ( LDA, N ) \n* On entry, the triangular matrix A. If UPLO = 'U', the\n* leading N-by-N upper triangular part of the array A contains\n* the upper triangular matrix, 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 the array A contains\n* the lower triangular matrix, and the strictly upper\n* triangular part of A is not referenced.\n*\n* LDA (input) INTEGER\n* The leading dimension of the matrix A. LDA >= max(1,N).\n*\n* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A stored in\n* RFP format. For a further discussion see Notes below.\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* We first consider Standard Packed Format when N is even.\n* We give an example where N = 6.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 05 00\n* 11 12 13 14 15 10 11\n* 22 23 24 25 20 21 22\n* 33 34 35 30 31 32 33\n* 44 45 40 41 42 43 44\n* 55 50 51 52 53 54 55\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n* conjugate-transpose of the first three columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n* conjugate-transpose of the last three columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N even and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- -- --\n* 03 04 05 33 43 53\n* -- --\n* 13 14 15 00 44 54\n* --\n* 23 24 25 10 11 55\n*\n* 33 34 35 20 21 22\n* --\n* 00 44 45 30 31 32\n* -- --\n* 01 11 55 40 41 42\n* -- -- --\n* 02 12 22 50 51 52\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- -- --\n* 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n* -- -- -- -- -- -- -- -- -- --\n* 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n*\n*\n* We next consider Standard Packed Format when N is odd.\n* We give an example where N = 5.\n*\n* AP is Upper AP is Lower\n*\n* 00 01 02 03 04 00\n* 11 12 13 14 10 11\n* 22 23 24 20 21 22\n* 33 34 30 31 32 33\n* 44 40 41 42 43 44\n*\n*\n* Let TRANSR = `N'. RFP holds AP as follows:\n* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n* three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n* conjugate-transpose of the first two columns of AP upper.\n* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n* three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n* conjugate-transpose of the last two columns of AP lower.\n* To denote conjugate we place -- above the element. This covers the\n* case N odd and TRANSR = `N'.\n*\n* RFP A RFP A\n*\n* -- --\n* 02 03 04 00 33 43\n* --\n* 12 13 14 10 11 44\n*\n* 22 23 24 20 21 22\n* --\n* 00 33 34 30 31 32\n* -- --\n* 01 11 44 40 41 42\n*\n* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n* transpose of RFP A above. One therefore gets:\n*\n*\n* RFP A RFP A\n*\n* -- -- -- -- -- -- -- -- --\n* 02 12 22 00 01 00 10 20 30 40 50\n* -- -- -- -- -- -- -- -- --\n* 03 13 23 33 11 33 11 21 31 41 51\n* -- -- -- -- -- -- -- -- --\n* 04 14 24 34 44 43 44 22 32 42 52\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_transr = argv[0];
- rb_uplo = argv[1];
- rb_a = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- transr = StringValueCStr(rb_transr)[0];
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- arf = NA_PTR_TYPE(rb_arf, doublecomplex*);
-
- ztrttf_(&transr, &uplo, &n, a, &lda, arf, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_arf, rb_info);
-}
-
-void
-init_lapack_ztrttf(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrttf", rb_ztrttf, -1);
-}
diff --git a/ztrttp.c b/ztrttp.c
deleted file mode 100644
index 31552f7..0000000
--- a/ztrttp.c
+++ /dev/null
@@ -1,54 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztrttp_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *ap, integer *info);
-
-static VALUE
-rb_ztrttp(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_info;
- integer info;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n ap, info = NumRu::Lapack.ztrttp( uplo, a)\n or\n NumRu::Lapack.ztrttp # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n* Purpose\n* =======\n*\n* ZTRTTP copies a triangular matrix A from full format (TR) to standard\n* packed format (TP).\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* N (input) INTEGER\n* The order of the matrices AP and A. N >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the triangular 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* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n* On exit, the upper or lower triangular matrix A, packed\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)*(2n-j)/2) = A(i,j) for j<=i<=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 (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- uplo = StringValueCStr(rb_uplo)[0];
- {
- int shape[1];
- shape[0] = ( n*(n+1)/2 );
- rb_ap = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
-
- ztrttp_(&uplo, &n, a, &lda, ap, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_ap, rb_info);
-}
-
-void
-init_lapack_ztrttp(VALUE mLapack){
- rb_define_module_function(mLapack, "ztrttp", rb_ztrttp, -1);
-}
diff --git a/ztzrqf.c b/ztzrqf.c
deleted file mode 100644
index 85af37c..0000000
--- a/ztzrqf.c
+++ /dev/null
@@ -1,64 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztzrqf_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, integer *info);
-
-static VALUE
-rb_ztzrqf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, info, a = NumRu::Lapack.ztzrqf( a)\n or\n NumRu::Lapack.ztzrqf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO )\n\n* Purpose\n* =======\n*\n* This routine is deprecated and has been replaced by routine ZTZRZF.\n*\n* ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (M)\n* The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), whose conjugate transpose is used to\n* introduce zeros into the (m - k + 1)th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 1)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
- rb_a = argv[0];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ztzrqf_(&m, &n, a, &lda, tau, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_tau, rb_info, rb_a);
-}
-
-void
-init_lapack_ztzrqf(VALUE mLapack){
- rb_define_module_function(mLapack, "ztzrqf", rb_ztzrqf, -1);
-}
diff --git a/ztzrzf.c b/ztzrzf.c
deleted file mode 100644
index 5e2d4c7..0000000
--- a/ztzrzf.c
+++ /dev/null
@@ -1,76 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID ztzrzf_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_ztzrzf(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n tau, work, info, a = NumRu::Lapack.ztzrzf( a, lwork)\n or\n NumRu::Lapack.ztzrzf # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n* to upper triangular form by means of unitary transformations.\n*\n* The upper trapezoidal matrix A is factored as\n*\n* A = ( R 0 ) * Z,\n*\n* where Z is an N-by-N unitary matrix and R is an M-by-M upper\n* triangular matrix.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix A. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix A. N >= M.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the leading M-by-N upper trapezoidal part of the\n* array A must contain the matrix to be factorized.\n* On exit, the leading M-by-M upper triangular part of A\n* contains the upper triangular matrix R, and elements M+1 to\n* N of the first M rows of A, with the array TAU, represent the\n* unitary matrix Z as a product of M elementary reflectors.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,M).\n*\n* TAU (output) COMPLEX*16 array, dimension (M)\n* The scalar factors of the elementary reflectors.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* The factorization is obtained by Householder's method. The kth\n* transformation matrix, Z( k ), which is used to introduce zeros into\n* the ( m - k + 1 )th row of A, is given in the form\n*\n* Z( k ) = ( I 0 ),\n* ( 0 T( k ) )\n*\n* where\n*\n* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n* ( 0 )\n* ( z( k ) )\n*\n* tau is a scalar and z( k ) is an ( n - m ) element vector.\n* tau and z( k ) are chosen to annihilate the elements of the kth row\n* of X.\n*\n* The scalar tau is returned in the kth element of TAU and the vector\n* u( k ) in the kth row of A, such that the elements of z( k ) are\n* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n* the upper triangular part of A.\n*\n* Z is given by\n*\n* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_lwork = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- m = lda;
- {
- int shape[1];
- shape[0] = m;
- rb_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- ztzrzf_(&m, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(4, rb_tau, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_ztzrzf(VALUE mLapack){
- rb_define_module_function(mLapack, "ztzrzf", rb_ztzrzf, -1);
-}
diff --git a/zunbdb.c b/zunbdb.c
deleted file mode 100644
index a243561..0000000
--- a/zunbdb.c
+++ /dev/null
@@ -1,216 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunbdb_(char *trans, char *signs, integer *m, integer *p, integer *q, doublecomplex *x11, integer *ldx11, doublecomplex *x12, integer *ldx12, doublecomplex *x21, integer *ldx21, doublecomplex *x22, integer *ldx22, doublereal *theta, doublereal *phi, doublecomplex *taup1, doublecomplex *taup2, doublecomplex *tauq1, doublecomplex *tauq2, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunbdb(int argc, VALUE *argv, VALUE self){
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- doublecomplex *x11;
- VALUE rb_x12;
- doublecomplex *x12;
- VALUE rb_x21;
- doublecomplex *x21;
- VALUE rb_x22;
- doublecomplex *x22;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_theta;
- doublereal *theta;
- VALUE rb_phi;
- doublereal *phi;
- VALUE rb_taup1;
- doublecomplex *taup1;
- VALUE rb_taup2;
- doublecomplex *taup2;
- VALUE rb_tauq1;
- doublecomplex *tauq1;
- VALUE rb_tauq2;
- doublecomplex *tauq2;
- VALUE rb_info;
- integer info;
- VALUE rb_x11_out__;
- doublecomplex *x11_out__;
- VALUE rb_x12_out__;
- doublecomplex *x12_out__;
- VALUE rb_x21_out__;
- doublecomplex *x21_out__;
- VALUE rb_x22_out__;
- doublecomplex *x22_out__;
- doublecomplex *work;
-
- integer ldx11;
- integer q;
- integer ldx12;
- integer ldx21;
- integer ldx22;
- integer p;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.zunbdb( trans, signs, m, x11, x12, x21, x22, lwork)\n or\n NumRu::Lapack.zunbdb # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNBDB( 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* ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n* partitioned unitary matrix X:\n*\n* [ B11 | B12 0 0 ]\n* [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H\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 ZUNCSD\n* for details.)\n*\n* The unitary 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) COMPLEX*16 array, dimension (LDX11,Q)\n* On entry, the top-left block of the unitary 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) COMPLEX*16 array, dimension (LDX12,M-Q)\n* On entry, the top-right block of the unitary 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) COMPLEX*16 array, dimension (LDX21,Q)\n* On entry, the bottom-left block of the unitary 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) COMPLEX*16 array, dimension (LDX22,M-Q)\n* On entry, the bottom-right block of the unitary 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) COMPLEX*16 array, dimension (P)\n* The scalar factors of the elementary reflectors that define\n* P1.\n*\n* TAUP2 (output) COMPLEX*16 array, dimension (M-P)\n* The scalar factors of the elementary reflectors that define\n* P2.\n*\n* TAUQ1 (output) COMPLEX*16 array, dimension (Q)\n* The scalar factors of the elementary reflectors that define\n* Q1.\n*\n* TAUQ2 (output) COMPLEX*16 array, dimension (M-Q)\n* The scalar factors of the elementary reflectors that define\n* Q2.\n*\n* WORK (workspace) COMPLEX*16 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 ZUNCSD for details.\n*\n* P1, P2, Q1, and Q2 are represented as products of elementary\n* reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2\n* using ZUNGQR and ZUNGLQ.\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 (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_trans = argv[0];
- rb_signs = argv[1];
- rb_m = argv[2];
- rb_x11 = argv[3];
- rb_x12 = argv[4];
- rb_x21 = argv[5];
- rb_x22 = argv[6];
- rb_lwork = argv[7];
-
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- signs = StringValueCStr(rb_signs)[0];
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- ldx21 = NA_SHAPE0(rb_x21);
- if (ldx21 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x21 must be %d", p);
- p = ldx21;
- if (NA_TYPE(rb_x21) != NA_DCOMPLEX)
- rb_x21 = na_change_type(rb_x21, NA_DCOMPLEX);
- x21 = NA_PTR_TYPE(rb_x21, doublecomplex*);
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- ldx11 = NA_SHAPE0(rb_x11);
- if (ldx11 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x11 must be %d", p);
- p = ldx11;
- if (NA_TYPE(rb_x11) != NA_DCOMPLEX)
- rb_x11 = na_change_type(rb_x11, NA_DCOMPLEX);
- x11 = NA_PTR_TYPE(rb_x11, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- ldx22 = NA_SHAPE0(rb_x22);
- if (ldx22 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be %d", p);
- p = ldx22;
- if (NA_TYPE(rb_x22) != NA_DCOMPLEX)
- rb_x22 = na_change_type(rb_x22, NA_DCOMPLEX);
- x22 = NA_PTR_TYPE(rb_x22, doublecomplex*);
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- ldx12 = NA_SHAPE0(rb_x12);
- if (ldx12 != (p))
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be %d", p);
- p = ldx12;
- if (NA_TYPE(rb_x12) != NA_DCOMPLEX)
- rb_x12 = na_change_type(rb_x12, NA_DCOMPLEX);
- x12 = NA_PTR_TYPE(rb_x12, doublecomplex*);
- ldx12 = p;
- ldx22 = p;
- ldx21 = p;
- ldx11 = p;
- {
- int shape[1];
- shape[0] = q;
- rb_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, doublereal*);
- {
- int shape[1];
- shape[0] = q-1;
- rb_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- phi = NA_PTR_TYPE(rb_phi, doublereal*);
- {
- int shape[1];
- shape[0] = p;
- rb_taup1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taup1 = NA_PTR_TYPE(rb_taup1, doublecomplex*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_taup2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- taup2 = NA_PTR_TYPE(rb_taup2, doublecomplex*);
- {
- int shape[1];
- shape[0] = q;
- rb_tauq1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tauq1 = NA_PTR_TYPE(rb_tauq1, doublecomplex*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_tauq2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- tauq2 = NA_PTR_TYPE(rb_tauq2, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldx11;
- shape[1] = q;
- rb_x11_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x11_out__ = NA_PTR_TYPE(rb_x11_out__, doublecomplex*);
- MEMCPY(x11_out__, x11, doublecomplex, NA_TOTAL(rb_x11));
- rb_x11 = rb_x11_out__;
- x11 = x11_out__;
- {
- int shape[2];
- shape[0] = ldx12;
- shape[1] = m-q;
- rb_x12_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x12_out__ = NA_PTR_TYPE(rb_x12_out__, doublecomplex*);
- MEMCPY(x12_out__, x12, doublecomplex, NA_TOTAL(rb_x12));
- rb_x12 = rb_x12_out__;
- x12 = x12_out__;
- {
- int shape[2];
- shape[0] = ldx21;
- shape[1] = q;
- rb_x21_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x21_out__ = NA_PTR_TYPE(rb_x21_out__, doublecomplex*);
- MEMCPY(x21_out__, x21, doublecomplex, NA_TOTAL(rb_x21));
- rb_x21 = rb_x21_out__;
- x21 = x21_out__;
- {
- int shape[2];
- shape[0] = ldx22;
- shape[1] = m-q;
- rb_x22_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- x22_out__ = NA_PTR_TYPE(rb_x22_out__, doublecomplex*);
- MEMCPY(x22_out__, x22, doublecomplex, NA_TOTAL(rb_x22));
- rb_x22 = rb_x22_out__;
- x22 = x22_out__;
- work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
-
- zunbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(11, rb_theta, rb_phi, rb_taup1, rb_taup2, rb_tauq1, rb_tauq2, rb_info, rb_x11, rb_x12, rb_x21, rb_x22);
-}
-
-void
-init_lapack_zunbdb(VALUE mLapack){
- rb_define_module_function(mLapack, "zunbdb", rb_zunbdb, -1);
-}
diff --git a/zuncsd.c b/zuncsd.c
deleted file mode 100644
index abee969..0000000
--- a/zuncsd.c
+++ /dev/null
@@ -1,201 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zuncsd_(char *jobu1, char *jobu2, char *jobv1t, char *jobv2t, char *trans, char *signs, integer *m, integer *p, integer *q, doublecomplex *x11, integer *ldx11, doublecomplex *x12, integer *ldx12, doublecomplex *x21, integer *ldx21, doublecomplex *x22, integer *ldx22, doublereal *theta, doublecomplex *u1, integer *ldu1, doublecomplex *u2, integer *ldu2, doublecomplex *v1t, integer *ldv1t, doublecomplex *v2t, integer *ldv2t, doublecomplex *work, integer *lwork, doublereal *rwork, integer *lrwork, integer *iwork, integer *info);
-
-static VALUE
-rb_zuncsd(int argc, VALUE *argv, VALUE self){
- VALUE rb_jobu1;
- char jobu1;
- VALUE rb_jobu2;
- char jobu2;
- VALUE rb_jobv1t;
- char jobv1t;
- VALUE rb_jobv2t;
- char jobv2t;
- VALUE rb_trans;
- char trans;
- VALUE rb_signs;
- char signs;
- VALUE rb_m;
- integer m;
- VALUE rb_x11;
- doublecomplex *x11;
- VALUE rb_ldx11;
- integer ldx11;
- VALUE rb_x12;
- doublecomplex *x12;
- VALUE rb_ldx12;
- integer ldx12;
- VALUE rb_x21;
- doublecomplex *x21;
- VALUE rb_ldx21;
- integer ldx21;
- VALUE rb_x22;
- doublecomplex *x22;
- VALUE rb_ldx22;
- integer ldx22;
- VALUE rb_ldu1;
- integer ldu1;
- VALUE rb_ldu2;
- integer ldu2;
- VALUE rb_ldv1t;
- integer ldv1t;
- VALUE rb_ldv2t;
- integer ldv2t;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_lrwork;
- integer lrwork;
- VALUE rb_theta;
- doublereal *theta;
- VALUE rb_u1;
- doublecomplex *u1;
- VALUE rb_u2;
- doublecomplex *u2;
- VALUE rb_v1t;
- doublecomplex *v1t;
- VALUE rb_v2t;
- doublecomplex *v2t;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
- doublereal *rwork;
- integer *iwork;
-
- integer p;
- integer q;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n theta, u1, u2, v1t, v2t, info = NumRu::Lapack.zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, ldx11, x12, ldx12, x21, ldx21, x22, ldx22, ldu1, ldu2, ldv1t, ldv2t, lwork, lrwork)\n or\n NumRu::Lapack.zuncsd # print help\n\n\nFORTRAN MANUAL\n RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNCSD computes the CS decomposition of an M-by-M partitioned\n* unitary matrix X:\n*\n* [ I 0 0 | 0 0 0 ]\n* [ 0 C 0 | 0 -S 0 ]\n* [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H\n* X = [-----------] = [---------] [---------------------] [---------] .\n* [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n* [ 0 S 0 | 0 C 0 ]\n* [ 0 0 I | 0 0 0 ]\n*\n* X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n* (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n* R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n* which R = MIN(P,M-P,Q,M-Q).\n*\n\n* Arguments\n* =========\n*\n* JOBU1 (input) CHARACTER\n* = 'Y': U1 is computed;\n* otherwise: U1 is not computed.\n*\n* JOBU2 (input) CHARACTER\n* = 'Y': U2 is computed;\n* otherwise: U2 is not computed.\n*\n* JOBV1T (input) CHARACTER\n* = 'Y': V1T is computed;\n* otherwise: V1T is not computed.\n*\n* JOBV2T (input) CHARACTER\n* = 'Y': V2T is computed;\n* otherwise: V2T is not computed.\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 <= M.\n*\n* X (input/workspace) COMPLEX*16 array, dimension (LDX,M)\n* On entry, the unitary matrix whose CSD is desired.\n*\n* LDX (input) INTEGER\n* The leading dimension of X. LDX >= MAX(1,M).\n*\n* THETA (output) DOUBLE PRECISION array, dimension (R), in which R =\n* MIN(P,M-P,Q,M-Q).\n* C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n* S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n* U1 (output) COMPLEX*16 array, dimension (P)\n* If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n*\n* LDU1 (input) INTEGER\n* The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n* MAX(1,P).\n*\n* U2 (output) COMPLEX*16 array, dimension (M-P)\n* If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n* matrix U2.\n*\n* LDU2 (input) INTEGER\n* The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n* MAX(1,M-P).\n*\n* V1T (output) COMPLEX*16 array, dimension (Q)\n* If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n* matrix V1**H.\n*\n* LDV1T (input) INTEGER\n* The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n* MAX(1,Q).\n*\n* V2T (output) COMPLEX*16 array, dimension (M-Q)\n* If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n* matrix V2**H.\n*\n* LDV2T (input) INTEGER\n* The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n* MAX(1,M-Q).\n*\n* WORK (workspace) COMPLEX*16 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.\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* RWORK (workspace) DOUBLE PRECISION array, dimension MAX(1,LRWORK)\n* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n* If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n* ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n* define the matrix in intermediate bidiagonal-block form\n* remaining after nonconvergence. INFO specifies the number\n* of nonzero PHI's.\n*\n* LRWORK (input) INTEGER\n* The dimension of the array RWORK.\n*\n* If LRWORK = -1, then a workspace query is assumed; the routine\n* only calculates the optimal size of the RWORK array, returns\n* this value as the first entry of the work array, and no error\n* message related to LRWORK is issued by XERBLA.\n*\n* IWORK (workspace) INTEGER array, dimension (M-Q)\n*\n* INFO (output) INTEGER\n* = 0: successful exit.\n* < 0: if INFO = -i, the i-th argument had an illegal value.\n* > 0: ZBBCSD did not converge. See the description of RWORK\n* above for details.\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\n");
- return Qnil;
- }
- if (argc != 21)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
- rb_jobu1 = argv[0];
- rb_jobu2 = argv[1];
- rb_jobv1t = argv[2];
- rb_jobv2t = argv[3];
- rb_trans = argv[4];
- rb_signs = argv[5];
- rb_m = argv[6];
- rb_x11 = argv[7];
- rb_ldx11 = argv[8];
- rb_x12 = argv[9];
- rb_ldx12 = argv[10];
- rb_x21 = argv[11];
- rb_ldx21 = argv[12];
- rb_x22 = argv[13];
- rb_ldx22 = argv[14];
- rb_ldu1 = argv[15];
- rb_ldu2 = argv[16];
- rb_ldv1t = argv[17];
- rb_ldv2t = argv[18];
- rb_lwork = argv[19];
- rb_lrwork = argv[20];
-
- trans = StringValueCStr(rb_trans)[0];
- jobv1t = StringValueCStr(rb_jobv1t)[0];
- jobv2t = StringValueCStr(rb_jobv2t)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_x21))
- rb_raise(rb_eArgError, "x21 (12th argument) must be NArray");
- if (NA_RANK(rb_x21) != 2)
- rb_raise(rb_eArgError, "rank of x21 (12th argument) must be %d", 2);
- q = NA_SHAPE1(rb_x21);
- p = NA_SHAPE0(rb_x21);
- if (NA_TYPE(rb_x21) != NA_DCOMPLEX)
- rb_x21 = na_change_type(rb_x21, NA_DCOMPLEX);
- x21 = NA_PTR_TYPE(rb_x21, doublecomplex*);
- signs = StringValueCStr(rb_signs)[0];
- jobu1 = StringValueCStr(rb_jobu1)[0];
- lrwork = NUM2INT(rb_lrwork);
- jobu2 = StringValueCStr(rb_jobu2)[0];
- if (!NA_IsNArray(rb_x11))
- rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
- if (NA_RANK(rb_x11) != 2)
- rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x11) != q)
- rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
- if (NA_SHAPE0(rb_x11) != p)
- rb_raise(rb_eRuntimeError, "shape 0 of x11 must be the same as shape 0 of x21");
- if (NA_TYPE(rb_x11) != NA_DCOMPLEX)
- rb_x11 = na_change_type(rb_x11, NA_DCOMPLEX);
- x11 = NA_PTR_TYPE(rb_x11, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_x22))
- rb_raise(rb_eArgError, "x22 (14th argument) must be NArray");
- if (NA_RANK(rb_x22) != 2)
- rb_raise(rb_eArgError, "rank of x22 (14th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x22) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
- if (NA_SHAPE0(rb_x22) != p)
- rb_raise(rb_eRuntimeError, "shape 0 of x22 must be the same as shape 0 of x21");
- if (NA_TYPE(rb_x22) != NA_DCOMPLEX)
- rb_x22 = na_change_type(rb_x22, NA_DCOMPLEX);
- x22 = NA_PTR_TYPE(rb_x22, doublecomplex*);
- ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
- ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
- if (!NA_IsNArray(rb_x12))
- rb_raise(rb_eArgError, "x12 (10th argument) must be NArray");
- if (NA_RANK(rb_x12) != 2)
- rb_raise(rb_eArgError, "rank of x12 (10th argument) must be %d", 2);
- if (NA_SHAPE1(rb_x12) != (m-q))
- rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
- if (NA_SHAPE0(rb_x12) != p)
- rb_raise(rb_eRuntimeError, "shape 0 of x12 must be the same as shape 0 of x21");
- if (NA_TYPE(rb_x12) != NA_DCOMPLEX)
- rb_x12 = na_change_type(rb_x12, NA_DCOMPLEX);
- x12 = NA_PTR_TYPE(rb_x12, doublecomplex*);
- ldx12 = p;
- ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
- ldx11 = p;
- ldx22 = p;
- ldx21 = p;
- ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
- {
- int shape[1];
- shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
- rb_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
- }
- theta = NA_PTR_TYPE(rb_theta, doublereal*);
- {
- int shape[1];
- shape[0] = p;
- rb_u1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- u1 = NA_PTR_TYPE(rb_u1, doublecomplex*);
- {
- int shape[1];
- shape[0] = m-p;
- rb_u2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- u2 = NA_PTR_TYPE(rb_u2, doublecomplex*);
- {
- int shape[1];
- shape[0] = q;
- rb_v1t = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- v1t = NA_PTR_TYPE(rb_v1t, doublecomplex*);
- {
- int shape[1];
- shape[0] = m-q;
- rb_v2t = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- v2t = NA_PTR_TYPE(rb_v2t, doublecomplex*);
- work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
- rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
- iwork = ALLOC_N(integer, (m-q));
-
- zuncsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, rwork, &lrwork, iwork, &info);
-
- free(work);
- free(rwork);
- free(iwork);
- rb_info = INT2NUM(info);
- return rb_ary_new3(6, rb_theta, rb_u1, rb_u2, rb_v1t, rb_v2t, rb_info);
-}
-
-void
-init_lapack_zuncsd(VALUE mLapack){
- rb_define_module_function(mLapack, "zuncsd", rb_zuncsd, -1);
-}
diff --git a/zung2l.c b/zung2l.c
deleted file mode 100644
index 8d8efbb..0000000
--- a/zung2l.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zung2l_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zung2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zung2l( m, a, tau)\n or\n NumRu::Lapack.zung2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNG2L generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the last n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQLF in the last k columns of its array\n* argument A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zung2l_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zung2l(VALUE mLapack){
- rb_define_module_function(mLapack, "zung2l", rb_zung2l, -1);
-}
diff --git a/zung2r.c b/zung2r.c
deleted file mode 100644
index 7b05ebe..0000000
--- a/zung2r.c
+++ /dev/null
@@ -1,73 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zung2r_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zung2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zung2r( m, a, tau)\n or\n NumRu::Lapack.zung2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNG2R generates an m by n complex matrix Q with orthonormal columns,\n* which is defined as the first n columns of a product of k elementary\n* reflectors of order m\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQRF in the first k columns of its array\n* argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (N)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (n));
-
- zung2r_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zung2r(VALUE mLapack){
- rb_define_module_function(mLapack, "zung2r", rb_zung2r, -1);
-}
diff --git a/zungbr.c b/zungbr.c
deleted file mode 100644
index 55ca77f..0000000
--- a/zungbr.c
+++ /dev/null
@@ -1,90 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zungbr_(char *vect, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zungbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungbr( vect, m, k, a, tau, lwork)\n or\n NumRu::Lapack.zungbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGBR generates one of the complex unitary matrices Q or P**H\n* determined by ZGEBRD when reducing a complex matrix A to bidiagonal\n* form: A = Q * B * P**H. Q and P**H are defined as products of\n* elementary reflectors H(i) or G(i) respectively.\n*\n* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n* is of order M:\n* if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n\n* columns of Q, where m >= n >= k;\n* if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an\n* M-by-M matrix.\n*\n* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n* is of order N:\n* if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m\n* rows of P**H, where n >= m >= k;\n* if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as\n* an N-by-N matrix.\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* Specifies whether the matrix Q or the matrix P**H is\n* required, as defined in the transformation applied by ZGEBRD:\n* = 'Q': generate Q;\n* = 'P': generate P**H.\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q or P**H to be returned.\n* M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q or P**H to be returned.\n* N >= 0.\n* If VECT = 'Q', M >= N >= min(M,K);\n* if VECT = 'P', N >= M >= min(N,K).\n*\n* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original M-by-K\n* matrix reduced by ZGEBRD.\n* If VECT = 'P', the number of rows in the original K-by-N\n* matrix reduced by ZGEBRD.\n* K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by ZGEBRD.\n* On exit, the M-by-N matrix Q or P**H.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= M.\n*\n* TAU (input) COMPLEX*16 array, dimension\n* (min(M,K)) if VECT = 'Q'\n* (min(N,K)) if VECT = 'P'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i), which determines Q or P**H, as\n* returned by ZGEBRD in its array argument TAUQ or TAUP.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,min(M,N)).\n* For optimum performance LWORK >= min(M,N)*NB, where NB\n* is the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_vect = argv[0];
- rb_m = argv[1];
- rb_k = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_lwork = argv[5];
-
- k = NUM2INT(rb_k);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(m,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zungbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zungbr(VALUE mLapack){
- rb_define_module_function(mLapack, "zungbr", rb_zungbr, -1);
-}
diff --git a/zunghr.c b/zunghr.c
deleted file mode 100644
index 1cb0847..0000000
--- a/zunghr.c
+++ /dev/null
@@ -1,86 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunghr_(integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunghr(int argc, VALUE *argv, VALUE self){
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zunghr( ilo, ihi, a, tau, lwork)\n or\n NumRu::Lapack.zunghr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGHR generates a complex unitary matrix Q which is defined as the\n* product of IHI-ILO elementary reflectors of order N, as returned by\n* ZGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of ZGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by ZGEHRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEHRD.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= IHI-ILO.\n* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_ilo = argv[0];
- rb_ihi = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_lwork = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ilo = NUM2INT(rb_ilo);
- ihi = NUM2INT(rb_ihi);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zunghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zunghr(VALUE mLapack){
- rb_define_module_function(mLapack, "zunghr", rb_zunghr, -1);
-}
diff --git a/zungl2.c b/zungl2.c
deleted file mode 100644
index 5be094f..0000000
--- a/zungl2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zungl2_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zungl2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zungl2( a, tau)\n or\n NumRu::Lapack.zungl2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n* which is defined as the first m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by ZGELQF in the first k rows of its array argument A.\n* On exit, the m by n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (m));
-
- zungl2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zungl2(VALUE mLapack){
- rb_define_module_function(mLapack, "zungl2", rb_zungl2, -1);
-}
diff --git a/zunglq.c b/zunglq.c
deleted file mode 100644
index f962666..0000000
--- a/zunglq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunglq_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunglq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zunglq( m, a, tau, lwork)\n or\n NumRu::Lapack.zunglq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the first M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th row must contain the vector which defines\n* the elementary reflector H(i), for i = 1,2,...,k, as returned\n* by ZGELQF in the first k rows of its array argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is\n* the optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zunglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zunglq(VALUE mLapack){
- rb_define_module_function(mLapack, "zunglq", rb_zunglq, -1);
-}
diff --git a/zungql.c b/zungql.c
deleted file mode 100644
index 90df73b..0000000
--- a/zungql.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zungql_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zungql(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungql( m, a, tau, lwork)\n or\n NumRu::Lapack.zungql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the last N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (n-k+i)-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQLF in the last k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zungql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zungql(VALUE mLapack){
- rb_define_module_function(mLapack, "zungql", rb_zungql, -1);
-}
diff --git a/zungqr.c b/zungqr.c
deleted file mode 100644
index fd77fb0..0000000
--- a/zungqr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zungqr_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zungqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungqr( m, a, tau, lwork)\n or\n NumRu::Lapack.zungqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n* which is defined as the first N columns of a product of K elementary\n* reflectors of order M\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. M >= N >= 0.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. N >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the i-th column must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGEQRF in the first k columns of its array\n* argument A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,N).\n* For optimum performance LWORK >= N*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zungqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zungqr(VALUE mLapack){
- rb_define_module_function(mLapack, "zungqr", rb_zungqr, -1);
-}
diff --git a/zungr2.c b/zungr2.c
deleted file mode 100644
index dcbcc88..0000000
--- a/zungr2.c
+++ /dev/null
@@ -1,71 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zungr2_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zungr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
- doublecomplex *work;
-
- integer lda;
- integer n;
- integer k;
- integer m;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, a = NumRu::Lapack.zungr2( a, tau)\n or\n NumRu::Lapack.zungr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n* which is defined as the last m rows of a product of k elementary\n* reflectors of order n\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGERQF in the last k rows of its array argument\n* A.\n* On exit, the m-by-n matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* WORK (workspace) COMPLEX*16 array, dimension (M)\n*\n* INFO (output) INTEGER\n* = 0: successful exit\n* < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 2)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
- rb_a = argv[0];
- rb_tau = argv[1];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (1th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- m = lda;
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
- work = ALLOC_N(doublecomplex, (m));
-
- zungr2_(&m, &n, &k, a, &lda, tau, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_a);
-}
-
-void
-init_lapack_zungr2(VALUE mLapack){
- rb_define_module_function(mLapack, "zungr2", rb_zungr2, -1);
-}
diff --git a/zungrq.c b/zungrq.c
deleted file mode 100644
index 5a5b22e..0000000
--- a/zungrq.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zungrq_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zungrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
- integer k;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungrq( m, a, tau, lwork)\n or\n NumRu::Lapack.zungrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n* which is defined as the last M rows of a product of K elementary\n* reflectors of order N\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF.\n*\n\n* Arguments\n* =========\n*\n* M (input) INTEGER\n* The number of rows of the matrix Q. M >= 0.\n*\n* N (input) INTEGER\n* The number of columns of the matrix Q. N >= M.\n*\n* K (input) INTEGER\n* The number of elementary reflectors whose product defines the\n* matrix Q. M >= K >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the (m-k+i)-th row must contain the vector which\n* defines the elementary reflector H(i), for i = 1,2,...,k, as\n* returned by ZGERQF in the last k rows of its array argument\n* A.\n* On exit, the M-by-N matrix Q.\n*\n* LDA (input) INTEGER\n* The first dimension of the array A. LDA >= max(1,M).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= max(1,M).\n* For optimum performance LWORK >= M*NB, where NB is the\n* optimal blocksize.\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 has an illegal value\n*\n\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_m = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- m = NUM2INT(rb_m);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zungrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zungrq(VALUE mLapack){
- rb_define_module_function(mLapack, "zungrq", rb_zungrq, -1);
-}
diff --git a/zungtr.c b/zungtr.c
deleted file mode 100644
index 8210aad..0000000
--- a/zungtr.c
+++ /dev/null
@@ -1,82 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zungtr_(char *uplo, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zungtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_a_out__;
- doublecomplex *a_out__;
-
- integer lda;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, a = NumRu::Lapack.zungtr( uplo, a, tau, lwork)\n or\n NumRu::Lapack.zungtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors of order N, as returned by\n* ZHETRD:\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 triangle of A contains elementary reflectors\n* from ZHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from ZHETRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* A (input/output) COMPLEX*16 array, dimension (LDA,N)\n* On entry, the vectors which define the elementary reflectors,\n* as returned by ZHETRD.\n* On exit, the N-by-N unitary matrix Q.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= N.\n*\n* TAU (input) COMPLEX*16 array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZHETRD.\n*\n* WORK (workspace/output) COMPLEX*16 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 >= N-1.\n* For optimum performance LWORK >= (N-1)*NB, where NB is\n* the optimal blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 4)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
- rb_uplo = argv[0];
- rb_a = argv[1];
- rb_tau = argv[2];
- rb_lwork = argv[3];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (2th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 2);
- n = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (n-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = lda;
- shape[1] = n;
- rb_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- a_out__ = NA_PTR_TYPE(rb_a_out__, doublecomplex*);
- MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rb_a));
- rb_a = rb_a_out__;
- a = a_out__;
-
- zungtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_a);
-}
-
-void
-init_lapack_zungtr(VALUE mLapack){
- rb_define_module_function(mLapack, "zungtr", rb_zungtr, -1);
-}
diff --git a/zunm2l.c b/zunm2l.c
deleted file mode 100644
index 6ea8437..0000000
--- a/zunm2l.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunm2l_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zunm2l(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.zunm2l( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.zunm2l # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNM2L overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zunm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_zunm2l(VALUE mLapack){
- rb_define_module_function(mLapack, "zunm2l", rb_zunm2l, -1);
-}
diff --git a/zunm2r.c b/zunm2r.c
deleted file mode 100644
index 2e498bb..0000000
--- a/zunm2r.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunm2r_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zunm2r(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.zunm2r( side, trans, m, a, tau, c)\n or\n NumRu::Lapack.zunm2r # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNM2R overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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 (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zunm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_zunm2r(VALUE mLapack){
- rb_define_module_function(mLapack, "zunm2r", rb_zunm2r, -1);
-}
diff --git a/zunmbr.c b/zunmbr.c
deleted file mode 100644
index b0ee9f4..0000000
--- a/zunmbr.c
+++ /dev/null
@@ -1,114 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmbr_(char *vect, char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmbr(int argc, VALUE *argv, VALUE self){
- VALUE rb_vect;
- char vect;
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_k;
- integer k;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer ldc;
- integer n;
- integer nq;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmbr( vect, side, trans, m, k, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmbr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C\n* with\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': P * C C * P\n* TRANS = 'C': P**H * C C * P**H\n*\n* Here Q and P**H are the unitary matrices determined by ZGEBRD when\n* reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n* and P**H are defined as products of elementary reflectors H(i) and\n* G(i) respectively.\n*\n* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n* order of the unitary matrix Q or P**H that is applied.\n*\n* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n* if nq >= k, Q = H(1) H(2) . . . H(k);\n* if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n* if k < nq, P = G(1) G(2) . . . G(k);\n* if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n* Arguments\n* =========\n*\n* VECT (input) CHARACTER*1\n* = 'Q': apply Q or Q**H;\n* = 'P': apply P or P**H.\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q, Q**H, P or P**H from the Left;\n* = 'R': apply Q, Q**H, P or P**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q or P;\n* = 'C': Conjugate transpose, apply Q**H or P**H.\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* K (input) INTEGER\n* If VECT = 'Q', the number of columns in the original\n* matrix reduced by ZGEBRD.\n* If VECT = 'P', the number of rows in the original\n* matrix reduced by ZGEBRD.\n* K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,min(nq,K)) if VECT = 'Q'\n* (LDA,nq) if VECT = 'P'\n* The vectors which define the elementary reflectors H(i) and\n* G(i), whose products determine the matrices Q and P, as\n* returned by ZGEBRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If VECT = 'Q', LDA >= max(1,nq);\n* if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n* TAU (input) COMPLEX*16 array, dimension (min(nq,K))\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i) or G(i) which determines Q or P, as returned\n* by ZGEBRD in the array argument TAUQ or TAUP.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n* or P*C or P**H*C or C*P or C*P**H.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M);\n* if N = 0 or M = 0, LWORK >= 1.\n* For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n* and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n* optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMLQ, ZUNMQR\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 9)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
- rb_vect = argv[0];
- rb_side = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_k = argv[4];
- rb_a = argv[5];
- rb_tau = argv[6];
- rb_c = argv[7];
- rb_lwork = argv[8];
-
- k = NUM2INT(rb_k);
- lwork = NUM2INT(rb_lwork);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- vect = StringValueCStr(rb_vect)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (8th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (6th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
- if (NA_SHAPE1(rb_a) != (MIN(nq,k)))
- rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmbr(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmbr", rb_zunmbr, -1);
-}
diff --git a/zunmhr.c b/zunmhr.c
deleted file mode 100644
index 0bf236a..0000000
--- a/zunmhr.c
+++ /dev/null
@@ -1,108 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmhr_(char *side, char *trans, integer *m, integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmhr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_ilo;
- integer ilo;
- VALUE rb_ihi;
- integer ihi;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmhr( side, trans, ilo, ihi, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmhr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMHR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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* IHI-ILO elementary reflectors, as returned by ZGEHRD:\n*\n* Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q**H (Conjugate transpose)\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* ILO (input) INTEGER\n* IHI (input) INTEGER\n* ILO and IHI must have the same values as in the previous call\n* of ZGEHRD. Q is equal to the unit matrix except in the\n* submatrix Q(ilo+1:ihi,ilo+1:ihi).\n* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n* ILO = 1 and IHI = 0, if M = 0;\n* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n* ILO = 1 and IHI = 0, if N = 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by ZGEHRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX*16 array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEHRD.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMQR\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n* ..\n\n");
- return Qnil;
- }
- if (argc != 8)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_ilo = argv[2];
- rb_ihi = argv[3];
- rb_a = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
- rb_lwork = argv[7];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (5th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- ilo = NUM2INT(rb_ilo);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- ihi = NUM2INT(rb_ihi);
- trans = StringValueCStr(rb_trans)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmhr(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmhr", rb_zunmhr, -1);
-}
diff --git a/zunml2.c b/zunml2.c
deleted file mode 100644
index 61780e8..0000000
--- a/zunml2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunml2_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zunml2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.zunml2( side, trans, a, tau, c)\n or\n NumRu::Lapack.zunml2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNML2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zunml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_zunml2(VALUE mLapack){
- rb_define_module_function(mLapack, "zunml2", rb_zunml2, -1);
-}
diff --git a/zunmlq.c b/zunmlq.c
deleted file mode 100644
index 651693a..0000000
--- a/zunmlq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmlq_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmlq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmlq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmlq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMLQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k)' . . . H(2)' H(1)'\n*\n* as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGELQF in the first k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGELQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmlq(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmlq", rb_zunmlq, -1);
-}
diff --git a/zunmql.c b/zunmql.c
deleted file mode 100644
index 1ba351c..0000000
--- a/zunmql.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmql_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmql(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmql( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmql # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMQL overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(k) . . . H(2) H(1)\n*\n* as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQLF in the last k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQLF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmql(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmql", rb_zunmql, -1);
-}
diff --git a/zunmqr.c b/zunmqr.c
deleted file mode 100644
index a8562e7..0000000
--- a/zunmqr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmqr_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmqr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmqr( side, trans, m, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmqr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMQR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension (LDA,K)\n* The i-th column must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGEQRF in the first k columns of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* If SIDE = 'L', LDA >= max(1,M);\n* if SIDE = 'R', LDA >= max(1,N).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGEQRF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_m = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- k = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != k)
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be the same as shape 1 of a");
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmqr(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmqr", rb_zunmqr, -1);
-}
diff --git a/zunmr2.c b/zunmr2.c
deleted file mode 100644
index d24903b..0000000
--- a/zunmr2.c
+++ /dev/null
@@ -1,91 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmr2_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zunmr2(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.zunmr2( side, trans, a, tau, c)\n or\n NumRu::Lapack.zunmr2 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMR2 overwrites the general complex m-by-n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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 (argc != 5)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zunmr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmr2(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmr2", rb_zunmr2, -1);
-}
diff --git a/zunmr3.c b/zunmr3.c
deleted file mode 100644
index 064bf80..0000000
--- a/zunmr3.c
+++ /dev/null
@@ -1,95 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmr3_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zunmr3(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.zunmr3( side, trans, l, a, tau, c)\n or\n NumRu::Lapack.zunmr3 # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMR3 overwrites the general complex m by n matrix C with\n*\n* Q * C if SIDE = 'L' and TRANS = 'N', or\n*\n* Q'* C if SIDE = 'L' and TRANS = 'C', or\n*\n* C * Q if SIDE = 'R' and TRANS = 'N', or\n*\n* C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q' from the Left\n* = 'R': apply Q or Q' from the Right\n*\n* TRANS (input) CHARACTER*1\n* = 'N': apply Q (No transpose)\n* = 'C': apply Q' (Conjugate transpose)\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZTZRZF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the m-by-n matrix C.\n* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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* Further Details\n* ===============\n*\n* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n COMPLEX*16 TAUI\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZLARZ\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC DCONJG, MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zunmr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmr3(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmr3", rb_zunmr3, -1);
-}
diff --git a/zunmrq.c b/zunmrq.c
deleted file mode 100644
index 5aa708d..0000000
--- a/zunmrq.c
+++ /dev/null
@@ -1,100 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmrq_(char *side, char *trans, integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmrq(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmrq( side, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmrq # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMRQ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1)' H(2)' . . . H(k)'\n*\n* as returned by ZGERQF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZGERQF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZGERQF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 6)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_a = argv[2];
- rb_tau = argv[3];
- rb_c = argv[4];
- rb_lwork = argv[5];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (3th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (5th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmrq(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmrq", rb_zunmrq, -1);
-}
diff --git a/zunmrz.c b/zunmrz.c
deleted file mode 100644
index 060140d..0000000
--- a/zunmrz.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmrz_(char *side, char *trans, integer *m, integer *n, integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmrz(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_trans;
- char trans;
- VALUE rb_l;
- integer l;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer m;
- integer k;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmrz( side, trans, l, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmrz # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMRZ overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary matrix defined as the product of k\n* elementary reflectors\n*\n* Q = H(1) H(2) . . . H(k)\n*\n* as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N\n* if SIDE = 'R'.\n*\n\n* Arguments\n* =========\n*\n* SIDE (input) CHARACTER*1\n* = 'L': apply Q or Q**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* K (input) INTEGER\n* The number of elementary reflectors whose product defines\n* the matrix Q.\n* If SIDE = 'L', M >= K >= 0;\n* if SIDE = 'R', N >= K >= 0.\n*\n* L (input) INTEGER\n* The number of columns of the matrix A containing\n* the meaningful part of the Householder reflectors.\n* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L',\n* (LDA,N) if SIDE = 'R'\n* The i-th row must contain the vector which defines the\n* elementary reflector H(i), for i = 1,2,...,k, as returned by\n* ZTZRZF in the last k rows of its array argument A.\n* A is modified by the routine but restored on exit.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A. LDA >= max(1,K).\n*\n* TAU (input) COMPLEX*16 array, dimension (K)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZTZRZF.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* Based on contributions by\n* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_trans = argv[1];
- rb_l = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- l = NUM2INT(rb_l);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- k = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmrz(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmrz", rb_zunmrz, -1);
-}
diff --git a/zunmtr.c b/zunmtr.c
deleted file mode 100644
index 2f7c296..0000000
--- a/zunmtr.c
+++ /dev/null
@@ -1,104 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zunmtr_(char *side, char *uplo, char *trans, integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *lwork, integer *info);
-
-static VALUE
-rb_zunmtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_a;
- doublecomplex *a;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_lwork;
- integer lwork;
- VALUE rb_work;
- doublecomplex *work;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
-
- integer lda;
- integer m;
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n work, info, c = NumRu::Lapack.zunmtr( side, uplo, trans, a, tau, c, lwork)\n or\n NumRu::Lapack.zunmtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUNMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 ZHETRD:\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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangle of A contains elementary reflectors\n* from ZHETRD;\n* = 'L': Lower triangle of A contains elementary reflectors\n* from ZHETRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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* A (input) COMPLEX*16 array, dimension\n* (LDA,M) if SIDE = 'L'\n* (LDA,N) if SIDE = 'R'\n* The vectors which define the elementary reflectors, as\n* returned by ZHETRD.\n*\n* LDA (input) INTEGER\n* The leading dimension of the array A.\n* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n* TAU (input) COMPLEX*16 array, dimension\n* (M-1) if SIDE = 'L'\n* (N-1) if SIDE = 'R'\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZHETRD.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace/output) COMPLEX*16 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.\n* If SIDE = 'L', LWORK >= max(1,N);\n* if SIDE = 'R', LWORK >= max(1,M).\n* For optimum performance LWORK >= N*NB if SIDE = 'L', and\n* LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n* blocksize.\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* =====================================================================\n*\n* .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n* ..\n* .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n* ..\n* .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMQL, ZUNMQR\n* ..\n* .. Intrinsic Functions ..\n INTRINSIC MAX\n* ..\n\n");
- return Qnil;
- }
- if (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_a = argv[3];
- rb_tau = argv[4];
- rb_c = argv[5];
- rb_lwork = argv[6];
-
- if (!NA_IsNArray(rb_a))
- rb_raise(rb_eArgError, "a (4th argument) must be NArray");
- if (NA_RANK(rb_a) != 2)
- rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
- m = NA_SHAPE1(rb_a);
- lda = NA_SHAPE0(rb_a);
- if (NA_TYPE(rb_a) != NA_DCOMPLEX)
- rb_a = na_change_type(rb_a, NA_DCOMPLEX);
- a = NA_PTR_TYPE(rb_a, doublecomplex*);
- side = StringValueCStr(rb_side)[0];
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (6th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- lwork = NUM2INT(rb_lwork);
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- {
- int shape[1];
- shape[0] = MAX(1,lwork);
- rb_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
- }
- work = NA_PTR_TYPE(rb_work, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
-
- zunmtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);
-
- rb_info = INT2NUM(info);
- return rb_ary_new3(3, rb_work, rb_info, rb_c);
-}
-
-void
-init_lapack_zunmtr(VALUE mLapack){
- rb_define_module_function(mLapack, "zunmtr", rb_zunmtr, -1);
-}
diff --git a/zupgtr.c b/zupgtr.c
deleted file mode 100644
index 1150dfd..0000000
--- a/zupgtr.c
+++ /dev/null
@@ -1,72 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zupgtr_(char *uplo, integer *n, doublecomplex *ap, doublecomplex *tau, doublecomplex *q, integer *ldq, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zupgtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_uplo;
- char uplo;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_q;
- doublecomplex *q;
- VALUE rb_info;
- integer info;
- doublecomplex *work;
-
- integer ldap;
- integer ldtau;
- integer ldq;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n q, info = NumRu::Lapack.zupgtr( uplo, ap, tau)\n or\n NumRu::Lapack.zupgtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUPGTR generates a complex unitary matrix Q which is defined as the\n* product of n-1 elementary reflectors H(i) of order n, as returned by\n* ZHPTRD 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 ZHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to ZHPTRD.\n*\n* N (input) INTEGER\n* The order of the matrix Q. N >= 0.\n*\n* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n* The vectors which define the elementary reflectors, as\n* returned by ZHPTRD.\n*\n* TAU (input) COMPLEX*16 array, dimension (N-1)\n* TAU(i) must contain the scalar factor of the elementary\n* reflector H(i), as returned by ZHPTRD.\n*\n* Q (output) COMPLEX*16 array, dimension (LDQ,N)\n* The N-by-N unitary matrix Q.\n*\n* LDQ (input) INTEGER\n* The leading dimension of the array Q. LDQ >= max(1,N).\n*\n* WORK (workspace) COMPLEX*16 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 (argc != 3)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
- rb_uplo = argv[0];
- rb_ap = argv[1];
- rb_tau = argv[2];
-
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
- ldtau = NA_SHAPE0(rb_tau);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
- ldap = NA_SHAPE0(rb_ap);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- n = ldtau+1;
- ldq = MAX(1,n);
- {
- int shape[2];
- shape[0] = ldq;
- shape[1] = n;
- rb_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- q = NA_PTR_TYPE(rb_q, doublecomplex*);
- work = ALLOC_N(doublecomplex, (n-1));
-
- zupgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_q, rb_info);
-}
-
-void
-init_lapack_zupgtr(VALUE mLapack){
- rb_define_module_function(mLapack, "zupgtr", rb_zupgtr, -1);
-}
diff --git a/zupmtr.c b/zupmtr.c
deleted file mode 100644
index a137e1c..0000000
--- a/zupmtr.c
+++ /dev/null
@@ -1,97 +0,0 @@
-#include "rb_lapack.h"
-
-extern VOID zupmtr_(char *side, char *uplo, char *trans, integer *m, integer *n, doublecomplex *ap, doublecomplex *tau, doublecomplex *c, integer *ldc, doublecomplex *work, integer *info);
-
-static VALUE
-rb_zupmtr(int argc, VALUE *argv, VALUE self){
- VALUE rb_side;
- char side;
- VALUE rb_uplo;
- char uplo;
- VALUE rb_trans;
- char trans;
- VALUE rb_m;
- integer m;
- VALUE rb_ap;
- doublecomplex *ap;
- VALUE rb_tau;
- doublecomplex *tau;
- VALUE rb_c;
- doublecomplex *c;
- VALUE rb_info;
- integer info;
- VALUE rb_c_out__;
- doublecomplex *c_out__;
- doublecomplex *work;
-
- integer ldc;
- integer n;
-
- if (argc == 0) {
- printf("%s\n", "USAGE:\n info, c = NumRu::Lapack.zupmtr( side, uplo, trans, m, ap, tau, c)\n or\n NumRu::Lapack.zupmtr # print help\n\n\nFORTRAN MANUAL\n SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n* Purpose\n* =======\n*\n* ZUPMTR overwrites the general complex M-by-N matrix C with\n*\n* SIDE = 'L' SIDE = 'R'\n* TRANS = 'N': Q * C C * Q\n* TRANS = 'C': Q**H * C C * Q**H\n*\n* where Q is a complex unitary 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 ZHPTRD 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**H from the Left;\n* = 'R': apply Q or Q**H from the Right.\n*\n* UPLO (input) CHARACTER*1\n* = 'U': Upper triangular packed storage used in previous\n* call to ZHPTRD;\n* = 'L': Lower triangular packed storage used in previous\n* call to ZHPTRD.\n*\n* TRANS (input) CHARACTER*1\n* = 'N': No transpose, apply Q;\n* = 'C': Conjugate transpose, apply Q**H.\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) COMPLEX*16 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 ZHPTRD. AP is modified by the routine but\n* restored on exit.\n*\n* TAU (input) COMPLEX*16 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 ZHPTRD.\n*\n* C (input/output) COMPLEX*16 array, dimension (LDC,N)\n* On entry, the M-by-N matrix C.\n* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n* LDC (input) INTEGER\n* The leading dimension of the array C. LDC >= max(1,M).\n*\n* WORK (workspace) COMPLEX*16 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 (argc != 7)
- rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
- rb_side = argv[0];
- rb_uplo = argv[1];
- rb_trans = argv[2];
- rb_m = argv[3];
- rb_ap = argv[4];
- rb_tau = argv[5];
- rb_c = argv[6];
-
- side = StringValueCStr(rb_side)[0];
- m = NUM2INT(rb_m);
- if (!NA_IsNArray(rb_c))
- rb_raise(rb_eArgError, "c (7th argument) must be NArray");
- if (NA_RANK(rb_c) != 2)
- rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
- n = NA_SHAPE1(rb_c);
- ldc = NA_SHAPE0(rb_c);
- if (NA_TYPE(rb_c) != NA_DCOMPLEX)
- rb_c = na_change_type(rb_c, NA_DCOMPLEX);
- c = NA_PTR_TYPE(rb_c, doublecomplex*);
- trans = StringValueCStr(rb_trans)[0];
- uplo = StringValueCStr(rb_uplo)[0];
- if (!NA_IsNArray(rb_tau))
- rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
- if (NA_RANK(rb_tau) != 1)
- rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
- if (NA_SHAPE0(rb_tau) != (m-1))
- rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
- if (NA_TYPE(rb_tau) != NA_DCOMPLEX)
- rb_tau = na_change_type(rb_tau, NA_DCOMPLEX);
- tau = NA_PTR_TYPE(rb_tau, doublecomplex*);
- if (!NA_IsNArray(rb_ap))
- rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
- if (NA_RANK(rb_ap) != 1)
- rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
- if (NA_SHAPE0(rb_ap) != (m*(m+1)/2))
- rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
- if (NA_TYPE(rb_ap) != NA_DCOMPLEX)
- rb_ap = na_change_type(rb_ap, NA_DCOMPLEX);
- ap = NA_PTR_TYPE(rb_ap, doublecomplex*);
- {
- int shape[2];
- shape[0] = ldc;
- shape[1] = n;
- rb_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
- }
- c_out__ = NA_PTR_TYPE(rb_c_out__, doublecomplex*);
- MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rb_c));
- rb_c = rb_c_out__;
- c = c_out__;
- work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));
-
- zupmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);
-
- free(work);
- rb_info = INT2NUM(info);
- return rb_ary_new3(2, rb_info, rb_c);
-}
-
-void
-init_lapack_zupmtr(VALUE mLapack){
- rb_define_module_function(mLapack, "zupmtr", rb_zupmtr, -1);
-}
--
Packaging for ruby-lapack
More information about the Pkg-ruby-extras-commits
mailing list